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.
10 /* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
11 a dTHX to get at the dispatch tables, even when we do not
12 need it for other reasons.
13 Invent a dSYS macro to abstract this out
15 #ifdef PERL_IMPLICIT_SYS
28 #define PERLIO_NOT_STDIO 0
29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
30 /* #define PerlIO FILE */
33 * This file provides those parts of PerlIO abstraction
34 * which are not #defined in perlio.h.
35 * Which these are depends on various Configure #ifdef's
39 #define PERL_IN_PERLIO_C
42 #undef PerlMemShared_calloc
43 #define PerlMemShared_calloc(x,y) calloc(x,y)
44 #undef PerlMemShared_free
45 #define PerlMemShared_free(x) free(x)
48 perlsio_binmode(FILE *fp, int iotype, int mode)
50 /* This used to be contents of do_binmode in doio.c */
52 # if defined(atarist) || defined(__MINT__)
55 ((FILE*)fp)->_flag |= _IOBIN;
57 ((FILE*)fp)->_flag &= ~ _IOBIN;
63 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
64 # if defined(WIN32) && defined(__BORLANDC__)
65 /* The translation mode of the stream is maintained independent
66 * of the translation mode of the fd in the Borland RTL (heavy
67 * digging through their runtime sources reveal). User has to
68 * set the mode explicitly for the stream (though they don't
69 * document this anywhere). GSAR 97-5-24
75 fp->flags &= ~ _F_BIN;
83 # if defined(USEMYBINMODE)
84 if (my_binmode(fp, iotype, mode) != FALSE)
96 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
98 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
102 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
108 PerlIO_destruct(pTHX)
113 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
118 return perlsio_binmode(fp,iotype,mode);
122 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
125 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
129 if (*args == &PL_sv_undef)
130 return PerlIO_tmpfile();
133 char *name = SvPV_nolen(*args);
136 fd = PerlLIO_open3(name,imode,perm);
138 return PerlIO_fdopen(fd,(char *)mode+1);
142 return PerlIO_reopen(name,mode,old);
146 return PerlIO_open(name,mode);
152 return PerlIO_fdopen(fd,(char *)mode);
160 #ifdef PERLIO_IS_STDIO
165 /* Does nothing (yet) except force this file to be included
166 in perl binary. That allows this file to force inclusion
167 of other functions that may be required by loadable
168 extensions e.g. for FileHandle::tmpfile
172 #undef PerlIO_tmpfile
179 #else /* PERLIO_IS_STDIO */
186 /* This section is just to make sure these functions
187 get pulled in from libsfio.a
190 #undef PerlIO_tmpfile
200 /* Force this file to be included in perl binary. Which allows
201 * this file to force inclusion of other functions that may be
202 * required by loadable extensions e.g. for FileHandle::tmpfile
206 * sfio does its own 'autoflush' on stdout in common cases.
207 * Flush results in a lot of lseek()s to regular files and
208 * lot of small writes to pipes.
210 sfset(sfstdout,SF_SHARE,0);
214 PerlIO_importFILE(FILE *stdio, int fl)
216 int fd = fileno(stdio);
217 PerlIO *r = PerlIO_fdopen(fd,"r+");
222 PerlIO_findFILE(PerlIO *pio)
224 int fd = PerlIO_fileno(pio);
225 FILE *f = fdopen(fd,"r+");
227 if (!f && errno == EINVAL)
229 if (!f && errno == EINVAL)
236 /*======================================================================================*/
237 /* Implement all the PerlIO interface ourselves.
242 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
247 #include <sys/mman.h>
252 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
255 PerlIO_debug(const char *fmt,...)
263 char *s = PerlEnv_getenv("PERLIO_DEBUG");
265 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
272 SV *sv = newSVpvn("",0);
275 s = CopFILE(PL_curcop);
278 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
279 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
282 PerlLIO_write(dbg,s,len);
288 /*--------------------------------------------------------------------------------------*/
290 /* Inner level routines */
292 /* Table of pointers to the PerlIO structs (malloc'ed) */
293 PerlIO *_perlio = NULL;
294 #define PERLIO_TABLE_SIZE 64
299 PerlIO_allocate(pTHX)
301 /* Find a free slot in the table, allocating new table as necessary */
308 last = (PerlIO **)(f);
309 for (i=1; i < PERLIO_TABLE_SIZE; i++)
317 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
327 PerlIO_cleantable(pTHX_ PerlIO **tablep)
329 PerlIO *table = *tablep;
333 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
334 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
342 PerlMemShared_free(table);
351 PerlIO_cleanup_layers(pTHXo_ void *data)
353 PerlIO_layer_hv = Nullhv;
354 PerlIO_layer_av = Nullav;
361 PerlIO_cleantable(aTHX_ &_perlio);
365 PerlIO_destruct(pTHX)
367 PerlIO **table = &_perlio;
372 table = (PerlIO **)(f++);
373 for (i=1; i < PERLIO_TABLE_SIZE; i++)
379 if (l->tab->kind & PERLIO_K_DESTRUCT)
381 PerlIO_debug("Destruct popping %s\n",l->tab->name);
396 PerlIO_pop(pTHX_ PerlIO *f)
401 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
403 (*l->tab->Popped)(f);
405 PerlMemShared_free(l);
409 /*--------------------------------------------------------------------------------------*/
410 /* XS Interface for perl code */
413 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
417 if ((SSize_t) len <= 0)
419 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
420 if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
422 SV *pkgsv = newSVpvn("PerlIO",6);
423 SV *layer = newSVpvn(name,len);
425 /* The two SVs are magically freed by load_module */
426 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
428 /* Say this is lvalue so we get an 'undef' if still not there */
429 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
431 if (svp && (sv = *svp))
439 #ifdef USE_ATTRIBUTES_FOR_PERLIO
442 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
446 IO *io = GvIOn((GV *)SvRV(sv));
447 PerlIO *ifp = IoIFP(io);
448 PerlIO *ofp = IoOFP(io);
449 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
455 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
459 IO *io = GvIOn((GV *)SvRV(sv));
460 PerlIO *ifp = IoIFP(io);
461 PerlIO *ofp = IoOFP(io);
462 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
468 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
470 Perl_warn(aTHX_ "clear %"SVf,sv);
475 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
477 Perl_warn(aTHX_ "free %"SVf,sv);
481 MGVTBL perlio_vtab = {
489 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
492 SV *sv = SvRV(ST(1));
497 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
499 mg = mg_find(sv, PERL_MAGIC_ext);
500 mg->mg_virtual = &perlio_vtab;
502 Perl_warn(aTHX_ "attrib %"SVf,sv);
503 for (i=2; i < items; i++)
506 const char *name = SvPV(ST(i),len);
507 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
510 av_push(av,SvREFCNT_inc(layer));
522 #endif /* USE_ATTIBUTES_FOR_PERLIO */
525 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
527 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
528 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
533 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
535 if (!PerlIO_layer_hv)
537 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
539 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
540 PerlIO_debug("define %s %p\n",tab->name,tab);
544 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
548 const char *s = names;
551 while (isSPACE(*s) || *s == ':')
557 const char *as = Nullch;
561 /* Message is consistent with how attribute lists are passed.
562 Even though this means "foo : : bar" is seen as an invalid separator
564 char q = ((*s == '\'') ? '"' : '\'');
565 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
571 } while (isALNUM(*e));
589 /* It's a nul terminated string, not allowed to \ the terminating null.
590 Anything other character is passed over. */
598 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
608 SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
611 av_push(av,SvREFCNT_inc(layer));
612 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
615 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
627 PerlIO_default_buffer(pTHX_ AV *av)
629 PerlIO_funcs *tab = &PerlIO_perlio;
630 if (O_BINARY != O_TEXT)
636 if (PerlIO_stdio.Set_ptrcnt)
641 PerlIO_debug("Pushing %s\n",tab->name);
642 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
643 av_push(av,&PL_sv_undef);
647 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
649 SV **svp = av_fetch(av,n,FALSE);
650 return (svp) ? *svp : Nullsv;
654 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
656 SV **svp = av_fetch(av,n,FALSE);
658 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
660 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
661 return INT2PTR(PerlIO_funcs *, SvIV(layer));
664 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
669 PerlIO_default_layers(pTHX)
672 if (!PerlIO_layer_av)
674 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
675 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
677 #ifdef USE_ATTRIBUTES_FOR_PERLIO
678 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
681 PerlIO_define_layer(aTHX_ &PerlIO_raw);
682 PerlIO_define_layer(aTHX_ &PerlIO_unix);
683 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
684 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
685 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
687 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
689 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
690 PerlIO_define_layer(aTHX_ &PerlIO_byte);
691 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
692 av_push(PerlIO_layer_av,&PL_sv_undef);
695 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
699 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
702 len = av_len(PerlIO_layer_av)+1;
705 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
706 len = av_len(PerlIO_layer_av);
708 return PerlIO_layer_av;
713 PerlIO_default_layer(pTHX_ I32 n)
715 AV *av = PerlIO_default_layers(aTHX);
718 n += av_len(PerlIO_layer_av)+1;
719 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
722 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
723 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
726 PerlIO_stdstreams(pTHX)
730 PerlIO_allocate(aTHX);
731 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
732 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
733 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
738 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
741 l = PerlMemShared_calloc(tab->size,sizeof(char));
744 Zero(l,tab->size,char);
748 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
749 (mode) ? mode : "(Null)",arg);
750 if ((*l->tab->Pushed)(f,mode,arg) != 0)
760 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
774 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
776 /* Remove the dummy layer */
779 /* Pop back to bottom layer */
783 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
791 /* Nothing bellow - push unix on top then remove it */
792 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
794 PerlIO_pop(aTHX_ PerlIONext(f));
799 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
806 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
808 IV max = av_len(layers)+1;
812 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
815 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
827 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
832 AV *layers = newAV();
833 code = PerlIO_parse_layers(aTHX_ layers,names);
836 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
838 SvREFCNT_dec((SV *) layers);
844 /*--------------------------------------------------------------------------------------*/
845 /* Given the abstraction above the public API functions */
848 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
850 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
851 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
852 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
858 if (PerlIOBase(top)->tab == &PerlIO_crlf)
861 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
864 top = PerlIONext(top);
867 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
872 PerlIO__close(PerlIO *f)
875 return (*PerlIOBase(f)->tab->Close)(f);
878 SETERRNO(EBADF,SS$_IVCHAN);
883 #undef PerlIO_fdupopen
885 PerlIO_fdupopen(pTHX_ PerlIO *f)
890 int fd = PerlLIO_dup(PerlIO_fileno(f));
891 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
894 Off_t posn = PerlIO_tell(f);
895 PerlIO_seek(new,posn,SEEK_SET);
901 SETERRNO(EBADF,SS$_IVCHAN);
908 PerlIO_close(PerlIO *f)
914 code = (*PerlIOBase(f)->tab->Close)(f);
925 PerlIO_fileno(PerlIO *f)
928 return (*PerlIOBase(f)->tab->Fileno)(f);
931 SETERRNO(EBADF,SS$_IVCHAN);
937 PerlIO_context_layers(pTHX_ const char *mode)
939 const char *type = NULL;
940 /* Need to supply default layer info from open.pm */
943 SV *layers = PL_curcop->cop_io;
947 type = SvPV(layers,len);
948 if (type && mode[0] != 'r')
950 /* Skip to write part */
951 const char *s = strchr(type,0);
952 if (s && (s-type) < len)
963 PerlIO_layer_from_ref(pTHX_ SV *sv)
965 /* For any scalar type load the handler which is bundled with perl */
966 if (SvTYPE(sv) < SVt_PVAV)
967 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
969 /* For other types allow if layer is known but don't try and load it */
973 return PerlIO_find_layer(aTHX_ "Array",5, 0);
975 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
977 return PerlIO_find_layer(aTHX_ "Code",4, 0);
979 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
985 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
987 AV *def = PerlIO_default_layers(aTHX);
990 PerlIO_stdstreams(aTHX);
994 /* If it is a reference but not an object see if we have a handler for it */
995 if (SvROK(arg) && !sv_isobject(arg))
997 SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1001 av_push(def,SvREFCNT_inc(handler));
1002 av_push(def,&PL_sv_undef);
1005 /* Don't fail if handler cannot be found
1006 * :Via(...) etc. may do something sensible
1007 * else we will just stringfy and open resulting string.
1012 layers = PerlIO_context_layers(aTHX_ mode);
1013 if (layers && *layers)
1018 IV n = av_len(def)+1;
1022 SV **svp = av_fetch(def,n,0);
1023 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
1030 PerlIO_parse_layers(aTHX_ av,layers);
1042 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1044 if (!f && narg == 1 && *args == &PL_sv_undef)
1046 if ((f = PerlIO_tmpfile()))
1049 layers = PerlIO_context_layers(aTHX_ mode);
1050 if (layers && *layers)
1051 PerlIO_apply_layers(aTHX_ f,mode,layers);
1058 PerlIO_funcs *tab = NULL;
1061 /* This is "reopen" - it is not tested as perl does not use it yet */
1066 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1067 av_unshift(layera,2);
1068 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1069 av_store(layera,1,arg);
1070 l = *PerlIONext(&l);
1075 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1077 n = av_len(layera)-1;
1080 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1090 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1091 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1092 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1095 if (n+2 < av_len(layera)+1)
1097 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1104 SvREFCNT_dec(layera);
1110 #undef PerlIO_fdopen
1112 PerlIO_fdopen(int fd, const char *mode)
1115 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1120 PerlIO_open(const char *path, const char *mode)
1123 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1124 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1127 #undef PerlIO_reopen
1129 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1132 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1133 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1138 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1141 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1144 SETERRNO(EBADF,SS$_IVCHAN);
1149 #undef PerlIO_unread
1151 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1154 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1157 SETERRNO(EBADF,SS$_IVCHAN);
1164 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1167 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1170 SETERRNO(EBADF,SS$_IVCHAN);
1177 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1180 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1183 SETERRNO(EBADF,SS$_IVCHAN);
1190 PerlIO_tell(PerlIO *f)
1193 return (*PerlIOBase(f)->tab->Tell)(f);
1196 SETERRNO(EBADF,SS$_IVCHAN);
1203 PerlIO_flush(PerlIO *f)
1209 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1210 if (tab && tab->Flush)
1212 return (*tab->Flush)(f);
1216 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1217 SETERRNO(EBADF,SS$_IVCHAN);
1223 PerlIO_debug("Cannot flush f=%p\n",f);
1224 SETERRNO(EBADF,SS$_IVCHAN);
1230 /* Is it good API design to do flush-all on NULL,
1231 * a potentially errorneous input? Maybe some magical
1232 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1233 * Yes, stdio does similar things on fflush(NULL),
1234 * but should we be bound by their design decisions?
1236 PerlIO **table = &_perlio;
1238 while ((f = *table))
1241 table = (PerlIO **)(f++);
1242 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1244 if (*f && PerlIO_flush(f) != 0)
1254 PerlIOBase_flush_linebuf()
1256 PerlIO **table = &_perlio;
1258 while ((f = *table))
1261 table = (PerlIO **)(f++);
1262 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1264 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1265 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1274 PerlIO_fill(PerlIO *f)
1277 return (*PerlIOBase(f)->tab->Fill)(f);
1280 SETERRNO(EBADF,SS$_IVCHAN);
1285 #undef PerlIO_isutf8
1287 PerlIO_isutf8(PerlIO *f)
1290 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1293 SETERRNO(EBADF,SS$_IVCHAN);
1300 PerlIO_eof(PerlIO *f)
1303 return (*PerlIOBase(f)->tab->Eof)(f);
1306 SETERRNO(EBADF,SS$_IVCHAN);
1313 PerlIO_error(PerlIO *f)
1316 return (*PerlIOBase(f)->tab->Error)(f);
1319 SETERRNO(EBADF,SS$_IVCHAN);
1324 #undef PerlIO_clearerr
1326 PerlIO_clearerr(PerlIO *f)
1329 (*PerlIOBase(f)->tab->Clearerr)(f);
1331 SETERRNO(EBADF,SS$_IVCHAN);
1334 #undef PerlIO_setlinebuf
1336 PerlIO_setlinebuf(PerlIO *f)
1339 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1341 SETERRNO(EBADF,SS$_IVCHAN);
1344 #undef PerlIO_has_base
1346 PerlIO_has_base(PerlIO *f)
1348 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1352 #undef PerlIO_fast_gets
1354 PerlIO_fast_gets(PerlIO *f)
1356 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1358 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1359 return (tab->Set_ptrcnt != NULL);
1364 #undef PerlIO_has_cntptr
1366 PerlIO_has_cntptr(PerlIO *f)
1370 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1371 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1376 #undef PerlIO_canset_cnt
1378 PerlIO_canset_cnt(PerlIO *f)
1382 PerlIOl *l = PerlIOBase(f);
1383 return (l->tab->Set_ptrcnt != NULL);
1388 #undef PerlIO_get_base
1390 PerlIO_get_base(PerlIO *f)
1393 return (*PerlIOBase(f)->tab->Get_base)(f);
1397 #undef PerlIO_get_bufsiz
1399 PerlIO_get_bufsiz(PerlIO *f)
1402 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1406 #undef PerlIO_get_ptr
1408 PerlIO_get_ptr(PerlIO *f)
1410 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1411 if (tab->Get_ptr == NULL)
1413 return (*tab->Get_ptr)(f);
1416 #undef PerlIO_get_cnt
1418 PerlIO_get_cnt(PerlIO *f)
1420 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1421 if (tab->Get_cnt == NULL)
1423 return (*tab->Get_cnt)(f);
1426 #undef PerlIO_set_cnt
1428 PerlIO_set_cnt(PerlIO *f,int cnt)
1430 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1433 #undef PerlIO_set_ptrcnt
1435 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1437 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1438 if (tab->Set_ptrcnt == NULL)
1441 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1443 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1446 /*--------------------------------------------------------------------------------------*/
1447 /* utf8 and raw dummy layers */
1450 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1455 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1456 PerlIO_pop(aTHX_ f);
1457 if (tab->kind & PERLIO_K_UTF8)
1458 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1460 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1466 PerlIO_funcs PerlIO_utf8 = {
1469 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1487 NULL, /* get_base */
1488 NULL, /* get_bufsiz */
1491 NULL, /* set_ptrcnt */
1494 PerlIO_funcs PerlIO_byte = {
1515 NULL, /* get_base */
1516 NULL, /* get_bufsiz */
1519 NULL, /* set_ptrcnt */
1523 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)
1525 PerlIO_funcs *tab = PerlIO_default_btm();
1526 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1529 PerlIO_funcs PerlIO_raw = {
1550 NULL, /* get_base */
1551 NULL, /* get_bufsiz */
1554 NULL, /* set_ptrcnt */
1556 /*--------------------------------------------------------------------------------------*/
1557 /*--------------------------------------------------------------------------------------*/
1558 /* "Methods" of the "base class" */
1561 PerlIOBase_fileno(PerlIO *f)
1563 return PerlIO_fileno(PerlIONext(f));
1567 PerlIO_modestr(PerlIO *f,char *buf)
1570 IV flags = PerlIOBase(f)->flags;
1571 if (flags & PERLIO_F_APPEND)
1574 if (flags & PERLIO_F_CANREAD)
1579 else if (flags & PERLIO_F_CANREAD)
1582 if (flags & PERLIO_F_CANWRITE)
1585 else if (flags & PERLIO_F_CANWRITE)
1588 if (flags & PERLIO_F_CANREAD)
1593 #if O_TEXT != O_BINARY
1594 if (!(flags & PERLIO_F_CRLF))
1602 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1604 PerlIOl *l = PerlIOBase(f);
1606 const char *omode = mode;
1609 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1610 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1611 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1612 if (tab->Set_ptrcnt != NULL)
1613 l->flags |= PERLIO_F_FASTGETS;
1616 if (*mode == '#' || *mode == 'I')
1621 l->flags |= PERLIO_F_CANREAD;
1624 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1627 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1630 SETERRNO(EINVAL,LIB$_INVARG);
1638 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1641 l->flags &= ~PERLIO_F_CRLF;
1644 l->flags |= PERLIO_F_CRLF;
1647 SETERRNO(EINVAL,LIB$_INVARG);
1656 l->flags |= l->next->flags &
1657 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1661 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1662 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1663 l->flags,PerlIO_modestr(f,temp));
1669 PerlIOBase_popped(PerlIO *f)
1675 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1678 Off_t old = PerlIO_tell(f);
1680 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1681 done = PerlIOBuf_unread(f,vbuf,count);
1682 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1687 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1689 STDCHAR *buf = (STDCHAR *) vbuf;
1692 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1696 SSize_t avail = PerlIO_get_cnt(f);
1699 take = (count < avail) ? count : avail;
1702 STDCHAR *ptr = PerlIO_get_ptr(f);
1703 Copy(ptr,buf,take,STDCHAR);
1704 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1708 if (count > 0 && avail <= 0)
1710 if (PerlIO_fill(f) != 0)
1714 return (buf - (STDCHAR *) vbuf);
1720 PerlIOBase_noop_ok(PerlIO *f)
1726 PerlIOBase_noop_fail(PerlIO *f)
1732 PerlIOBase_close(PerlIO *f)
1735 PerlIO *n = PerlIONext(f);
1736 if (PerlIO_flush(f) != 0)
1738 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1740 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1745 PerlIOBase_eof(PerlIO *f)
1749 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1755 PerlIOBase_error(PerlIO *f)
1759 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1765 PerlIOBase_clearerr(PerlIO *f)
1769 PerlIO *n = PerlIONext(f);
1770 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1777 PerlIOBase_setlinebuf(PerlIO *f)
1781 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1785 /*--------------------------------------------------------------------------------------*/
1786 /* Bottom-most level for UNIX-like case */
1790 struct _PerlIO base; /* The generic part */
1791 int fd; /* UNIX like file descriptor */
1792 int oflags; /* open/fcntl flags */
1796 PerlIOUnix_oflags(const char *mode)
1811 oflags = O_CREAT|O_TRUNC;
1822 oflags = O_CREAT|O_APPEND;
1838 else if (*mode == 't')
1841 oflags &= ~O_BINARY;
1844 /* Always open in binary mode */
1846 if (*mode || oflags == -1)
1848 SETERRNO(EINVAL,LIB$_INVARG);
1855 PerlIOUnix_fileno(PerlIO *f)
1857 return PerlIOSelf(f,PerlIOUnix)->fd;
1861 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1863 IV code = PerlIOBase_pushed(f,mode,arg);
1866 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1867 s->fd = PerlIO_fileno(PerlIONext(f));
1868 s->oflags = PerlIOUnix_oflags(mode);
1870 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1875 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)
1879 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1880 (*PerlIOBase(f)->tab->Close)(f);
1884 char *path = SvPV_nolen(*args);
1889 imode = PerlIOUnix_oflags(mode);
1894 fd = PerlLIO_open3(path,imode,perm);
1904 f = PerlIO_allocate(aTHX);
1905 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1908 s = PerlIOSelf(f,PerlIOUnix);
1911 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1918 /* FIXME: pop layers ??? */
1925 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1928 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1929 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1933 SSize_t len = PerlLIO_read(fd,vbuf,count);
1934 if (len >= 0 || errno != EINTR)
1937 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1938 else if (len == 0 && count != 0)
1939 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1947 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1950 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1953 SSize_t len = PerlLIO_write(fd,vbuf,count);
1954 if (len >= 0 || errno != EINTR)
1957 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1965 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1968 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1969 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1970 return (new == (Off_t) -1) ? -1 : 0;
1974 PerlIOUnix_tell(PerlIO *f)
1977 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1981 PerlIOUnix_close(PerlIO *f)
1984 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1986 while (PerlLIO_close(fd) != 0)
1997 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2002 PerlIO_funcs PerlIO_unix = {
2017 PerlIOBase_noop_ok, /* flush */
2018 PerlIOBase_noop_fail, /* fill */
2021 PerlIOBase_clearerr,
2022 PerlIOBase_setlinebuf,
2023 NULL, /* get_base */
2024 NULL, /* get_bufsiz */
2027 NULL, /* set_ptrcnt */
2030 /*--------------------------------------------------------------------------------------*/
2031 /* stdio as a layer */
2035 struct _PerlIO base;
2036 FILE * stdio; /* The stream */
2040 PerlIOStdio_fileno(PerlIO *f)
2043 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2047 PerlIOStdio_mode(const char *mode,char *tmode)
2054 if (O_BINARY != O_TEXT)
2062 /* This isn't used yet ... */
2064 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2069 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2071 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2077 return PerlIOBase_pushed(f,mode,arg);
2080 #undef PerlIO_importFILE
2082 PerlIO_importFILE(FILE *stdio, int fl)
2088 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2095 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)
2100 char *path = SvPV_nolen(*args);
2101 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2102 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2112 char *path = SvPV_nolen(*args);
2116 fd = PerlLIO_open3(path,imode,perm);
2120 FILE *stdio = PerlSIO_fopen(path,mode);
2123 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2124 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2145 stdio = PerlSIO_stdin;
2148 stdio = PerlSIO_stdout;
2151 stdio = PerlSIO_stderr;
2157 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2161 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2171 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2174 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2178 STDCHAR *buf = (STDCHAR *) vbuf;
2179 /* Perl is expecting PerlIO_getc() to fill the buffer
2180 * Linux's stdio does not do that for fread()
2182 int ch = PerlSIO_fgetc(s);
2190 got = PerlSIO_fread(vbuf,1,count,s);
2195 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2198 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2199 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2203 int ch = *buf-- & 0xff;
2204 if (PerlSIO_ungetc(ch,s) != ch)
2213 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2216 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2220 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2223 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2224 return PerlSIO_fseek(stdio,offset,whence);
2228 PerlIOStdio_tell(PerlIO *f)
2231 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2232 return PerlSIO_ftell(stdio);
2236 PerlIOStdio_close(PerlIO *f)
2239 #ifdef SOCKS5_VERSION_NAME
2241 Sock_size_t optlen = sizeof(int);
2243 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2245 #ifdef SOCKS5_VERSION_NAME
2246 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2247 PerlSIO_fclose(stdio) :
2248 close(PerlIO_fileno(f))
2250 PerlSIO_fclose(stdio)
2257 PerlIOStdio_flush(PerlIO *f)
2260 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2261 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2263 return PerlSIO_fflush(stdio);
2268 /* FIXME: This discards ungetc() and pre-read stuff which is
2269 not right if this is just a "sync" from a layer above
2270 Suspect right design is to do _this_ but not have layer above
2271 flush this layer read-to-read
2273 /* Not writeable - sync by attempting a seek */
2275 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2283 PerlIOStdio_fill(PerlIO *f)
2286 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2288 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2289 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2291 if (PerlSIO_fflush(stdio) != 0)
2294 c = PerlSIO_fgetc(stdio);
2295 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2301 PerlIOStdio_eof(PerlIO *f)
2304 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2308 PerlIOStdio_error(PerlIO *f)
2311 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2315 PerlIOStdio_clearerr(PerlIO *f)
2318 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2322 PerlIOStdio_setlinebuf(PerlIO *f)
2325 #ifdef HAS_SETLINEBUF
2326 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2328 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2334 PerlIOStdio_get_base(PerlIO *f)
2337 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2338 return PerlSIO_get_base(stdio);
2342 PerlIOStdio_get_bufsiz(PerlIO *f)
2345 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2346 return PerlSIO_get_bufsiz(stdio);
2350 #ifdef USE_STDIO_PTR
2352 PerlIOStdio_get_ptr(PerlIO *f)
2355 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2356 return PerlSIO_get_ptr(stdio);
2360 PerlIOStdio_get_cnt(PerlIO *f)
2363 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2364 return PerlSIO_get_cnt(stdio);
2368 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2370 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2374 #ifdef STDIO_PTR_LVALUE
2375 PerlSIO_set_ptr(stdio,ptr);
2376 #ifdef STDIO_PTR_LVAL_SETS_CNT
2377 if (PerlSIO_get_cnt(stdio) != (cnt))
2380 assert(PerlSIO_get_cnt(stdio) == (cnt));
2383 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2384 /* Setting ptr _does_ change cnt - we are done */
2387 #else /* STDIO_PTR_LVALUE */
2389 #endif /* STDIO_PTR_LVALUE */
2391 /* Now (or only) set cnt */
2392 #ifdef STDIO_CNT_LVALUE
2393 PerlSIO_set_cnt(stdio,cnt);
2394 #else /* STDIO_CNT_LVALUE */
2395 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2396 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2397 #else /* STDIO_PTR_LVAL_SETS_CNT */
2399 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2400 #endif /* STDIO_CNT_LVALUE */
2405 PerlIO_funcs PerlIO_stdio = {
2407 sizeof(PerlIOStdio),
2424 PerlIOStdio_clearerr,
2425 PerlIOStdio_setlinebuf,
2427 PerlIOStdio_get_base,
2428 PerlIOStdio_get_bufsiz,
2433 #ifdef USE_STDIO_PTR
2434 PerlIOStdio_get_ptr,
2435 PerlIOStdio_get_cnt,
2436 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2437 PerlIOStdio_set_ptrcnt
2438 #else /* STDIO_PTR_LVALUE */
2440 #endif /* STDIO_PTR_LVALUE */
2441 #else /* USE_STDIO_PTR */
2445 #endif /* USE_STDIO_PTR */
2448 #undef PerlIO_exportFILE
2450 PerlIO_exportFILE(PerlIO *f, int fl)
2454 stdio = fdopen(PerlIO_fileno(f),"r+");
2458 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2464 #undef PerlIO_findFILE
2466 PerlIO_findFILE(PerlIO *f)
2471 if (l->tab == &PerlIO_stdio)
2473 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2476 l = *PerlIONext(&l);
2478 return PerlIO_exportFILE(f,0);
2481 #undef PerlIO_releaseFILE
2483 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2487 /*--------------------------------------------------------------------------------------*/
2488 /* perlio buffer layer */
2491 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2494 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2495 int fd = PerlIO_fileno(f);
2497 if (fd >= 0 && PerlLIO_isatty(fd))
2499 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2501 posn = PerlIO_tell(PerlIONext(f));
2502 if (posn != (Off_t) -1)
2506 return PerlIOBase_pushed(f,mode,arg);
2510 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)
2514 PerlIO *next = PerlIONext(f);
2515 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2516 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2517 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2524 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2531 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2534 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2535 fd = PerlIO_fileno(f);
2536 #if O_BINARY != O_TEXT
2537 /* do something about failing setmode()? --jhi */
2538 PerlLIO_setmode(fd , O_BINARY);
2540 if (init && fd == 2)
2542 /* Initial stderr is unbuffered */
2543 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2550 /* This "flush" is akin to sfio's sync in that it handles files in either
2554 PerlIOBuf_flush(PerlIO *f)
2556 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2558 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2560 /* write() the buffer */
2561 STDCHAR *buf = b->buf;
2563 PerlIO *n = PerlIONext(f);
2566 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2571 else if (count < 0 || PerlIO_error(n))
2573 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2578 b->posn += (p - buf);
2580 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2582 STDCHAR *buf = PerlIO_get_base(f);
2583 /* Note position change */
2584 b->posn += (b->ptr - buf);
2585 if (b->ptr < b->end)
2587 /* We did not consume all of it */
2588 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2590 b->posn = PerlIO_tell(PerlIONext(f));
2594 b->ptr = b->end = b->buf;
2595 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2596 /* FIXME: Is this right for read case ? */
2597 if (PerlIO_flush(PerlIONext(f)) != 0)
2603 PerlIOBuf_fill(PerlIO *f)
2605 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2606 PerlIO *n = PerlIONext(f);
2608 /* FIXME: doing the down-stream flush is a bad idea if it causes
2609 pre-read data in stdio buffer to be discarded
2610 but this is too simplistic - as it skips _our_ hosekeeping
2611 and breaks tell tests.
2612 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2616 if (PerlIO_flush(f) != 0)
2618 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2619 PerlIOBase_flush_linebuf();
2622 PerlIO_get_base(f); /* allocate via vtable */
2624 b->ptr = b->end = b->buf;
2625 if (PerlIO_fast_gets(n))
2627 /* Layer below is also buffered
2628 * We do _NOT_ want to call its ->Read() because that will loop
2629 * till it gets what we asked for which may hang on a pipe etc.
2630 * Instead take anything it has to hand, or ask it to fill _once_.
2632 avail = PerlIO_get_cnt(n);
2635 avail = PerlIO_fill(n);
2637 avail = PerlIO_get_cnt(n);
2640 if (!PerlIO_error(n) && PerlIO_eof(n))
2646 STDCHAR *ptr = PerlIO_get_ptr(n);
2647 SSize_t cnt = avail;
2648 if (avail > b->bufsiz)
2650 Copy(ptr,b->buf,avail,STDCHAR);
2651 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2656 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2661 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2663 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2666 b->end = b->buf+avail;
2667 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2672 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2674 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2679 return PerlIOBase_read(f,vbuf,count);
2685 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2687 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2688 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2691 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2697 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2699 avail = (b->ptr - b->buf);
2704 b->end = b->buf + avail;
2706 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2707 b->posn -= b->bufsiz;
2709 if (avail > (SSize_t) count)
2717 Copy(buf,b->ptr,avail,STDCHAR);
2721 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2728 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2730 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2731 const STDCHAR *buf = (const STDCHAR *) vbuf;
2735 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2739 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2740 if ((SSize_t) count < avail)
2742 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2743 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2763 Copy(buf,b->ptr,avail,STDCHAR);
2770 if (b->ptr >= (b->buf + b->bufsiz))
2773 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2779 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2782 if ((code = PerlIO_flush(f)) == 0)
2784 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2785 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2786 code = PerlIO_seek(PerlIONext(f),offset,whence);
2789 b->posn = PerlIO_tell(PerlIONext(f));
2796 PerlIOBuf_tell(PerlIO *f)
2798 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2799 Off_t posn = b->posn;
2801 posn += (b->ptr - b->buf);
2806 PerlIOBuf_close(PerlIO *f)
2808 IV code = PerlIOBase_close(f);
2809 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2810 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2812 PerlMemShared_free(b->buf);
2815 b->ptr = b->end = b->buf;
2816 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2821 PerlIOBuf_get_ptr(PerlIO *f)
2823 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2830 PerlIOBuf_get_cnt(PerlIO *f)
2832 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2835 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2836 return (b->end - b->ptr);
2841 PerlIOBuf_get_base(PerlIO *f)
2843 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2848 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2851 b->buf = (STDCHAR *)&b->oneword;
2852 b->bufsiz = sizeof(b->oneword);
2861 PerlIOBuf_bufsiz(PerlIO *f)
2863 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2866 return (b->end - b->buf);
2870 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2872 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2876 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2879 assert(PerlIO_get_cnt(f) == cnt);
2880 assert(b->ptr >= b->buf);
2882 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2885 PerlIO_funcs PerlIO_perlio = {
2904 PerlIOBase_clearerr,
2905 PerlIOBase_setlinebuf,
2910 PerlIOBuf_set_ptrcnt,
2913 /*--------------------------------------------------------------------------------------*/
2914 /* Temp layer to hold unread chars when cannot do it any other way */
2917 PerlIOPending_fill(PerlIO *f)
2919 /* Should never happen */
2925 PerlIOPending_close(PerlIO *f)
2927 /* A tad tricky - flush pops us, then we close new top */
2929 return PerlIO_close(f);
2933 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2935 /* A tad tricky - flush pops us, then we seek new top */
2937 return PerlIO_seek(f,offset,whence);
2942 PerlIOPending_flush(PerlIO *f)
2945 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2946 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2948 PerlMemShared_free(b->buf);
2951 PerlIO_pop(aTHX_ f);
2956 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2964 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2969 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2971 IV code = PerlIOBase_pushed(f,mode,arg);
2972 PerlIOl *l = PerlIOBase(f);
2973 /* Our PerlIO_fast_gets must match what we are pushed on,
2974 or sv_gets() etc. get muddled when it changes mid-string
2977 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2978 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2983 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2985 SSize_t avail = PerlIO_get_cnt(f);
2990 got = PerlIOBuf_read(f,vbuf,avail);
2991 if (got >= 0 && got < count)
2993 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2994 if (more >= 0 || got == 0)
3000 PerlIO_funcs PerlIO_pending = {
3004 PerlIOPending_pushed,
3014 PerlIOPending_close,
3015 PerlIOPending_flush,
3019 PerlIOBase_clearerr,
3020 PerlIOBase_setlinebuf,
3025 PerlIOPending_set_ptrcnt,
3030 /*--------------------------------------------------------------------------------------*/
3031 /* crlf - translation
3032 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3033 to hand back a line at a time and keeping a record of which nl we "lied" about.
3034 On write translate "\n" to CR,LF
3039 PerlIOBuf base; /* PerlIOBuf stuff */
3040 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3044 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3047 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3048 code = PerlIOBuf_pushed(f,mode,arg);
3050 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3051 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3052 PerlIOBase(f)->flags);
3059 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3061 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3067 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3068 return PerlIOBuf_unread(f,vbuf,count);
3071 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3072 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3074 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3080 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3082 b->end = b->ptr = b->buf + b->bufsiz;
3083 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3084 b->posn -= b->bufsiz;
3086 while (count > 0 && b->ptr > b->buf)
3091 if (b->ptr - 2 >= b->buf)
3117 PerlIOCrlf_get_cnt(PerlIO *f)
3119 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3122 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3124 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3125 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3127 STDCHAR *nl = b->ptr;
3129 while (nl < b->end && *nl != 0xd)
3131 if (nl < b->end && *nl == 0xd)
3143 /* Not CR,LF but just CR */
3150 /* Blast - found CR as last char in buffer */
3153 /* They may not care, defer work as long as possible */
3154 return (nl - b->ptr);
3159 b->ptr++; /* say we have read it as far as flush() is concerned */
3160 b->buf++; /* Leave space an front of buffer */
3161 b->bufsiz--; /* Buffer is thus smaller */
3162 code = PerlIO_fill(f); /* Fetch some more */
3163 b->bufsiz++; /* Restore size for next time */
3164 b->buf--; /* Point at space */
3165 b->ptr = nl = b->buf; /* Which is what we hand off */
3166 b->posn--; /* Buffer starts here */
3167 *nl = 0xd; /* Fill in the CR */
3169 goto test; /* fill() call worked */
3170 /* CR at EOF - just fall through */
3175 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3181 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3183 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3184 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3185 IV flags = PerlIOBase(f)->flags;
3195 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3202 /* Test code - delete when it works ... */
3209 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3217 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3218 ptr, chk, flags, c->nl, b->end, cnt);
3225 /* They have taken what we lied about */
3232 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3236 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3238 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3239 return PerlIOBuf_write(f,vbuf,count);
3242 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3243 const STDCHAR *buf = (const STDCHAR *) vbuf;
3244 const STDCHAR *ebuf = buf+count;
3247 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3251 STDCHAR *eptr = b->buf+b->bufsiz;
3252 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3253 while (buf < ebuf && b->ptr < eptr)
3257 if ((b->ptr + 2) > eptr)
3259 /* Not room for both */
3265 *(b->ptr)++ = 0xd; /* CR */
3266 *(b->ptr)++ = 0xa; /* LF */
3268 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3287 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3289 return (buf - (STDCHAR *) vbuf);
3294 PerlIOCrlf_flush(PerlIO *f)
3296 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3302 return PerlIOBuf_flush(f);
3305 PerlIO_funcs PerlIO_crlf = {
3308 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3310 PerlIOBase_noop_ok, /* popped */
3314 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3315 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3316 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3324 PerlIOBase_clearerr,
3325 PerlIOBase_setlinebuf,
3330 PerlIOCrlf_set_ptrcnt,
3334 /*--------------------------------------------------------------------------------------*/
3335 /* mmap as "buffer" layer */
3339 PerlIOBuf base; /* PerlIOBuf stuff */
3340 Mmap_t mptr; /* Mapped address */
3341 Size_t len; /* mapped length */
3342 STDCHAR *bbuf; /* malloced buffer if map fails */
3345 static size_t page_size = 0;
3348 PerlIOMmap_map(PerlIO *f)
3351 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3352 IV flags = PerlIOBase(f)->flags;
3356 if (flags & PERLIO_F_CANREAD)
3358 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3359 int fd = PerlIO_fileno(f);
3361 code = fstat(fd,&st);
3362 if (code == 0 && S_ISREG(st.st_mode))
3364 SSize_t len = st.st_size - b->posn;
3369 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3371 SETERRNO(0,SS$_NORMAL);
3372 # ifdef _SC_PAGESIZE
3373 page_size = sysconf(_SC_PAGESIZE);
3375 page_size = sysconf(_SC_PAGE_SIZE);
3377 if ((long)page_size < 0) {
3382 (void)SvUPGRADE(error, SVt_PV);
3383 msg = SvPVx(error, n_a);
3384 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3387 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3391 # ifdef HAS_GETPAGESIZE
3392 page_size = getpagesize();
3394 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3395 page_size = PAGESIZE; /* compiletime, bad */
3399 if ((IV)page_size <= 0)
3400 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3404 /* This is a hack - should never happen - open should have set it ! */
3405 b->posn = PerlIO_tell(PerlIONext(f));
3407 posn = (b->posn / page_size) * page_size;
3408 len = st.st_size - posn;
3409 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3410 if (m->mptr && m->mptr != (Mmap_t) -1)
3412 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3413 madvise(m->mptr, len, MADV_SEQUENTIAL);
3415 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3416 madvise(m->mptr, len, MADV_WILLNEED);
3418 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3419 b->end = ((STDCHAR *)m->mptr) + len;
3420 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3431 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3433 b->ptr = b->end = b->ptr;
3442 PerlIOMmap_unmap(PerlIO *f)
3444 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3445 PerlIOBuf *b = &m->base;
3451 code = munmap(m->mptr, m->len);
3455 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3458 b->ptr = b->end = b->buf;
3459 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3465 PerlIOMmap_get_base(PerlIO *f)
3467 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3468 PerlIOBuf *b = &m->base;
3469 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3471 /* Already have a readbuffer in progress */
3476 /* We have a write buffer or flushed PerlIOBuf read buffer */
3477 m->bbuf = b->buf; /* save it in case we need it again */
3478 b->buf = NULL; /* Clear to trigger below */
3482 PerlIOMmap_map(f); /* Try and map it */
3485 /* Map did not work - recover PerlIOBuf buffer if we have one */
3489 b->ptr = b->end = b->buf;
3492 return PerlIOBuf_get_base(f);
3496 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3498 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3499 PerlIOBuf *b = &m->base;
3500 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3502 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3505 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3510 /* Loose the unwritable mapped buffer */
3512 /* If flush took the "buffer" see if we have one from before */
3513 if (!b->buf && m->bbuf)
3517 PerlIOBuf_get_base(f);
3521 return PerlIOBuf_unread(f,vbuf,count);
3525 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3527 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3528 PerlIOBuf *b = &m->base;
3529 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3531 /* No, or wrong sort of, buffer */
3534 if (PerlIOMmap_unmap(f) != 0)
3537 /* If unmap took the "buffer" see if we have one from before */
3538 if (!b->buf && m->bbuf)
3542 PerlIOBuf_get_base(f);
3546 return PerlIOBuf_write(f,vbuf,count);
3550 PerlIOMmap_flush(PerlIO *f)
3552 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3553 PerlIOBuf *b = &m->base;
3554 IV code = PerlIOBuf_flush(f);
3555 /* Now we are "synced" at PerlIOBuf level */
3560 /* Unmap the buffer */
3561 if (PerlIOMmap_unmap(f) != 0)
3566 /* We seem to have a PerlIOBuf buffer which was not mapped
3567 * remember it in case we need one later
3576 PerlIOMmap_fill(PerlIO *f)
3578 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3579 IV code = PerlIO_flush(f);
3580 if (code == 0 && !b->buf)
3582 code = PerlIOMmap_map(f);
3584 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3586 code = PerlIOBuf_fill(f);
3592 PerlIOMmap_close(PerlIO *f)
3594 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3595 PerlIOBuf *b = &m->base;
3596 IV code = PerlIO_flush(f);
3601 b->ptr = b->end = b->buf;
3603 if (PerlIOBuf_close(f) != 0)
3609 PerlIO_funcs PerlIO_mmap = {
3628 PerlIOBase_clearerr,
3629 PerlIOBase_setlinebuf,
3630 PerlIOMmap_get_base,
3634 PerlIOBuf_set_ptrcnt,
3637 #endif /* HAS_MMAP */
3644 call_atexit(PerlIO_cleanup_layers, NULL);
3649 atexit(&PerlIO_cleanup);
3661 PerlIO_stdstreams(aTHX);
3666 #undef PerlIO_stdout
3673 PerlIO_stdstreams(aTHX);
3678 #undef PerlIO_stderr
3685 PerlIO_stdstreams(aTHX);
3690 /*--------------------------------------------------------------------------------------*/
3692 #undef PerlIO_getname
3694 PerlIO_getname(PerlIO *f, char *buf)
3699 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3700 if (stdio) name = fgetname(stdio, buf);
3702 Perl_croak(aTHX_ "Don't know how to get file name");
3708 /*--------------------------------------------------------------------------------------*/
3709 /* Functions which can be called on any kind of PerlIO implemented
3715 PerlIO_getc(PerlIO *f)
3718 SSize_t count = PerlIO_read(f,buf,1);
3721 return (unsigned char) buf[0];
3726 #undef PerlIO_ungetc
3728 PerlIO_ungetc(PerlIO *f, int ch)
3733 if (PerlIO_unread(f,&buf,1) == 1)
3741 PerlIO_putc(PerlIO *f, int ch)
3744 return PerlIO_write(f,&buf,1);
3749 PerlIO_puts(PerlIO *f, const char *s)
3751 STRLEN len = strlen(s);
3752 return PerlIO_write(f,s,len);
3755 #undef PerlIO_rewind
3757 PerlIO_rewind(PerlIO *f)
3759 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3763 #undef PerlIO_vprintf
3765 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3768 SV *sv = newSVpvn("",0);
3774 Perl_va_copy(ap, apc);
3775 sv_vcatpvf(sv, fmt, &apc);
3777 sv_vcatpvf(sv, fmt, &ap);
3780 wrote = PerlIO_write(f,s,len);
3785 #undef PerlIO_printf
3787 PerlIO_printf(PerlIO *f,const char *fmt,...)
3792 result = PerlIO_vprintf(f,fmt,ap);
3797 #undef PerlIO_stdoutf
3799 PerlIO_stdoutf(const char *fmt,...)
3804 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3809 #undef PerlIO_tmpfile
3811 PerlIO_tmpfile(void)
3813 /* I have no idea how portable mkstemp() is ... */
3814 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3817 FILE *stdio = PerlSIO_tmpfile();
3820 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3826 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3827 int fd = mkstemp(SvPVX(sv));
3831 f = PerlIO_fdopen(fd,"w+");
3834 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3836 PerlLIO_unlink(SvPVX(sv));
3846 #endif /* USE_SFIO */
3847 #endif /* PERLIO_IS_STDIO */
3849 /*======================================================================================*/
3850 /* Now some functions in terms of above which may be needed even if
3851 we are not in true PerlIO mode
3855 #undef PerlIO_setpos
3857 PerlIO_setpos(PerlIO *f, SV *pos)
3863 Off_t *posn = (Off_t *) SvPV(pos,len);
3864 if (f && len == sizeof(Off_t))
3865 return PerlIO_seek(f,*posn,SEEK_SET);
3867 SETERRNO(EINVAL,SS$_IVCHAN);
3871 #undef PerlIO_setpos
3873 PerlIO_setpos(PerlIO *f, SV *pos)
3879 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3880 if (f && len == sizeof(Fpos_t))
3882 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3883 return fsetpos64(f, fpos);
3885 return fsetpos(f, fpos);
3889 SETERRNO(EINVAL,SS$_IVCHAN);
3895 #undef PerlIO_getpos
3897 PerlIO_getpos(PerlIO *f, SV *pos)
3900 Off_t posn = PerlIO_tell(f);
3901 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3902 return (posn == (Off_t)-1) ? -1 : 0;
3905 #undef PerlIO_getpos
3907 PerlIO_getpos(PerlIO *f, SV *pos)
3912 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3913 code = fgetpos64(f, &fpos);
3915 code = fgetpos(f, &fpos);
3917 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3922 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3925 vprintf(char *pat, char *args)
3927 _doprnt(pat, args, stdout);
3928 return 0; /* wrong, but perl doesn't use the return value */
3932 vfprintf(FILE *fd, char *pat, char *args)
3934 _doprnt(pat, args, fd);
3935 return 0; /* wrong, but perl doesn't use the return value */
3940 #ifndef PerlIO_vsprintf
3942 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3944 int val = vsprintf(s, fmt, ap);
3947 if (strlen(s) >= (STRLEN)n)
3950 (void)PerlIO_puts(Perl_error_log,
3951 "panic: sprintf overflow - memory corrupted!\n");
3959 #ifndef PerlIO_sprintf
3961 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3966 result = PerlIO_vsprintf(s, n, fmt, ap);