3 * Copyright (c) 1996-2001, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
37 perlsio_binmode(FILE *fp, int iotype, int mode)
39 /* This used to be contents of do_binmode in doio.c */
41 # if defined(atarist) || defined(__MINT__)
44 ((FILE*)fp)->_flag |= _IOBIN;
46 ((FILE*)fp)->_flag &= ~ _IOBIN;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
53 # if defined(WIN32) && defined(__BORLANDC__)
54 /* The translation mode of the stream is maintained independent
55 * of the translation mode of the fd in the Borland RTL (heavy
56 * digging through their runtime sources reveal). User has to
57 * set the mode explicitly for the stream (though they don't
58 * document this anywhere). GSAR 97-5-24
64 fp->flags &= ~ _F_BIN;
72 # if defined(USEMYBINMODE)
73 if (my_binmode(fp, iotype, mode) != FALSE)
85 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
87 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
91 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
102 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
104 return perlsio_binmode(fp,iotype,mode);
107 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
110 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
114 if (*args == &PL_sv_undef)
115 return PerlIO_tmpfile();
118 char *name = SvPV_nolen(*args);
121 fd = PerlLIO_open3(name,imode,perm);
123 return PerlIO_fdopen(fd,(char *)mode+1);
127 return PerlIO_reopen(name,mode,old);
131 return PerlIO_open(name,mode);
137 return PerlIO_fdopen(fd,(char *)mode);
145 #ifdef PERLIO_IS_STDIO
150 /* Does nothing (yet) except force this file to be included
151 in perl binary. That allows this file to force inclusion
152 of other functions that may be required by loadable
153 extensions e.g. for FileHandle::tmpfile
157 #undef PerlIO_tmpfile
164 #else /* PERLIO_IS_STDIO */
171 /* This section is just to make sure these functions
172 get pulled in from libsfio.a
175 #undef PerlIO_tmpfile
185 /* Force this file to be included in perl binary. Which allows
186 * this file to force inclusion of other functions that may be
187 * required by loadable extensions e.g. for FileHandle::tmpfile
191 * sfio does its own 'autoflush' on stdout in common cases.
192 * Flush results in a lot of lseek()s to regular files and
193 * lot of small writes to pipes.
195 sfset(sfstdout,SF_SHARE,0);
199 /*======================================================================================*/
200 /* Implement all the PerlIO interface ourselves.
205 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
210 #include <sys/mman.h>
215 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
218 PerlIO_debug(const char *fmt,...)
226 char *s = PerlEnv_getenv("PERLIO_DEBUG");
228 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
235 SV *sv = newSVpvn("",0);
238 s = CopFILE(PL_curcop);
241 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
242 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
245 PerlLIO_write(dbg,s,len);
251 /*--------------------------------------------------------------------------------------*/
253 /* Inner level routines */
255 /* Table of pointers to the PerlIO structs (malloc'ed) */
256 PerlIO *_perlio = NULL;
257 #define PERLIO_TABLE_SIZE 64
262 PerlIO_allocate(pTHX)
264 /* Find a free slot in the table, allocating new table as necessary */
271 last = (PerlIO **)(f);
272 for (i=1; i < PERLIO_TABLE_SIZE; i++)
280 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
290 PerlIO_cleantable(pTHX_ PerlIO **tablep)
292 PerlIO *table = *tablep;
296 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
297 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
305 PerlMemShared_free(table);
314 PerlIO_cleanup_layers(pTHXo_ void *data)
316 PerlIO_layer_hv = Nullhv;
317 PerlIO_layer_av = Nullav;
324 PerlIO_cleantable(aTHX_ &_perlio);
328 PerlIO_destruct(pTHX)
330 PerlIO **table = &_perlio;
335 table = (PerlIO **)(f++);
336 for (i=1; i < PERLIO_TABLE_SIZE; i++)
342 if (l->tab->kind & PERLIO_K_DESTRUCT)
344 PerlIO_debug("Destruct popping %s\n",l->tab->name);
359 PerlIO_pop(pTHX_ PerlIO *f)
364 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
366 (*l->tab->Popped)(f);
368 PerlMemShared_free(l);
372 /*--------------------------------------------------------------------------------------*/
373 /* XS Interface for perl code */
376 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
380 if ((SSize_t) len <= 0)
382 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
383 if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
385 SV *pkgsv = newSVpvn("PerlIO",6);
386 SV *layer = newSVpvn(name,len);
388 /* The two SVs are magically freed by load_module */
389 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
391 /* Say this is lvalue so we get an 'undef' if still not there */
392 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
394 if (svp && (sv = *svp))
404 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
408 IO *io = GvIOn((GV *)SvRV(sv));
409 PerlIO *ifp = IoIFP(io);
410 PerlIO *ofp = IoOFP(io);
411 AV *av = (AV *) mg->mg_obj;
412 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
418 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
422 IO *io = GvIOn((GV *)SvRV(sv));
423 PerlIO *ifp = IoIFP(io);
424 PerlIO *ofp = IoOFP(io);
425 AV *av = (AV *) mg->mg_obj;
426 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
432 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
434 Perl_warn(aTHX_ "clear %"SVf,sv);
439 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
441 Perl_warn(aTHX_ "free %"SVf,sv);
445 MGVTBL perlio_vtab = {
453 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
456 SV *sv = SvRV(ST(1));
461 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
463 mg = mg_find(sv, PERL_MAGIC_ext);
464 mg->mg_virtual = &perlio_vtab;
466 Perl_warn(aTHX_ "attrib %"SVf,sv);
467 for (i=2; i < items; i++)
470 const char *name = SvPV(ST(i),len);
471 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
474 av_push(av,SvREFCNT_inc(layer));
487 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
489 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
490 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
495 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
497 if (!PerlIO_layer_hv)
499 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
501 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
502 PerlIO_debug("define %s %p\n",tab->name,tab);
506 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
510 const char *s = names;
513 while (isSPACE(*s) || *s == ':')
519 const char *as = Nullch;
523 /* Message is consistent with how attribute lists are passed.
524 Even though this means "foo : : bar" is seen as an invalid separator
526 char q = ((*s == '\'') ? '"' : '\'');
527 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
533 } while (isALNUM(*e));
551 /* It's a nul terminated string, not allowed to \ the terminating null.
552 Anything other character is passed over. */
560 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
570 SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
573 av_push(av,SvREFCNT_inc(layer));
574 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
577 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
589 PerlIO_default_buffer(pTHX_ AV *av)
591 PerlIO_funcs *tab = &PerlIO_perlio;
592 if (O_BINARY != O_TEXT)
598 if (PerlIO_stdio.Set_ptrcnt)
603 PerlIO_debug("Pushing %s\n",tab->name);
604 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
605 av_push(av,&PL_sv_undef);
609 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
611 SV **svp = av_fetch(av,n,FALSE);
612 return (svp) ? *svp : Nullsv;
616 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
618 SV **svp = av_fetch(av,n,FALSE);
620 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
622 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
623 return INT2PTR(PerlIO_funcs *, SvIV(layer));
626 Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
631 PerlIO_default_layers(pTHX)
634 if (!PerlIO_layer_av)
636 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
637 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
639 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
641 PerlIO_define_layer(aTHX_ &PerlIO_raw);
642 PerlIO_define_layer(aTHX_ &PerlIO_unix);
643 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
644 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
645 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
647 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
649 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
650 PerlIO_define_layer(aTHX_ &PerlIO_byte);
651 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
652 av_push(PerlIO_layer_av,&PL_sv_undef);
655 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
659 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
662 len = av_len(PerlIO_layer_av)+1;
665 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
666 len = av_len(PerlIO_layer_av);
668 return PerlIO_layer_av;
673 PerlIO_default_layer(pTHX_ I32 n)
675 AV *av = PerlIO_default_layers(aTHX);
678 n += av_len(PerlIO_layer_av)+1;
679 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
682 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
683 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
686 PerlIO_stdstreams(pTHX)
690 PerlIO_allocate(aTHX);
691 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
692 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
693 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
698 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
701 l = PerlMemShared_calloc(tab->size,sizeof(char));
704 Zero(l,tab->size,char);
708 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
709 (mode) ? mode : "(Null)",arg);
710 if ((*l->tab->Pushed)(f,mode,arg) != 0)
720 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
734 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
736 /* Remove the dummy layer */
739 /* Pop back to bottom layer */
744 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
752 /* Nothing bellow - push unix on top then remove it */
753 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
755 PerlIO_pop(aTHX_ PerlIONext(f));
760 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
767 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
769 IV max = av_len(layers)+1;
773 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
776 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
788 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
793 AV *layers = newAV();
794 code = PerlIO_parse_layers(aTHX_ layers,names);
797 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
799 SvREFCNT_dec((SV *) layers);
805 /*--------------------------------------------------------------------------------------*/
806 /* Given the abstraction above the public API functions */
809 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
811 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
812 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
813 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
819 if (PerlIOBase(top)->tab == &PerlIO_crlf)
822 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
825 top = PerlIONext(top);
828 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
833 PerlIO__close(PerlIO *f)
836 return (*PerlIOBase(f)->tab->Close)(f);
839 SETERRNO(EBADF,SS$_IVCHAN);
844 #undef PerlIO_fdupopen
846 PerlIO_fdupopen(pTHX_ PerlIO *f)
851 int fd = PerlLIO_dup(PerlIO_fileno(f));
852 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
855 Off_t posn = PerlIO_tell(f);
856 PerlIO_seek(new,posn,SEEK_SET);
862 SETERRNO(EBADF,SS$_IVCHAN);
869 PerlIO_close(PerlIO *f)
875 code = (*PerlIOBase(f)->tab->Close)(f);
886 PerlIO_fileno(PerlIO *f)
889 return (*PerlIOBase(f)->tab->Fileno)(f);
892 SETERRNO(EBADF,SS$_IVCHAN);
898 PerlIO_context_layers(pTHX_ const char *mode)
900 const char *type = NULL;
901 /* Need to supply default layer info from open.pm */
904 SV *layers = PL_curcop->cop_io;
908 type = SvPV(layers,len);
909 if (type && mode[0] != 'r')
911 /* Skip to write part */
912 const char *s = strchr(type,0);
913 if (s && (s-type) < len)
924 PerlIO_layer_from_ref(pTHX_ SV *sv)
926 /* For any scalar type load the handler which is bundled with perl */
927 if (SvTYPE(sv) < SVt_PVAV)
928 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
930 /* For other types allow if layer is known but don't try and load it */
934 return PerlIO_find_layer(aTHX_ "Array",5, 0);
936 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
938 return PerlIO_find_layer(aTHX_ "Code",4, 0);
940 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
946 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
948 AV *def = PerlIO_default_layers(aTHX);
951 PerlIO_stdstreams(aTHX);
955 /* If it is a reference but not an object see if we have a handler for it */
956 if (SvROK(arg) && !sv_isobject(arg))
958 SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
962 av_push(def,SvREFCNT_inc(handler));
963 av_push(def,&PL_sv_undef);
966 /* Don't fail if handler cannot be found
967 * :Via(...) etc. may do something sensible
968 * else we will just stringfy and open resulting string.
973 layers = PerlIO_context_layers(aTHX_ mode);
974 if (layers && *layers)
979 IV n = av_len(def)+1;
983 SV **svp = av_fetch(def,n,0);
984 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
991 PerlIO_parse_layers(aTHX_ av,layers);
1003 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1005 if (!f && narg == 1 && *args == &PL_sv_undef)
1007 if ((f = PerlIO_tmpfile()))
1010 layers = PerlIO_context_layers(aTHX_ mode);
1011 if (layers && *layers)
1012 PerlIO_apply_layers(aTHX_ f,mode,layers);
1022 /* This is "reopen" - it is not tested as perl does not use it yet */
1027 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1028 av_unshift(layera,2);
1029 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1030 av_store(layera,1,arg);
1031 l = *PerlIONext(&l);
1036 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1038 n = av_len(layera)-1;
1041 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1051 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1052 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1053 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1056 if (n+2 < av_len(layera)+1)
1058 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1065 SvREFCNT_dec(layera);
1071 #undef PerlIO_fdopen
1073 PerlIO_fdopen(int fd, const char *mode)
1076 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1081 PerlIO_open(const char *path, const char *mode)
1084 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1085 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1088 #undef PerlIO_reopen
1090 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1093 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1094 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1099 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1102 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1105 SETERRNO(EBADF,SS$_IVCHAN);
1110 #undef PerlIO_unread
1112 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1115 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1118 SETERRNO(EBADF,SS$_IVCHAN);
1125 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1128 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1131 SETERRNO(EBADF,SS$_IVCHAN);
1138 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1141 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1144 SETERRNO(EBADF,SS$_IVCHAN);
1151 PerlIO_tell(PerlIO *f)
1154 return (*PerlIOBase(f)->tab->Tell)(f);
1157 SETERRNO(EBADF,SS$_IVCHAN);
1164 PerlIO_flush(PerlIO *f)
1170 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1171 if (tab && tab->Flush)
1173 return (*tab->Flush)(f);
1177 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1178 SETERRNO(EBADF,SS$_IVCHAN);
1184 PerlIO_debug("Cannot flush f=%p\n",f);
1185 SETERRNO(EBADF,SS$_IVCHAN);
1191 /* Is it good API design to do flush-all on NULL,
1192 * a potentially errorneous input? Maybe some magical
1193 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1194 * Yes, stdio does similar things on fflush(NULL),
1195 * but should we be bound by their design decisions?
1197 PerlIO **table = &_perlio;
1199 while ((f = *table))
1202 table = (PerlIO **)(f++);
1203 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1205 if (*f && PerlIO_flush(f) != 0)
1215 PerlIOBase_flush_linebuf()
1217 PerlIO **table = &_perlio;
1219 while ((f = *table))
1222 table = (PerlIO **)(f++);
1223 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1225 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1226 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1235 PerlIO_fill(PerlIO *f)
1238 return (*PerlIOBase(f)->tab->Fill)(f);
1241 SETERRNO(EBADF,SS$_IVCHAN);
1246 #undef PerlIO_isutf8
1248 PerlIO_isutf8(PerlIO *f)
1251 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1254 SETERRNO(EBADF,SS$_IVCHAN);
1261 PerlIO_eof(PerlIO *f)
1264 return (*PerlIOBase(f)->tab->Eof)(f);
1267 SETERRNO(EBADF,SS$_IVCHAN);
1274 PerlIO_error(PerlIO *f)
1277 return (*PerlIOBase(f)->tab->Error)(f);
1280 SETERRNO(EBADF,SS$_IVCHAN);
1285 #undef PerlIO_clearerr
1287 PerlIO_clearerr(PerlIO *f)
1290 (*PerlIOBase(f)->tab->Clearerr)(f);
1292 SETERRNO(EBADF,SS$_IVCHAN);
1295 #undef PerlIO_setlinebuf
1297 PerlIO_setlinebuf(PerlIO *f)
1300 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1302 SETERRNO(EBADF,SS$_IVCHAN);
1305 #undef PerlIO_has_base
1307 PerlIO_has_base(PerlIO *f)
1309 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1313 #undef PerlIO_fast_gets
1315 PerlIO_fast_gets(PerlIO *f)
1317 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1319 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1320 return (tab->Set_ptrcnt != NULL);
1325 #undef PerlIO_has_cntptr
1327 PerlIO_has_cntptr(PerlIO *f)
1331 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1332 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1337 #undef PerlIO_canset_cnt
1339 PerlIO_canset_cnt(PerlIO *f)
1343 PerlIOl *l = PerlIOBase(f);
1344 return (l->tab->Set_ptrcnt != NULL);
1349 #undef PerlIO_get_base
1351 PerlIO_get_base(PerlIO *f)
1354 return (*PerlIOBase(f)->tab->Get_base)(f);
1358 #undef PerlIO_get_bufsiz
1360 PerlIO_get_bufsiz(PerlIO *f)
1363 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1367 #undef PerlIO_get_ptr
1369 PerlIO_get_ptr(PerlIO *f)
1371 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1372 if (tab->Get_ptr == NULL)
1374 return (*tab->Get_ptr)(f);
1377 #undef PerlIO_get_cnt
1379 PerlIO_get_cnt(PerlIO *f)
1381 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1382 if (tab->Get_cnt == NULL)
1384 return (*tab->Get_cnt)(f);
1387 #undef PerlIO_set_cnt
1389 PerlIO_set_cnt(PerlIO *f,int cnt)
1391 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1394 #undef PerlIO_set_ptrcnt
1396 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1398 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1399 if (tab->Set_ptrcnt == NULL)
1402 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1404 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1407 /*--------------------------------------------------------------------------------------*/
1408 /* utf8 and raw dummy layers */
1411 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1416 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1417 PerlIO_pop(aTHX_ f);
1418 if (tab->kind & PERLIO_K_UTF8)
1419 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1421 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1427 PerlIO_funcs PerlIO_utf8 = {
1430 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1448 NULL, /* get_base */
1449 NULL, /* get_bufsiz */
1452 NULL, /* set_ptrcnt */
1455 PerlIO_funcs PerlIO_byte = {
1476 NULL, /* get_base */
1477 NULL, /* get_bufsiz */
1480 NULL, /* set_ptrcnt */
1484 PerlIORaw_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1486 PerlIO_funcs *tab = PerlIO_default_btm();
1487 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1490 PerlIO_funcs PerlIO_raw = {
1511 NULL, /* get_base */
1512 NULL, /* get_bufsiz */
1515 NULL, /* set_ptrcnt */
1517 /*--------------------------------------------------------------------------------------*/
1518 /*--------------------------------------------------------------------------------------*/
1519 /* "Methods" of the "base class" */
1522 PerlIOBase_fileno(PerlIO *f)
1524 return PerlIO_fileno(PerlIONext(f));
1528 PerlIO_modestr(PerlIO *f,char *buf)
1531 IV flags = PerlIOBase(f)->flags;
1532 if (flags & PERLIO_F_APPEND)
1535 if (flags & PERLIO_F_CANREAD)
1540 else if (flags & PERLIO_F_CANREAD)
1543 if (flags & PERLIO_F_CANWRITE)
1546 else if (flags & PERLIO_F_CANWRITE)
1549 if (flags & PERLIO_F_CANREAD)
1554 #if O_TEXT != O_BINARY
1555 if (!(flags & PERLIO_F_CRLF))
1563 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1565 PerlIOl *l = PerlIOBase(f);
1566 const char *omode = mode;
1568 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1569 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1570 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1571 if (tab->Set_ptrcnt != NULL)
1572 l->flags |= PERLIO_F_FASTGETS;
1575 if (*mode == '#' || *mode == 'I')
1580 l->flags |= PERLIO_F_CANREAD;
1583 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1586 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1589 SETERRNO(EINVAL,LIB$_INVARG);
1597 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1600 l->flags &= ~PERLIO_F_CRLF;
1603 l->flags |= PERLIO_F_CRLF;
1606 SETERRNO(EINVAL,LIB$_INVARG);
1615 l->flags |= l->next->flags &
1616 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1620 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1621 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1622 l->flags,PerlIO_modestr(f,temp));
1628 PerlIOBase_popped(PerlIO *f)
1634 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1637 Off_t old = PerlIO_tell(f);
1639 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1640 done = PerlIOBuf_unread(f,vbuf,count);
1641 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1646 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1648 STDCHAR *buf = (STDCHAR *) vbuf;
1651 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1655 SSize_t avail = PerlIO_get_cnt(f);
1658 take = (count < avail) ? count : avail;
1661 STDCHAR *ptr = PerlIO_get_ptr(f);
1662 Copy(ptr,buf,take,STDCHAR);
1663 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1667 if (count > 0 && avail <= 0)
1669 if (PerlIO_fill(f) != 0)
1673 return (buf - (STDCHAR *) vbuf);
1679 PerlIOBase_noop_ok(PerlIO *f)
1685 PerlIOBase_noop_fail(PerlIO *f)
1691 PerlIOBase_close(PerlIO *f)
1694 PerlIO *n = PerlIONext(f);
1695 if (PerlIO_flush(f) != 0)
1697 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1699 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1704 PerlIOBase_eof(PerlIO *f)
1708 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1714 PerlIOBase_error(PerlIO *f)
1718 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1724 PerlIOBase_clearerr(PerlIO *f)
1728 PerlIO *n = PerlIONext(f);
1729 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1736 PerlIOBase_setlinebuf(PerlIO *f)
1740 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1744 /*--------------------------------------------------------------------------------------*/
1745 /* Bottom-most level for UNIX-like case */
1749 struct _PerlIO base; /* The generic part */
1750 int fd; /* UNIX like file descriptor */
1751 int oflags; /* open/fcntl flags */
1755 PerlIOUnix_oflags(const char *mode)
1770 oflags = O_CREAT|O_TRUNC;
1781 oflags = O_CREAT|O_APPEND;
1797 else if (*mode == 't')
1800 oflags &= ~O_BINARY;
1803 /* Always open in binary mode */
1805 if (*mode || oflags == -1)
1807 SETERRNO(EINVAL,LIB$_INVARG);
1814 PerlIOUnix_fileno(PerlIO *f)
1816 return PerlIOSelf(f,PerlIOUnix)->fd;
1820 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1822 IV code = PerlIOBase_pushed(f,mode,arg);
1825 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1826 s->fd = PerlIO_fileno(PerlIONext(f));
1827 s->oflags = PerlIOUnix_oflags(mode);
1829 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1834 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1838 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1839 (*PerlIOBase(f)->tab->Close)(f);
1843 char *path = SvPV_nolen(*args);
1848 imode = PerlIOUnix_oflags(mode);
1853 fd = PerlLIO_open3(path,imode,perm);
1863 f = PerlIO_allocate(aTHX);
1864 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1867 s = PerlIOSelf(f,PerlIOUnix);
1870 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1877 /* FIXME: pop layers ??? */
1884 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1887 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1888 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1892 SSize_t len = PerlLIO_read(fd,vbuf,count);
1893 if (len >= 0 || errno != EINTR)
1896 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1897 else if (len == 0 && count != 0)
1898 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1906 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1909 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1912 SSize_t len = PerlLIO_write(fd,vbuf,count);
1913 if (len >= 0 || errno != EINTR)
1916 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1924 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1927 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1928 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1929 return (new == (Off_t) -1) ? -1 : 0;
1933 PerlIOUnix_tell(PerlIO *f)
1936 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1937 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1941 PerlIOUnix_close(PerlIO *f)
1944 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1946 while (PerlLIO_close(fd) != 0)
1957 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1962 PerlIO_funcs PerlIO_unix = {
1977 PerlIOBase_noop_ok, /* flush */
1978 PerlIOBase_noop_fail, /* fill */
1981 PerlIOBase_clearerr,
1982 PerlIOBase_setlinebuf,
1983 NULL, /* get_base */
1984 NULL, /* get_bufsiz */
1987 NULL, /* set_ptrcnt */
1990 /*--------------------------------------------------------------------------------------*/
1991 /* stdio as a layer */
1995 struct _PerlIO base;
1996 FILE * stdio; /* The stream */
2000 PerlIOStdio_fileno(PerlIO *f)
2003 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2007 PerlIOStdio_mode(const char *mode,char *tmode)
2014 if (O_BINARY != O_TEXT)
2022 /* This isn't used yet ... */
2024 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2029 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2031 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2037 return PerlIOBase_pushed(f,mode,arg);
2040 #undef PerlIO_importFILE
2042 PerlIO_importFILE(FILE *stdio, int fl)
2048 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2055 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2060 char *path = SvPV_nolen(*args);
2061 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2062 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2072 char *path = SvPV_nolen(*args);
2076 fd = PerlLIO_open3(path,imode,perm);
2080 FILE *stdio = PerlSIO_fopen(path,mode);
2083 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2084 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2105 stdio = PerlSIO_stdin;
2108 stdio = PerlSIO_stdout;
2111 stdio = PerlSIO_stderr;
2117 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2121 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2131 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2134 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2138 STDCHAR *buf = (STDCHAR *) vbuf;
2139 /* Perl is expecting PerlIO_getc() to fill the buffer
2140 * Linux's stdio does not do that for fread()
2142 int ch = PerlSIO_fgetc(s);
2150 got = PerlSIO_fread(vbuf,1,count,s);
2155 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2158 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2159 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2163 int ch = *buf-- & 0xff;
2164 if (PerlSIO_ungetc(ch,s) != ch)
2173 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2176 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2180 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2183 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2184 return PerlSIO_fseek(stdio,offset,whence);
2188 PerlIOStdio_tell(PerlIO *f)
2191 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2192 return PerlSIO_ftell(stdio);
2196 PerlIOStdio_close(PerlIO *f)
2199 #ifdef SOCKS5_VERSION_NAME
2201 Sock_size_t optlen = sizeof(int);
2203 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2205 #ifdef SOCKS5_VERSION_NAME
2206 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2207 PerlSIO_fclose(stdio) :
2208 close(PerlIO_fileno(f))
2210 PerlSIO_fclose(stdio)
2217 PerlIOStdio_flush(PerlIO *f)
2220 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2221 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2223 return PerlSIO_fflush(stdio);
2228 /* FIXME: This discards ungetc() and pre-read stuff which is
2229 not right if this is just a "sync" from a layer above
2230 Suspect right design is to do _this_ but not have layer above
2231 flush this layer read-to-read
2233 /* Not writeable - sync by attempting a seek */
2235 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2243 PerlIOStdio_fill(PerlIO *f)
2246 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2248 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2249 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2251 if (PerlSIO_fflush(stdio) != 0)
2254 c = PerlSIO_fgetc(stdio);
2255 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2261 PerlIOStdio_eof(PerlIO *f)
2264 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2268 PerlIOStdio_error(PerlIO *f)
2271 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2275 PerlIOStdio_clearerr(PerlIO *f)
2278 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2282 PerlIOStdio_setlinebuf(PerlIO *f)
2285 #ifdef HAS_SETLINEBUF
2286 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2288 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2294 PerlIOStdio_get_base(PerlIO *f)
2297 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2298 return PerlSIO_get_base(stdio);
2302 PerlIOStdio_get_bufsiz(PerlIO *f)
2305 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2306 return PerlSIO_get_bufsiz(stdio);
2310 #ifdef USE_STDIO_PTR
2312 PerlIOStdio_get_ptr(PerlIO *f)
2315 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2316 return PerlSIO_get_ptr(stdio);
2320 PerlIOStdio_get_cnt(PerlIO *f)
2323 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2324 return PerlSIO_get_cnt(stdio);
2328 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2331 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2334 #ifdef STDIO_PTR_LVALUE
2335 PerlSIO_set_ptr(stdio,ptr);
2336 #ifdef STDIO_PTR_LVAL_SETS_CNT
2337 if (PerlSIO_get_cnt(stdio) != (cnt))
2340 assert(PerlSIO_get_cnt(stdio) == (cnt));
2343 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2344 /* Setting ptr _does_ change cnt - we are done */
2347 #else /* STDIO_PTR_LVALUE */
2349 #endif /* STDIO_PTR_LVALUE */
2351 /* Now (or only) set cnt */
2352 #ifdef STDIO_CNT_LVALUE
2353 PerlSIO_set_cnt(stdio,cnt);
2354 #else /* STDIO_CNT_LVALUE */
2355 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2356 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2357 #else /* STDIO_PTR_LVAL_SETS_CNT */
2359 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2360 #endif /* STDIO_CNT_LVALUE */
2365 PerlIO_funcs PerlIO_stdio = {
2367 sizeof(PerlIOStdio),
2384 PerlIOStdio_clearerr,
2385 PerlIOStdio_setlinebuf,
2387 PerlIOStdio_get_base,
2388 PerlIOStdio_get_bufsiz,
2393 #ifdef USE_STDIO_PTR
2394 PerlIOStdio_get_ptr,
2395 PerlIOStdio_get_cnt,
2396 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2397 PerlIOStdio_set_ptrcnt
2398 #else /* STDIO_PTR_LVALUE */
2400 #endif /* STDIO_PTR_LVALUE */
2401 #else /* USE_STDIO_PTR */
2405 #endif /* USE_STDIO_PTR */
2408 #undef PerlIO_exportFILE
2410 PerlIO_exportFILE(PerlIO *f, int fl)
2414 stdio = fdopen(PerlIO_fileno(f),"r+");
2418 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2424 #undef PerlIO_findFILE
2426 PerlIO_findFILE(PerlIO *f)
2431 if (l->tab == &PerlIO_stdio)
2433 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2436 l = *PerlIONext(&l);
2438 return PerlIO_exportFILE(f,0);
2441 #undef PerlIO_releaseFILE
2443 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2447 /*--------------------------------------------------------------------------------------*/
2448 /* perlio buffer layer */
2451 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2453 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2454 int fd = PerlIO_fileno(f);
2457 if (fd >= 0 && PerlLIO_isatty(fd))
2459 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2461 posn = PerlIO_tell(PerlIONext(f));
2462 if (posn != (Off_t) -1)
2466 return PerlIOBase_pushed(f,mode,arg);
2470 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2474 PerlIO *next = PerlIONext(f);
2475 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2476 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2477 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2484 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2491 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2494 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2495 fd = PerlIO_fileno(f);
2496 #if O_BINARY != O_TEXT
2497 /* do something about failing setmode()? --jhi */
2498 PerlLIO_setmode(fd , O_BINARY);
2500 if (init && fd == 2)
2502 /* Initial stderr is unbuffered */
2503 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2510 /* This "flush" is akin to sfio's sync in that it handles files in either
2514 PerlIOBuf_flush(PerlIO *f)
2516 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2518 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2520 /* write() the buffer */
2521 STDCHAR *buf = b->buf;
2523 PerlIO *n = PerlIONext(f);
2526 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2531 else if (count < 0 || PerlIO_error(n))
2533 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2538 b->posn += (p - buf);
2540 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2542 STDCHAR *buf = PerlIO_get_base(f);
2543 /* Note position change */
2544 b->posn += (b->ptr - buf);
2545 if (b->ptr < b->end)
2547 /* We did not consume all of it */
2548 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2550 b->posn = PerlIO_tell(PerlIONext(f));
2554 b->ptr = b->end = b->buf;
2555 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2556 /* FIXME: Is this right for read case ? */
2557 if (PerlIO_flush(PerlIONext(f)) != 0)
2563 PerlIOBuf_fill(PerlIO *f)
2565 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2566 PerlIO *n = PerlIONext(f);
2568 /* FIXME: doing the down-stream flush is a bad idea if it causes
2569 pre-read data in stdio buffer to be discarded
2570 but this is too simplistic - as it skips _our_ hosekeeping
2571 and breaks tell tests.
2572 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2576 if (PerlIO_flush(f) != 0)
2578 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2579 PerlIOBase_flush_linebuf();
2582 PerlIO_get_base(f); /* allocate via vtable */
2584 b->ptr = b->end = b->buf;
2585 if (PerlIO_fast_gets(n))
2587 /* Layer below is also buffered
2588 * We do _NOT_ want to call its ->Read() because that will loop
2589 * till it gets what we asked for which may hang on a pipe etc.
2590 * Instead take anything it has to hand, or ask it to fill _once_.
2592 avail = PerlIO_get_cnt(n);
2595 avail = PerlIO_fill(n);
2597 avail = PerlIO_get_cnt(n);
2600 if (!PerlIO_error(n) && PerlIO_eof(n))
2606 STDCHAR *ptr = PerlIO_get_ptr(n);
2607 SSize_t cnt = avail;
2608 if (avail > b->bufsiz)
2610 Copy(ptr,b->buf,avail,STDCHAR);
2611 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2616 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2621 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2623 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2626 b->end = b->buf+avail;
2627 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2632 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2634 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2639 return PerlIOBase_read(f,vbuf,count);
2645 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2647 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2648 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2651 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2657 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2659 avail = (b->ptr - b->buf);
2664 b->end = b->buf + avail;
2666 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2667 b->posn -= b->bufsiz;
2669 if (avail > (SSize_t) count)
2677 Copy(buf,b->ptr,avail,STDCHAR);
2681 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2688 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2690 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2691 const STDCHAR *buf = (const STDCHAR *) vbuf;
2695 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2699 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2700 if ((SSize_t) count < avail)
2702 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2703 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2723 Copy(buf,b->ptr,avail,STDCHAR);
2730 if (b->ptr >= (b->buf + b->bufsiz))
2733 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2739 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2742 if ((code = PerlIO_flush(f)) == 0)
2744 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2745 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2746 code = PerlIO_seek(PerlIONext(f),offset,whence);
2749 b->posn = PerlIO_tell(PerlIONext(f));
2756 PerlIOBuf_tell(PerlIO *f)
2758 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2759 Off_t posn = b->posn;
2761 posn += (b->ptr - b->buf);
2766 PerlIOBuf_close(PerlIO *f)
2769 IV code = PerlIOBase_close(f);
2770 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2771 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2773 PerlMemShared_free(b->buf);
2776 b->ptr = b->end = b->buf;
2777 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2782 PerlIOBuf_get_ptr(PerlIO *f)
2784 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2791 PerlIOBuf_get_cnt(PerlIO *f)
2793 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2796 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2797 return (b->end - b->ptr);
2802 PerlIOBuf_get_base(PerlIO *f)
2804 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2810 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2813 b->buf = (STDCHAR *)&b->oneword;
2814 b->bufsiz = sizeof(b->oneword);
2823 PerlIOBuf_bufsiz(PerlIO *f)
2825 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2828 return (b->end - b->buf);
2832 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2834 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2838 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2841 assert(PerlIO_get_cnt(f) == cnt);
2842 assert(b->ptr >= b->buf);
2844 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2847 PerlIO_funcs PerlIO_perlio = {
2866 PerlIOBase_clearerr,
2867 PerlIOBase_setlinebuf,
2872 PerlIOBuf_set_ptrcnt,
2875 /*--------------------------------------------------------------------------------------*/
2876 /* Temp layer to hold unread chars when cannot do it any other way */
2879 PerlIOPending_fill(PerlIO *f)
2881 /* Should never happen */
2887 PerlIOPending_close(PerlIO *f)
2889 /* A tad tricky - flush pops us, then we close new top */
2891 return PerlIO_close(f);
2895 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2897 /* A tad tricky - flush pops us, then we seek new top */
2899 return PerlIO_seek(f,offset,whence);
2904 PerlIOPending_flush(PerlIO *f)
2907 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2908 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2910 PerlMemShared_free(b->buf);
2913 PerlIO_pop(aTHX_ f);
2918 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2926 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2931 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2933 IV code = PerlIOBase_pushed(f,mode,arg);
2934 PerlIOl *l = PerlIOBase(f);
2935 /* Our PerlIO_fast_gets must match what we are pushed on,
2936 or sv_gets() etc. get muddled when it changes mid-string
2939 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2940 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2945 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2947 SSize_t avail = PerlIO_get_cnt(f);
2952 got = PerlIOBuf_read(f,vbuf,avail);
2953 if (got >= 0 && got < count)
2955 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2956 if (more >= 0 || got == 0)
2962 PerlIO_funcs PerlIO_pending = {
2966 PerlIOPending_pushed,
2976 PerlIOPending_close,
2977 PerlIOPending_flush,
2981 PerlIOBase_clearerr,
2982 PerlIOBase_setlinebuf,
2987 PerlIOPending_set_ptrcnt,
2992 /*--------------------------------------------------------------------------------------*/
2993 /* crlf - translation
2994 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2995 to hand back a line at a time and keeping a record of which nl we "lied" about.
2996 On write translate "\n" to CR,LF
3001 PerlIOBuf base; /* PerlIOBuf stuff */
3002 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3006 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3009 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3010 code = PerlIOBuf_pushed(f,mode,arg);
3012 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3013 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3014 PerlIOBase(f)->flags);
3021 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3023 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3029 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3030 return PerlIOBuf_unread(f,vbuf,count);
3033 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3034 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3036 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3042 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3044 b->end = b->ptr = b->buf + b->bufsiz;
3045 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3046 b->posn -= b->bufsiz;
3048 while (count > 0 && b->ptr > b->buf)
3053 if (b->ptr - 2 >= b->buf)
3079 PerlIOCrlf_get_cnt(PerlIO *f)
3081 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3084 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3086 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3087 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3089 STDCHAR *nl = b->ptr;
3091 while (nl < b->end && *nl != 0xd)
3093 if (nl < b->end && *nl == 0xd)
3105 /* Not CR,LF but just CR */
3112 /* Blast - found CR as last char in buffer */
3115 /* They may not care, defer work as long as possible */
3116 return (nl - b->ptr);
3122 b->ptr++; /* say we have read it as far as flush() is concerned */
3123 b->buf++; /* Leave space an front of buffer */
3124 b->bufsiz--; /* Buffer is thus smaller */
3125 code = PerlIO_fill(f); /* Fetch some more */
3126 b->bufsiz++; /* Restore size for next time */
3127 b->buf--; /* Point at space */
3128 b->ptr = nl = b->buf; /* Which is what we hand off */
3129 b->posn--; /* Buffer starts here */
3130 *nl = 0xd; /* Fill in the CR */
3132 goto test; /* fill() call worked */
3133 /* CR at EOF - just fall through */
3138 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3144 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3146 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3147 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3148 IV flags = PerlIOBase(f)->flags;
3158 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3165 /* Test code - delete when it works ... */
3172 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3180 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3181 ptr, chk, flags, c->nl, b->end, cnt);
3188 /* They have taken what we lied about */
3195 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3199 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3201 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3202 return PerlIOBuf_write(f,vbuf,count);
3205 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3206 const STDCHAR *buf = (const STDCHAR *) vbuf;
3207 const STDCHAR *ebuf = buf+count;
3210 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3214 STDCHAR *eptr = b->buf+b->bufsiz;
3215 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3216 while (buf < ebuf && b->ptr < eptr)
3220 if ((b->ptr + 2) > eptr)
3222 /* Not room for both */
3228 *(b->ptr)++ = 0xd; /* CR */
3229 *(b->ptr)++ = 0xa; /* LF */
3231 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3250 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3252 return (buf - (STDCHAR *) vbuf);
3257 PerlIOCrlf_flush(PerlIO *f)
3259 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3265 return PerlIOBuf_flush(f);
3268 PerlIO_funcs PerlIO_crlf = {
3271 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3273 PerlIOBase_noop_ok, /* popped */
3277 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3278 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3279 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3287 PerlIOBase_clearerr,
3288 PerlIOBase_setlinebuf,
3293 PerlIOCrlf_set_ptrcnt,
3297 /*--------------------------------------------------------------------------------------*/
3298 /* mmap as "buffer" layer */
3302 PerlIOBuf base; /* PerlIOBuf stuff */
3303 Mmap_t mptr; /* Mapped address */
3304 Size_t len; /* mapped length */
3305 STDCHAR *bbuf; /* malloced buffer if map fails */
3308 static size_t page_size = 0;
3311 PerlIOMmap_map(PerlIO *f)
3314 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3315 PerlIOBuf *b = &m->base;
3316 IV flags = PerlIOBase(f)->flags;
3320 if (flags & PERLIO_F_CANREAD)
3322 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3323 int fd = PerlIO_fileno(f);
3325 code = fstat(fd,&st);
3326 if (code == 0 && S_ISREG(st.st_mode))
3328 SSize_t len = st.st_size - b->posn;
3333 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3335 SETERRNO(0,SS$_NORMAL);
3336 # ifdef _SC_PAGESIZE
3337 page_size = sysconf(_SC_PAGESIZE);
3339 page_size = sysconf(_SC_PAGE_SIZE);
3341 if ((long)page_size < 0) {
3346 (void)SvUPGRADE(error, SVt_PV);
3347 msg = SvPVx(error, n_a);
3348 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3351 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3355 # ifdef HAS_GETPAGESIZE
3356 page_size = getpagesize();
3358 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3359 page_size = PAGESIZE; /* compiletime, bad */
3363 if ((IV)page_size <= 0)
3364 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3368 /* This is a hack - should never happen - open should have set it ! */
3369 b->posn = PerlIO_tell(PerlIONext(f));
3371 posn = (b->posn / page_size) * page_size;
3372 len = st.st_size - posn;
3373 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3374 if (m->mptr && m->mptr != (Mmap_t) -1)
3376 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3377 madvise(m->mptr, len, MADV_SEQUENTIAL);
3379 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3380 madvise(m->mptr, len, MADV_WILLNEED);
3382 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3383 b->end = ((STDCHAR *)m->mptr) + len;
3384 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3395 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3397 b->ptr = b->end = b->ptr;
3406 PerlIOMmap_unmap(PerlIO *f)
3408 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3409 PerlIOBuf *b = &m->base;
3415 code = munmap(m->mptr, m->len);
3419 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3422 b->ptr = b->end = b->buf;
3423 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3429 PerlIOMmap_get_base(PerlIO *f)
3431 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3432 PerlIOBuf *b = &m->base;
3433 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3435 /* Already have a readbuffer in progress */
3440 /* We have a write buffer or flushed PerlIOBuf read buffer */
3441 m->bbuf = b->buf; /* save it in case we need it again */
3442 b->buf = NULL; /* Clear to trigger below */
3446 PerlIOMmap_map(f); /* Try and map it */
3449 /* Map did not work - recover PerlIOBuf buffer if we have one */
3453 b->ptr = b->end = b->buf;
3456 return PerlIOBuf_get_base(f);
3460 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3462 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3463 PerlIOBuf *b = &m->base;
3464 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3466 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3469 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3474 /* Loose the unwritable mapped buffer */
3476 /* If flush took the "buffer" see if we have one from before */
3477 if (!b->buf && m->bbuf)
3481 PerlIOBuf_get_base(f);
3485 return PerlIOBuf_unread(f,vbuf,count);
3489 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3491 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3492 PerlIOBuf *b = &m->base;
3493 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3495 /* No, or wrong sort of, buffer */
3498 if (PerlIOMmap_unmap(f) != 0)
3501 /* If unmap took the "buffer" see if we have one from before */
3502 if (!b->buf && m->bbuf)
3506 PerlIOBuf_get_base(f);
3510 return PerlIOBuf_write(f,vbuf,count);
3514 PerlIOMmap_flush(PerlIO *f)
3516 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3517 PerlIOBuf *b = &m->base;
3518 IV code = PerlIOBuf_flush(f);
3519 /* Now we are "synced" at PerlIOBuf level */
3524 /* Unmap the buffer */
3525 if (PerlIOMmap_unmap(f) != 0)
3530 /* We seem to have a PerlIOBuf buffer which was not mapped
3531 * remember it in case we need one later
3540 PerlIOMmap_fill(PerlIO *f)
3542 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3543 IV code = PerlIO_flush(f);
3544 if (code == 0 && !b->buf)
3546 code = PerlIOMmap_map(f);
3548 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3550 code = PerlIOBuf_fill(f);
3556 PerlIOMmap_close(PerlIO *f)
3558 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3559 PerlIOBuf *b = &m->base;
3560 IV code = PerlIO_flush(f);
3565 b->ptr = b->end = b->buf;
3567 if (PerlIOBuf_close(f) != 0)
3573 PerlIO_funcs PerlIO_mmap = {
3592 PerlIOBase_clearerr,
3593 PerlIOBase_setlinebuf,
3594 PerlIOMmap_get_base,
3598 PerlIOBuf_set_ptrcnt,
3601 #endif /* HAS_MMAP */
3607 call_atexit(PerlIO_cleanup_layers, NULL);
3611 atexit(&PerlIO_cleanup);
3623 PerlIO_stdstreams(aTHX);
3628 #undef PerlIO_stdout
3635 PerlIO_stdstreams(aTHX);
3640 #undef PerlIO_stderr
3647 PerlIO_stdstreams(aTHX);
3652 /*--------------------------------------------------------------------------------------*/
3654 #undef PerlIO_getname
3656 PerlIO_getname(PerlIO *f, char *buf)
3661 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3662 if (stdio) name = fgetname(stdio, buf);
3664 Perl_croak(aTHX_ "Don't know how to get file name");
3670 /*--------------------------------------------------------------------------------------*/
3671 /* Functions which can be called on any kind of PerlIO implemented
3677 PerlIO_getc(PerlIO *f)
3680 SSize_t count = PerlIO_read(f,buf,1);
3683 return (unsigned char) buf[0];
3688 #undef PerlIO_ungetc
3690 PerlIO_ungetc(PerlIO *f, int ch)
3695 if (PerlIO_unread(f,&buf,1) == 1)
3703 PerlIO_putc(PerlIO *f, int ch)
3706 return PerlIO_write(f,&buf,1);
3711 PerlIO_puts(PerlIO *f, const char *s)
3713 STRLEN len = strlen(s);
3714 return PerlIO_write(f,s,len);
3717 #undef PerlIO_rewind
3719 PerlIO_rewind(PerlIO *f)
3721 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3725 #undef PerlIO_vprintf
3727 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3730 SV *sv = newSVpvn("",0);
3736 Perl_va_copy(ap, apc);
3737 sv_vcatpvf(sv, fmt, &apc);
3739 sv_vcatpvf(sv, fmt, &ap);
3742 wrote = PerlIO_write(f,s,len);
3747 #undef PerlIO_printf
3749 PerlIO_printf(PerlIO *f,const char *fmt,...)
3754 result = PerlIO_vprintf(f,fmt,ap);
3759 #undef PerlIO_stdoutf
3761 PerlIO_stdoutf(const char *fmt,...)
3766 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3771 #undef PerlIO_tmpfile
3773 PerlIO_tmpfile(void)
3775 /* I have no idea how portable mkstemp() is ... */
3776 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3779 FILE *stdio = PerlSIO_tmpfile();
3782 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3788 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3789 int fd = mkstemp(SvPVX(sv));
3793 f = PerlIO_fdopen(fd,"w+");
3796 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3798 PerlLIO_unlink(SvPVX(sv));
3808 #endif /* USE_SFIO */
3809 #endif /* PERLIO_IS_STDIO */
3811 /*======================================================================================*/
3812 /* Now some functions in terms of above which may be needed even if
3813 we are not in true PerlIO mode
3817 #undef PerlIO_setpos
3819 PerlIO_setpos(PerlIO *f, SV *pos)
3825 Off_t *posn = (Off_t *) SvPV(pos,len);
3826 if (f && len == sizeof(Off_t))
3827 return PerlIO_seek(f,*posn,SEEK_SET);
3829 SETERRNO(EINVAL,SS$_IVCHAN);
3833 #undef PerlIO_setpos
3835 PerlIO_setpos(PerlIO *f, SV *pos)
3841 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3842 if (f && len == sizeof(Fpos_t))
3844 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3845 return fsetpos64(f, fpos);
3847 return fsetpos(f, fpos);
3851 SETERRNO(EINVAL,SS$_IVCHAN);
3857 #undef PerlIO_getpos
3859 PerlIO_getpos(PerlIO *f, SV *pos)
3862 Off_t posn = PerlIO_tell(f);
3863 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3864 return (posn == (Off_t)-1) ? -1 : 0;
3867 #undef PerlIO_getpos
3869 PerlIO_getpos(PerlIO *f, SV *pos)
3874 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3875 code = fgetpos64(f, &fpos);
3877 code = fgetpos(f, &fpos);
3879 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3884 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3887 vprintf(char *pat, char *args)
3889 _doprnt(pat, args, stdout);
3890 return 0; /* wrong, but perl doesn't use the return value */
3894 vfprintf(FILE *fd, char *pat, char *args)
3896 _doprnt(pat, args, fd);
3897 return 0; /* wrong, but perl doesn't use the return value */
3902 #ifndef PerlIO_vsprintf
3904 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3906 int val = vsprintf(s, fmt, ap);
3909 if (strlen(s) >= (STRLEN)n)
3912 (void)PerlIO_puts(Perl_error_log,
3913 "panic: sprintf overflow - memory corrupted!\n");
3921 #ifndef PerlIO_sprintf
3923 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3928 result = PerlIO_vsprintf(s, n, fmt, ap);