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);
347 PerlIO_list_t *PerlIO_known_layers;
348 PerlIO_list_t *PerlIO_def_layerlist;
351 PerlIO_list_alloc(void)
354 Newz('L',list,1,PerlIO_list_t);
360 PerlIO_list_free(PerlIO_list_t *list)
364 if (--list->refcnt == 0)
370 for (i=0; i < list->cur; i++)
372 if (list->array[i].arg)
373 SvREFCNT_dec(list->array[i].arg);
375 Safefree(list->array);
383 PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
386 if (list->cur >= list->len)
390 Renew(list->array,list->len,PerlIO_pair_t);
392 New('l',list->array,list->len,PerlIO_pair_t);
394 p = &(list->array[list->cur++]);
402 PerlIO_cleanup_layers(pTHXo_ void *data)
405 PerlIO_known_layers = Nullhv;
406 PerlIO_def_layerlist = Nullav;
414 PerlIO_cleantable(aTHX_ &_perlio);
418 PerlIO_destruct(pTHX)
420 PerlIO **table = &_perlio;
425 table = (PerlIO **)(f++);
426 for (i=1; i < PERLIO_TABLE_SIZE; i++)
432 if (l->tab->kind & PERLIO_K_DESTRUCT)
434 PerlIO_debug("Destruct popping %s\n",l->tab->name);
449 PerlIO_pop(pTHX_ PerlIO *f)
454 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
456 (*l->tab->Popped)(f);
458 PerlMemShared_free(l);
462 /*--------------------------------------------------------------------------------------*/
463 /* XS Interface for perl code */
466 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
469 if ((SSize_t) len <= 0)
471 for (i=0; i < PerlIO_known_layers->cur; i++)
473 PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
474 if (strEQ(f->name,name))
476 PerlIO_debug("%.*s => %p\n",(int)len,name,f);
480 if (load && PL_subname && PerlIO_def_layerlist && PerlIO_def_layerlist->cur >= 2)
482 SV *pkgsv = newSVpvn("PerlIO",6);
483 SV *layer = newSVpvn(name,len);
485 /* The two SVs are magically freed by load_module */
486 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
488 return PerlIO_find_layer(aTHX_ name,len,0);
490 PerlIO_debug("Cannot find %.*s\n",(int)len,name);
494 #ifdef USE_ATTRIBUTES_FOR_PERLIO
497 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
501 IO *io = GvIOn((GV *)SvRV(sv));
502 PerlIO *ifp = IoIFP(io);
503 PerlIO *ofp = IoOFP(io);
504 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
510 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
514 IO *io = GvIOn((GV *)SvRV(sv));
515 PerlIO *ifp = IoIFP(io);
516 PerlIO *ofp = IoOFP(io);
517 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
523 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
525 Perl_warn(aTHX_ "clear %"SVf,sv);
530 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
532 Perl_warn(aTHX_ "free %"SVf,sv);
536 MGVTBL perlio_vtab = {
544 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
547 SV *sv = SvRV(ST(1));
552 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
554 mg = mg_find(sv, PERL_MAGIC_ext);
555 mg->mg_virtual = &perlio_vtab;
557 Perl_warn(aTHX_ "attrib %"SVf,sv);
558 for (i=2; i < items; i++)
561 const char *name = SvPV(ST(i),len);
562 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
565 av_push(av,SvREFCNT_inc(layer));
577 #endif /* USE_ATTIBUTES_FOR_PERLIO */
580 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
582 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
583 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
588 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
590 if (!PerlIO_known_layers)
591 PerlIO_known_layers = PerlIO_list_alloc();
592 PerlIO_list_push(PerlIO_known_layers,tab,Nullsv);
593 PerlIO_debug("define %s %p\n",tab->name,tab);
597 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
601 const char *s = names;
604 while (isSPACE(*s) || *s == ':')
610 const char *as = Nullch;
614 /* Message is consistent with how attribute lists are passed.
615 Even though this means "foo : : bar" is seen as an invalid separator
617 char q = ((*s == '\'') ? '"' : '\'');
618 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
624 } while (isALNUM(*e));
642 /* It's a nul terminated string, not allowed to \ the terminating null.
643 Anything other character is passed over. */
651 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
661 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s,llen,1);
664 PerlIO_list_push(av, layer, (as) ? newSVpvn(as,alen) : &PL_sv_undef);
667 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
679 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
681 PerlIO_funcs *tab = &PerlIO_perlio;
682 if (O_BINARY != O_TEXT)
688 if (PerlIO_stdio.Set_ptrcnt)
693 PerlIO_debug("Pushing %s\n",tab->name);
694 PerlIO_list_push(av,PerlIO_find_layer(aTHX_ tab->name,0,0),&PL_sv_undef);
698 PerlIO_arg_fetch(PerlIO_list_t *av,IV n)
700 return av->array[n].arg;
704 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
706 if (n >= 0 && n < av->cur)
708 PerlIO_debug("Layer %ld is %s\n",n,av->array[n].funcs->name);
709 return av->array[n].funcs;
712 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
717 PerlIO_default_layers(pTHX)
719 if (!PerlIO_def_layerlist)
721 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
722 PerlIO_def_layerlist = PerlIO_list_alloc();
724 #ifdef USE_ATTRIBUTES_FOR_PERLIO
725 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
728 PerlIO_define_layer(aTHX_ &PerlIO_raw);
729 PerlIO_define_layer(aTHX_ &PerlIO_unix);
730 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
731 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
732 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
734 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
736 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
737 PerlIO_define_layer(aTHX_ &PerlIO_byte);
738 PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0),&PL_sv_undef);
741 PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
745 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
748 if (PerlIO_def_layerlist->cur < 2)
750 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
752 return PerlIO_def_layerlist;
757 PerlIO_default_layer(pTHX_ I32 n)
759 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
762 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
765 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
766 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
769 PerlIO_stdstreams(pTHX)
773 PerlIO_allocate(aTHX);
774 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
775 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
776 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
781 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
784 l = PerlMemShared_calloc(tab->size,sizeof(char));
787 Zero(l,tab->size,char);
791 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
792 (mode) ? mode : "(Null)",arg);
793 if ((*l->tab->Pushed)(f,mode,arg) != 0)
803 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
817 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
819 /* Remove the dummy layer */
822 /* Pop back to bottom layer */
826 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
834 /* Nothing bellow - push unix on top then remove it */
835 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
837 PerlIO_pop(aTHX_ PerlIONext(f));
842 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
849 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
851 IV max = layers->cur;
855 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
858 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
870 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
875 PerlIO_list_t *layers = PerlIO_list_alloc();
876 code = PerlIO_parse_layers(aTHX_ layers,names);
879 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
881 PerlIO_list_free(layers);
887 /*--------------------------------------------------------------------------------------*/
888 /* Given the abstraction above the public API functions */
891 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
893 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
894 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
895 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
901 if (PerlIOBase(top)->tab == &PerlIO_crlf)
904 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
907 top = PerlIONext(top);
910 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
915 PerlIO__close(PerlIO *f)
918 return (*PerlIOBase(f)->tab->Close)(f);
921 SETERRNO(EBADF,SS$_IVCHAN);
926 #undef PerlIO_fdupopen
928 PerlIO_fdupopen(pTHX_ PerlIO *f)
933 int fd = PerlLIO_dup(PerlIO_fileno(f));
934 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
937 Off_t posn = PerlIO_tell(f);
938 PerlIO_seek(new,posn,SEEK_SET);
944 SETERRNO(EBADF,SS$_IVCHAN);
951 PerlIO_close(PerlIO *f)
957 code = (*PerlIOBase(f)->tab->Close)(f);
968 PerlIO_fileno(PerlIO *f)
971 return (*PerlIOBase(f)->tab->Fileno)(f);
974 SETERRNO(EBADF,SS$_IVCHAN);
980 PerlIO_context_layers(pTHX_ const char *mode)
982 const char *type = NULL;
983 /* Need to supply default layer info from open.pm */
986 SV *layers = PL_curcop->cop_io;
990 type = SvPV(layers,len);
991 if (type && mode[0] != 'r')
993 /* Skip to write part */
994 const char *s = strchr(type,0);
995 if (s && (s-type) < len)
1005 static PerlIO_funcs *
1006 PerlIO_layer_from_ref(pTHX_ SV *sv)
1008 /* For any scalar type load the handler which is bundled with perl */
1009 if (SvTYPE(sv) < SVt_PVAV)
1010 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1012 /* For other types allow if layer is known but don't try and load it */
1016 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1018 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1020 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1022 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1028 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1030 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1033 PerlIO_stdstreams(aTHX);
1037 /* If it is a reference but not an object see if we have a handler for it */
1038 if (SvROK(arg) && !sv_isobject(arg))
1040 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1043 def = PerlIO_list_alloc();
1044 PerlIO_list_push(def,handler,&PL_sv_undef);
1047 /* Don't fail if handler cannot be found
1048 * :Via(...) etc. may do something sensible
1049 * else we will just stringfy and open resulting string.
1054 layers = PerlIO_context_layers(aTHX_ mode);
1055 if (layers && *layers)
1061 av = PerlIO_list_alloc();
1062 for (i=0; i < def->cur; i++)
1064 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1071 PerlIO_parse_layers(aTHX_ av,layers);
1083 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1085 if (!f && narg == 1 && *args == &PL_sv_undef)
1087 if ((f = PerlIO_tmpfile()))
1090 layers = PerlIO_context_layers(aTHX_ mode);
1091 if (layers && *layers)
1092 PerlIO_apply_layers(aTHX_ f,mode,layers);
1097 PerlIO_list_t *layera = NULL;
1099 PerlIO_funcs *tab = NULL;
1102 /* This is "reopen" - it is not tested as perl does not use it yet */
1104 layera = PerlIO_list_alloc();
1107 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1108 PerlIO_list_push(layera,l->tab,arg);
1109 l = *PerlIONext(&l);
1114 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1116 /* Start at "top" of layer stack */
1120 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1130 /* Found that layer 'n' can do opens - call it */
1131 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1132 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1133 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1136 if (n+1 < layera->cur)
1138 /* More layers above the one that we used to open - apply them now */
1139 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1146 PerlIO_list_free(layera);
1152 #undef PerlIO_fdopen
1154 PerlIO_fdopen(int fd, const char *mode)
1157 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1162 PerlIO_open(const char *path, const char *mode)
1165 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1166 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1169 #undef PerlIO_reopen
1171 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1174 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1175 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1180 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1183 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1186 SETERRNO(EBADF,SS$_IVCHAN);
1191 #undef PerlIO_unread
1193 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1196 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1199 SETERRNO(EBADF,SS$_IVCHAN);
1206 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1209 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1212 SETERRNO(EBADF,SS$_IVCHAN);
1219 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1222 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1225 SETERRNO(EBADF,SS$_IVCHAN);
1232 PerlIO_tell(PerlIO *f)
1235 return (*PerlIOBase(f)->tab->Tell)(f);
1238 SETERRNO(EBADF,SS$_IVCHAN);
1245 PerlIO_flush(PerlIO *f)
1251 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1252 if (tab && tab->Flush)
1254 return (*tab->Flush)(f);
1258 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1259 SETERRNO(EBADF,SS$_IVCHAN);
1265 PerlIO_debug("Cannot flush f=%p\n",f);
1266 SETERRNO(EBADF,SS$_IVCHAN);
1272 /* Is it good API design to do flush-all on NULL,
1273 * a potentially errorneous input? Maybe some magical
1274 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1275 * Yes, stdio does similar things on fflush(NULL),
1276 * but should we be bound by their design decisions?
1278 PerlIO **table = &_perlio;
1280 while ((f = *table))
1283 table = (PerlIO **)(f++);
1284 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1286 if (*f && PerlIO_flush(f) != 0)
1296 PerlIOBase_flush_linebuf()
1298 PerlIO **table = &_perlio;
1300 while ((f = *table))
1303 table = (PerlIO **)(f++);
1304 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1306 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1307 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1316 PerlIO_fill(PerlIO *f)
1319 return (*PerlIOBase(f)->tab->Fill)(f);
1322 SETERRNO(EBADF,SS$_IVCHAN);
1327 #undef PerlIO_isutf8
1329 PerlIO_isutf8(PerlIO *f)
1332 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1335 SETERRNO(EBADF,SS$_IVCHAN);
1342 PerlIO_eof(PerlIO *f)
1345 return (*PerlIOBase(f)->tab->Eof)(f);
1348 SETERRNO(EBADF,SS$_IVCHAN);
1355 PerlIO_error(PerlIO *f)
1358 return (*PerlIOBase(f)->tab->Error)(f);
1361 SETERRNO(EBADF,SS$_IVCHAN);
1366 #undef PerlIO_clearerr
1368 PerlIO_clearerr(PerlIO *f)
1371 (*PerlIOBase(f)->tab->Clearerr)(f);
1373 SETERRNO(EBADF,SS$_IVCHAN);
1376 #undef PerlIO_setlinebuf
1378 PerlIO_setlinebuf(PerlIO *f)
1381 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1383 SETERRNO(EBADF,SS$_IVCHAN);
1386 #undef PerlIO_has_base
1388 PerlIO_has_base(PerlIO *f)
1390 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1394 #undef PerlIO_fast_gets
1396 PerlIO_fast_gets(PerlIO *f)
1398 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1400 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1401 return (tab->Set_ptrcnt != NULL);
1406 #undef PerlIO_has_cntptr
1408 PerlIO_has_cntptr(PerlIO *f)
1412 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1413 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1418 #undef PerlIO_canset_cnt
1420 PerlIO_canset_cnt(PerlIO *f)
1424 PerlIOl *l = PerlIOBase(f);
1425 return (l->tab->Set_ptrcnt != NULL);
1430 #undef PerlIO_get_base
1432 PerlIO_get_base(PerlIO *f)
1435 return (*PerlIOBase(f)->tab->Get_base)(f);
1439 #undef PerlIO_get_bufsiz
1441 PerlIO_get_bufsiz(PerlIO *f)
1444 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1448 #undef PerlIO_get_ptr
1450 PerlIO_get_ptr(PerlIO *f)
1452 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1453 if (tab->Get_ptr == NULL)
1455 return (*tab->Get_ptr)(f);
1458 #undef PerlIO_get_cnt
1460 PerlIO_get_cnt(PerlIO *f)
1462 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1463 if (tab->Get_cnt == NULL)
1465 return (*tab->Get_cnt)(f);
1468 #undef PerlIO_set_cnt
1470 PerlIO_set_cnt(PerlIO *f,int cnt)
1472 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1475 #undef PerlIO_set_ptrcnt
1477 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1479 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1480 if (tab->Set_ptrcnt == NULL)
1483 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1485 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1488 /*--------------------------------------------------------------------------------------*/
1489 /* utf8 and raw dummy layers */
1492 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1497 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1498 PerlIO_pop(aTHX_ f);
1499 if (tab->kind & PERLIO_K_UTF8)
1500 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1502 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1508 PerlIO_funcs PerlIO_utf8 = {
1511 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1529 NULL, /* get_base */
1530 NULL, /* get_bufsiz */
1533 NULL, /* set_ptrcnt */
1536 PerlIO_funcs PerlIO_byte = {
1557 NULL, /* get_base */
1558 NULL, /* get_bufsiz */
1561 NULL, /* set_ptrcnt */
1565 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1567 PerlIO_funcs *tab = PerlIO_default_btm();
1568 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1571 PerlIO_funcs PerlIO_raw = {
1592 NULL, /* get_base */
1593 NULL, /* get_bufsiz */
1596 NULL, /* set_ptrcnt */
1598 /*--------------------------------------------------------------------------------------*/
1599 /*--------------------------------------------------------------------------------------*/
1600 /* "Methods" of the "base class" */
1603 PerlIOBase_fileno(PerlIO *f)
1605 return PerlIO_fileno(PerlIONext(f));
1609 PerlIO_modestr(PerlIO *f,char *buf)
1612 IV flags = PerlIOBase(f)->flags;
1613 if (flags & PERLIO_F_APPEND)
1616 if (flags & PERLIO_F_CANREAD)
1621 else if (flags & PERLIO_F_CANREAD)
1624 if (flags & PERLIO_F_CANWRITE)
1627 else if (flags & PERLIO_F_CANWRITE)
1630 if (flags & PERLIO_F_CANREAD)
1635 #if O_TEXT != O_BINARY
1636 if (!(flags & PERLIO_F_CRLF))
1644 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1646 PerlIOl *l = PerlIOBase(f);
1648 const char *omode = mode;
1651 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1652 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1653 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1654 if (tab->Set_ptrcnt != NULL)
1655 l->flags |= PERLIO_F_FASTGETS;
1658 if (*mode == '#' || *mode == 'I')
1663 l->flags |= PERLIO_F_CANREAD;
1666 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1669 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1672 SETERRNO(EINVAL,LIB$_INVARG);
1680 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1683 l->flags &= ~PERLIO_F_CRLF;
1686 l->flags |= PERLIO_F_CRLF;
1689 SETERRNO(EINVAL,LIB$_INVARG);
1698 l->flags |= l->next->flags &
1699 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1703 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1704 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1705 l->flags,PerlIO_modestr(f,temp));
1711 PerlIOBase_popped(PerlIO *f)
1717 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1720 Off_t old = PerlIO_tell(f);
1722 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1723 done = PerlIOBuf_unread(f,vbuf,count);
1724 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1729 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1731 STDCHAR *buf = (STDCHAR *) vbuf;
1734 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1738 SSize_t avail = PerlIO_get_cnt(f);
1741 take = (count < avail) ? count : avail;
1744 STDCHAR *ptr = PerlIO_get_ptr(f);
1745 Copy(ptr,buf,take,STDCHAR);
1746 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1750 if (count > 0 && avail <= 0)
1752 if (PerlIO_fill(f) != 0)
1756 return (buf - (STDCHAR *) vbuf);
1762 PerlIOBase_noop_ok(PerlIO *f)
1768 PerlIOBase_noop_fail(PerlIO *f)
1774 PerlIOBase_close(PerlIO *f)
1777 PerlIO *n = PerlIONext(f);
1778 if (PerlIO_flush(f) != 0)
1780 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1782 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1787 PerlIOBase_eof(PerlIO *f)
1791 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1797 PerlIOBase_error(PerlIO *f)
1801 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1807 PerlIOBase_clearerr(PerlIO *f)
1811 PerlIO *n = PerlIONext(f);
1812 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1819 PerlIOBase_setlinebuf(PerlIO *f)
1823 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1827 /*--------------------------------------------------------------------------------------*/
1828 /* Bottom-most level for UNIX-like case */
1832 struct _PerlIO base; /* The generic part */
1833 int fd; /* UNIX like file descriptor */
1834 int oflags; /* open/fcntl flags */
1838 PerlIOUnix_oflags(const char *mode)
1853 oflags = O_CREAT|O_TRUNC;
1864 oflags = O_CREAT|O_APPEND;
1880 else if (*mode == 't')
1883 oflags &= ~O_BINARY;
1886 /* Always open in binary mode */
1888 if (*mode || oflags == -1)
1890 SETERRNO(EINVAL,LIB$_INVARG);
1897 PerlIOUnix_fileno(PerlIO *f)
1899 return PerlIOSelf(f,PerlIOUnix)->fd;
1903 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1905 IV code = PerlIOBase_pushed(f,mode,arg);
1908 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1909 s->fd = PerlIO_fileno(PerlIONext(f));
1910 s->oflags = PerlIOUnix_oflags(mode);
1912 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1917 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1921 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1922 (*PerlIOBase(f)->tab->Close)(f);
1926 char *path = SvPV_nolen(*args);
1931 imode = PerlIOUnix_oflags(mode);
1936 fd = PerlLIO_open3(path,imode,perm);
1946 f = PerlIO_allocate(aTHX);
1947 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1950 s = PerlIOSelf(f,PerlIOUnix);
1953 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1960 /* FIXME: pop layers ??? */
1967 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1970 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1971 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1975 SSize_t len = PerlLIO_read(fd,vbuf,count);
1976 if (len >= 0 || errno != EINTR)
1979 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1980 else if (len == 0 && count != 0)
1981 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1989 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1992 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1995 SSize_t len = PerlLIO_write(fd,vbuf,count);
1996 if (len >= 0 || errno != EINTR)
1999 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2007 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2010 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2011 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2012 return (new == (Off_t) -1) ? -1 : 0;
2016 PerlIOUnix_tell(PerlIO *f)
2019 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2023 PerlIOUnix_close(PerlIO *f)
2026 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2028 while (PerlLIO_close(fd) != 0)
2039 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2044 PerlIO_funcs PerlIO_unix = {
2059 PerlIOBase_noop_ok, /* flush */
2060 PerlIOBase_noop_fail, /* fill */
2063 PerlIOBase_clearerr,
2064 PerlIOBase_setlinebuf,
2065 NULL, /* get_base */
2066 NULL, /* get_bufsiz */
2069 NULL, /* set_ptrcnt */
2072 /*--------------------------------------------------------------------------------------*/
2073 /* stdio as a layer */
2077 struct _PerlIO base;
2078 FILE * stdio; /* The stream */
2082 PerlIOStdio_fileno(PerlIO *f)
2085 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2089 PerlIOStdio_mode(const char *mode,char *tmode)
2096 if (O_BINARY != O_TEXT)
2104 /* This isn't used yet ... */
2106 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2111 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2113 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2119 return PerlIOBase_pushed(f,mode,arg);
2122 #undef PerlIO_importFILE
2124 PerlIO_importFILE(FILE *stdio, int fl)
2130 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2137 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2142 char *path = SvPV_nolen(*args);
2143 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2144 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2154 char *path = SvPV_nolen(*args);
2158 fd = PerlLIO_open3(path,imode,perm);
2162 FILE *stdio = PerlSIO_fopen(path,mode);
2165 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2166 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2187 stdio = PerlSIO_stdin;
2190 stdio = PerlSIO_stdout;
2193 stdio = PerlSIO_stderr;
2199 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2203 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2213 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2216 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2220 STDCHAR *buf = (STDCHAR *) vbuf;
2221 /* Perl is expecting PerlIO_getc() to fill the buffer
2222 * Linux's stdio does not do that for fread()
2224 int ch = PerlSIO_fgetc(s);
2232 got = PerlSIO_fread(vbuf,1,count,s);
2237 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2240 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2241 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2245 int ch = *buf-- & 0xff;
2246 if (PerlSIO_ungetc(ch,s) != ch)
2255 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2258 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2262 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2265 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2266 return PerlSIO_fseek(stdio,offset,whence);
2270 PerlIOStdio_tell(PerlIO *f)
2273 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2274 return PerlSIO_ftell(stdio);
2278 PerlIOStdio_close(PerlIO *f)
2281 #ifdef SOCKS5_VERSION_NAME
2283 Sock_size_t optlen = sizeof(int);
2285 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2287 #ifdef SOCKS5_VERSION_NAME
2288 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2289 PerlSIO_fclose(stdio) :
2290 close(PerlIO_fileno(f))
2292 PerlSIO_fclose(stdio)
2299 PerlIOStdio_flush(PerlIO *f)
2302 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2303 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2305 return PerlSIO_fflush(stdio);
2310 /* FIXME: This discards ungetc() and pre-read stuff which is
2311 not right if this is just a "sync" from a layer above
2312 Suspect right design is to do _this_ but not have layer above
2313 flush this layer read-to-read
2315 /* Not writeable - sync by attempting a seek */
2317 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2325 PerlIOStdio_fill(PerlIO *f)
2328 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2330 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2331 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2333 if (PerlSIO_fflush(stdio) != 0)
2336 c = PerlSIO_fgetc(stdio);
2337 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2343 PerlIOStdio_eof(PerlIO *f)
2346 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2350 PerlIOStdio_error(PerlIO *f)
2353 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2357 PerlIOStdio_clearerr(PerlIO *f)
2360 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2364 PerlIOStdio_setlinebuf(PerlIO *f)
2367 #ifdef HAS_SETLINEBUF
2368 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2370 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2376 PerlIOStdio_get_base(PerlIO *f)
2379 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2380 return PerlSIO_get_base(stdio);
2384 PerlIOStdio_get_bufsiz(PerlIO *f)
2387 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2388 return PerlSIO_get_bufsiz(stdio);
2392 #ifdef USE_STDIO_PTR
2394 PerlIOStdio_get_ptr(PerlIO *f)
2397 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2398 return PerlSIO_get_ptr(stdio);
2402 PerlIOStdio_get_cnt(PerlIO *f)
2405 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2406 return PerlSIO_get_cnt(stdio);
2410 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2412 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2416 #ifdef STDIO_PTR_LVALUE
2417 PerlSIO_set_ptr(stdio,ptr);
2418 #ifdef STDIO_PTR_LVAL_SETS_CNT
2419 if (PerlSIO_get_cnt(stdio) != (cnt))
2422 assert(PerlSIO_get_cnt(stdio) == (cnt));
2425 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2426 /* Setting ptr _does_ change cnt - we are done */
2429 #else /* STDIO_PTR_LVALUE */
2431 #endif /* STDIO_PTR_LVALUE */
2433 /* Now (or only) set cnt */
2434 #ifdef STDIO_CNT_LVALUE
2435 PerlSIO_set_cnt(stdio,cnt);
2436 #else /* STDIO_CNT_LVALUE */
2437 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2438 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2439 #else /* STDIO_PTR_LVAL_SETS_CNT */
2441 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2442 #endif /* STDIO_CNT_LVALUE */
2447 PerlIO_funcs PerlIO_stdio = {
2449 sizeof(PerlIOStdio),
2466 PerlIOStdio_clearerr,
2467 PerlIOStdio_setlinebuf,
2469 PerlIOStdio_get_base,
2470 PerlIOStdio_get_bufsiz,
2475 #ifdef USE_STDIO_PTR
2476 PerlIOStdio_get_ptr,
2477 PerlIOStdio_get_cnt,
2478 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2479 PerlIOStdio_set_ptrcnt
2480 #else /* STDIO_PTR_LVALUE */
2482 #endif /* STDIO_PTR_LVALUE */
2483 #else /* USE_STDIO_PTR */
2487 #endif /* USE_STDIO_PTR */
2490 #undef PerlIO_exportFILE
2492 PerlIO_exportFILE(PerlIO *f, int fl)
2496 stdio = fdopen(PerlIO_fileno(f),"r+");
2500 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2506 #undef PerlIO_findFILE
2508 PerlIO_findFILE(PerlIO *f)
2513 if (l->tab == &PerlIO_stdio)
2515 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2518 l = *PerlIONext(&l);
2520 return PerlIO_exportFILE(f,0);
2523 #undef PerlIO_releaseFILE
2525 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2529 /*--------------------------------------------------------------------------------------*/
2530 /* perlio buffer layer */
2533 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2536 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2537 int fd = PerlIO_fileno(f);
2539 if (fd >= 0 && PerlLIO_isatty(fd))
2541 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2543 posn = PerlIO_tell(PerlIONext(f));
2544 if (posn != (Off_t) -1)
2548 return PerlIOBase_pushed(f,mode,arg);
2552 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2556 PerlIO *next = PerlIONext(f);
2557 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2558 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2559 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2566 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2573 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2576 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2577 fd = PerlIO_fileno(f);
2578 #if O_BINARY != O_TEXT
2579 /* do something about failing setmode()? --jhi */
2580 PerlLIO_setmode(fd , O_BINARY);
2582 if (init && fd == 2)
2584 /* Initial stderr is unbuffered */
2585 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2592 /* This "flush" is akin to sfio's sync in that it handles files in either
2596 PerlIOBuf_flush(PerlIO *f)
2598 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2600 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2602 /* write() the buffer */
2603 STDCHAR *buf = b->buf;
2605 PerlIO *n = PerlIONext(f);
2608 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2613 else if (count < 0 || PerlIO_error(n))
2615 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2620 b->posn += (p - buf);
2622 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2624 STDCHAR *buf = PerlIO_get_base(f);
2625 /* Note position change */
2626 b->posn += (b->ptr - buf);
2627 if (b->ptr < b->end)
2629 /* We did not consume all of it */
2630 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2632 b->posn = PerlIO_tell(PerlIONext(f));
2636 b->ptr = b->end = b->buf;
2637 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2638 /* FIXME: Is this right for read case ? */
2639 if (PerlIO_flush(PerlIONext(f)) != 0)
2645 PerlIOBuf_fill(PerlIO *f)
2647 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2648 PerlIO *n = PerlIONext(f);
2650 /* FIXME: doing the down-stream flush is a bad idea if it causes
2651 pre-read data in stdio buffer to be discarded
2652 but this is too simplistic - as it skips _our_ hosekeeping
2653 and breaks tell tests.
2654 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2658 if (PerlIO_flush(f) != 0)
2660 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2661 PerlIOBase_flush_linebuf();
2664 PerlIO_get_base(f); /* allocate via vtable */
2666 b->ptr = b->end = b->buf;
2667 if (PerlIO_fast_gets(n))
2669 /* Layer below is also buffered
2670 * We do _NOT_ want to call its ->Read() because that will loop
2671 * till it gets what we asked for which may hang on a pipe etc.
2672 * Instead take anything it has to hand, or ask it to fill _once_.
2674 avail = PerlIO_get_cnt(n);
2677 avail = PerlIO_fill(n);
2679 avail = PerlIO_get_cnt(n);
2682 if (!PerlIO_error(n) && PerlIO_eof(n))
2688 STDCHAR *ptr = PerlIO_get_ptr(n);
2689 SSize_t cnt = avail;
2690 if (avail > b->bufsiz)
2692 Copy(ptr,b->buf,avail,STDCHAR);
2693 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2698 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2703 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2705 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2708 b->end = b->buf+avail;
2709 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2714 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2716 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2721 return PerlIOBase_read(f,vbuf,count);
2727 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2729 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2730 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2733 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2739 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2741 avail = (b->ptr - b->buf);
2746 b->end = b->buf + avail;
2748 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2749 b->posn -= b->bufsiz;
2751 if (avail > (SSize_t) count)
2759 Copy(buf,b->ptr,avail,STDCHAR);
2763 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2770 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2772 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2773 const STDCHAR *buf = (const STDCHAR *) vbuf;
2777 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2781 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2782 if ((SSize_t) count < avail)
2784 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2785 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2805 Copy(buf,b->ptr,avail,STDCHAR);
2812 if (b->ptr >= (b->buf + b->bufsiz))
2815 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2821 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2824 if ((code = PerlIO_flush(f)) == 0)
2826 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2827 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2828 code = PerlIO_seek(PerlIONext(f),offset,whence);
2831 b->posn = PerlIO_tell(PerlIONext(f));
2838 PerlIOBuf_tell(PerlIO *f)
2840 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2841 Off_t posn = b->posn;
2843 posn += (b->ptr - b->buf);
2848 PerlIOBuf_close(PerlIO *f)
2850 IV code = PerlIOBase_close(f);
2851 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2852 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2854 PerlMemShared_free(b->buf);
2857 b->ptr = b->end = b->buf;
2858 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2863 PerlIOBuf_get_ptr(PerlIO *f)
2865 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2872 PerlIOBuf_get_cnt(PerlIO *f)
2874 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2877 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2878 return (b->end - b->ptr);
2883 PerlIOBuf_get_base(PerlIO *f)
2885 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2890 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2893 b->buf = (STDCHAR *)&b->oneword;
2894 b->bufsiz = sizeof(b->oneword);
2903 PerlIOBuf_bufsiz(PerlIO *f)
2905 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2908 return (b->end - b->buf);
2912 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2914 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2918 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2921 assert(PerlIO_get_cnt(f) == cnt);
2922 assert(b->ptr >= b->buf);
2924 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2927 PerlIO_funcs PerlIO_perlio = {
2946 PerlIOBase_clearerr,
2947 PerlIOBase_setlinebuf,
2952 PerlIOBuf_set_ptrcnt,
2955 /*--------------------------------------------------------------------------------------*/
2956 /* Temp layer to hold unread chars when cannot do it any other way */
2959 PerlIOPending_fill(PerlIO *f)
2961 /* Should never happen */
2967 PerlIOPending_close(PerlIO *f)
2969 /* A tad tricky - flush pops us, then we close new top */
2971 return PerlIO_close(f);
2975 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2977 /* A tad tricky - flush pops us, then we seek new top */
2979 return PerlIO_seek(f,offset,whence);
2984 PerlIOPending_flush(PerlIO *f)
2987 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2988 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2990 PerlMemShared_free(b->buf);
2993 PerlIO_pop(aTHX_ f);
2998 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3006 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3011 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3013 IV code = PerlIOBase_pushed(f,mode,arg);
3014 PerlIOl *l = PerlIOBase(f);
3015 /* Our PerlIO_fast_gets must match what we are pushed on,
3016 or sv_gets() etc. get muddled when it changes mid-string
3019 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3020 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3025 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3027 SSize_t avail = PerlIO_get_cnt(f);
3032 got = PerlIOBuf_read(f,vbuf,avail);
3033 if (got >= 0 && got < count)
3035 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3036 if (more >= 0 || got == 0)
3042 PerlIO_funcs PerlIO_pending = {
3046 PerlIOPending_pushed,
3056 PerlIOPending_close,
3057 PerlIOPending_flush,
3061 PerlIOBase_clearerr,
3062 PerlIOBase_setlinebuf,
3067 PerlIOPending_set_ptrcnt,
3072 /*--------------------------------------------------------------------------------------*/
3073 /* crlf - translation
3074 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3075 to hand back a line at a time and keeping a record of which nl we "lied" about.
3076 On write translate "\n" to CR,LF
3081 PerlIOBuf base; /* PerlIOBuf stuff */
3082 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3086 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3089 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3090 code = PerlIOBuf_pushed(f,mode,arg);
3092 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3093 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3094 PerlIOBase(f)->flags);
3101 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3103 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3109 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3110 return PerlIOBuf_unread(f,vbuf,count);
3113 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3114 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3116 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3122 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3124 b->end = b->ptr = b->buf + b->bufsiz;
3125 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3126 b->posn -= b->bufsiz;
3128 while (count > 0 && b->ptr > b->buf)
3133 if (b->ptr - 2 >= b->buf)
3159 PerlIOCrlf_get_cnt(PerlIO *f)
3161 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3164 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3166 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3167 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3169 STDCHAR *nl = b->ptr;
3171 while (nl < b->end && *nl != 0xd)
3173 if (nl < b->end && *nl == 0xd)
3185 /* Not CR,LF but just CR */
3192 /* Blast - found CR as last char in buffer */
3195 /* They may not care, defer work as long as possible */
3196 return (nl - b->ptr);
3201 b->ptr++; /* say we have read it as far as flush() is concerned */
3202 b->buf++; /* Leave space an front of buffer */
3203 b->bufsiz--; /* Buffer is thus smaller */
3204 code = PerlIO_fill(f); /* Fetch some more */
3205 b->bufsiz++; /* Restore size for next time */
3206 b->buf--; /* Point at space */
3207 b->ptr = nl = b->buf; /* Which is what we hand off */
3208 b->posn--; /* Buffer starts here */
3209 *nl = 0xd; /* Fill in the CR */
3211 goto test; /* fill() call worked */
3212 /* CR at EOF - just fall through */
3217 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3223 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3225 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3226 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3227 IV flags = PerlIOBase(f)->flags;
3237 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3244 /* Test code - delete when it works ... */
3251 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3259 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3260 ptr, chk, flags, c->nl, b->end, cnt);
3267 /* They have taken what we lied about */
3274 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3278 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3280 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3281 return PerlIOBuf_write(f,vbuf,count);
3284 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3285 const STDCHAR *buf = (const STDCHAR *) vbuf;
3286 const STDCHAR *ebuf = buf+count;
3289 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3293 STDCHAR *eptr = b->buf+b->bufsiz;
3294 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3295 while (buf < ebuf && b->ptr < eptr)
3299 if ((b->ptr + 2) > eptr)
3301 /* Not room for both */
3307 *(b->ptr)++ = 0xd; /* CR */
3308 *(b->ptr)++ = 0xa; /* LF */
3310 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3329 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3331 return (buf - (STDCHAR *) vbuf);
3336 PerlIOCrlf_flush(PerlIO *f)
3338 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3344 return PerlIOBuf_flush(f);
3347 PerlIO_funcs PerlIO_crlf = {
3350 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3352 PerlIOBase_noop_ok, /* popped */
3356 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3357 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3358 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3366 PerlIOBase_clearerr,
3367 PerlIOBase_setlinebuf,
3372 PerlIOCrlf_set_ptrcnt,
3376 /*--------------------------------------------------------------------------------------*/
3377 /* mmap as "buffer" layer */
3381 PerlIOBuf base; /* PerlIOBuf stuff */
3382 Mmap_t mptr; /* Mapped address */
3383 Size_t len; /* mapped length */
3384 STDCHAR *bbuf; /* malloced buffer if map fails */
3387 static size_t page_size = 0;
3390 PerlIOMmap_map(PerlIO *f)
3393 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3394 IV flags = PerlIOBase(f)->flags;
3398 if (flags & PERLIO_F_CANREAD)
3400 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3401 int fd = PerlIO_fileno(f);
3403 code = fstat(fd,&st);
3404 if (code == 0 && S_ISREG(st.st_mode))
3406 SSize_t len = st.st_size - b->posn;
3411 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3413 SETERRNO(0,SS$_NORMAL);
3414 # ifdef _SC_PAGESIZE
3415 page_size = sysconf(_SC_PAGESIZE);
3417 page_size = sysconf(_SC_PAGE_SIZE);
3419 if ((long)page_size < 0) {
3424 (void)SvUPGRADE(error, SVt_PV);
3425 msg = SvPVx(error, n_a);
3426 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3429 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3433 # ifdef HAS_GETPAGESIZE
3434 page_size = getpagesize();
3436 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3437 page_size = PAGESIZE; /* compiletime, bad */
3441 if ((IV)page_size <= 0)
3442 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3446 /* This is a hack - should never happen - open should have set it ! */
3447 b->posn = PerlIO_tell(PerlIONext(f));
3449 posn = (b->posn / page_size) * page_size;
3450 len = st.st_size - posn;
3451 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3452 if (m->mptr && m->mptr != (Mmap_t) -1)
3454 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3455 madvise(m->mptr, len, MADV_SEQUENTIAL);
3457 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3458 madvise(m->mptr, len, MADV_WILLNEED);
3460 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3461 b->end = ((STDCHAR *)m->mptr) + len;
3462 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3473 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3475 b->ptr = b->end = b->ptr;
3484 PerlIOMmap_unmap(PerlIO *f)
3486 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3487 PerlIOBuf *b = &m->base;
3493 code = munmap(m->mptr, m->len);
3497 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3500 b->ptr = b->end = b->buf;
3501 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3507 PerlIOMmap_get_base(PerlIO *f)
3509 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3510 PerlIOBuf *b = &m->base;
3511 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3513 /* Already have a readbuffer in progress */
3518 /* We have a write buffer or flushed PerlIOBuf read buffer */
3519 m->bbuf = b->buf; /* save it in case we need it again */
3520 b->buf = NULL; /* Clear to trigger below */
3524 PerlIOMmap_map(f); /* Try and map it */
3527 /* Map did not work - recover PerlIOBuf buffer if we have one */
3531 b->ptr = b->end = b->buf;
3534 return PerlIOBuf_get_base(f);
3538 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3540 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3541 PerlIOBuf *b = &m->base;
3542 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3544 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3547 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3552 /* Loose the unwritable mapped buffer */
3554 /* If flush took the "buffer" see if we have one from before */
3555 if (!b->buf && m->bbuf)
3559 PerlIOBuf_get_base(f);
3563 return PerlIOBuf_unread(f,vbuf,count);
3567 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3569 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3570 PerlIOBuf *b = &m->base;
3571 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3573 /* No, or wrong sort of, buffer */
3576 if (PerlIOMmap_unmap(f) != 0)
3579 /* If unmap took the "buffer" see if we have one from before */
3580 if (!b->buf && m->bbuf)
3584 PerlIOBuf_get_base(f);
3588 return PerlIOBuf_write(f,vbuf,count);
3592 PerlIOMmap_flush(PerlIO *f)
3594 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3595 PerlIOBuf *b = &m->base;
3596 IV code = PerlIOBuf_flush(f);
3597 /* Now we are "synced" at PerlIOBuf level */
3602 /* Unmap the buffer */
3603 if (PerlIOMmap_unmap(f) != 0)
3608 /* We seem to have a PerlIOBuf buffer which was not mapped
3609 * remember it in case we need one later
3618 PerlIOMmap_fill(PerlIO *f)
3620 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3621 IV code = PerlIO_flush(f);
3622 if (code == 0 && !b->buf)
3624 code = PerlIOMmap_map(f);
3626 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3628 code = PerlIOBuf_fill(f);
3634 PerlIOMmap_close(PerlIO *f)
3636 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3637 PerlIOBuf *b = &m->base;
3638 IV code = PerlIO_flush(f);
3643 b->ptr = b->end = b->buf;
3645 if (PerlIOBuf_close(f) != 0)
3651 PerlIO_funcs PerlIO_mmap = {
3670 PerlIOBase_clearerr,
3671 PerlIOBase_setlinebuf,
3672 PerlIOMmap_get_base,
3676 PerlIOBuf_set_ptrcnt,
3679 #endif /* HAS_MMAP */
3686 call_atexit(PerlIO_cleanup_layers, NULL);
3691 atexit(&PerlIO_cleanup);
3703 PerlIO_stdstreams(aTHX);
3708 #undef PerlIO_stdout
3715 PerlIO_stdstreams(aTHX);
3720 #undef PerlIO_stderr
3727 PerlIO_stdstreams(aTHX);
3732 /*--------------------------------------------------------------------------------------*/
3734 #undef PerlIO_getname
3736 PerlIO_getname(PerlIO *f, char *buf)
3741 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3742 if (stdio) name = fgetname(stdio, buf);
3744 Perl_croak(aTHX_ "Don't know how to get file name");
3750 /*--------------------------------------------------------------------------------------*/
3751 /* Functions which can be called on any kind of PerlIO implemented
3757 PerlIO_getc(PerlIO *f)
3760 SSize_t count = PerlIO_read(f,buf,1);
3763 return (unsigned char) buf[0];
3768 #undef PerlIO_ungetc
3770 PerlIO_ungetc(PerlIO *f, int ch)
3775 if (PerlIO_unread(f,&buf,1) == 1)
3783 PerlIO_putc(PerlIO *f, int ch)
3786 return PerlIO_write(f,&buf,1);
3791 PerlIO_puts(PerlIO *f, const char *s)
3793 STRLEN len = strlen(s);
3794 return PerlIO_write(f,s,len);
3797 #undef PerlIO_rewind
3799 PerlIO_rewind(PerlIO *f)
3801 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3805 #undef PerlIO_vprintf
3807 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3810 SV *sv = newSVpvn("",0);
3816 Perl_va_copy(ap, apc);
3817 sv_vcatpvf(sv, fmt, &apc);
3819 sv_vcatpvf(sv, fmt, &ap);
3822 wrote = PerlIO_write(f,s,len);
3827 #undef PerlIO_printf
3829 PerlIO_printf(PerlIO *f,const char *fmt,...)
3834 result = PerlIO_vprintf(f,fmt,ap);
3839 #undef PerlIO_stdoutf
3841 PerlIO_stdoutf(const char *fmt,...)
3846 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3851 #undef PerlIO_tmpfile
3853 PerlIO_tmpfile(void)
3855 /* I have no idea how portable mkstemp() is ... */
3856 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3859 FILE *stdio = PerlSIO_tmpfile();
3862 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3868 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3869 int fd = mkstemp(SvPVX(sv));
3873 f = PerlIO_fdopen(fd,"w+");
3876 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3878 PerlLIO_unlink(SvPVX(sv));
3888 #endif /* USE_SFIO */
3889 #endif /* PERLIO_IS_STDIO */
3891 /*======================================================================================*/
3892 /* Now some functions in terms of above which may be needed even if
3893 we are not in true PerlIO mode
3897 #undef PerlIO_setpos
3899 PerlIO_setpos(PerlIO *f, SV *pos)
3905 Off_t *posn = (Off_t *) SvPV(pos,len);
3906 if (f && len == sizeof(Off_t))
3907 return PerlIO_seek(f,*posn,SEEK_SET);
3909 SETERRNO(EINVAL,SS$_IVCHAN);
3913 #undef PerlIO_setpos
3915 PerlIO_setpos(PerlIO *f, SV *pos)
3921 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3922 if (f && len == sizeof(Fpos_t))
3924 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3925 return fsetpos64(f, fpos);
3927 return fsetpos(f, fpos);
3931 SETERRNO(EINVAL,SS$_IVCHAN);
3937 #undef PerlIO_getpos
3939 PerlIO_getpos(PerlIO *f, SV *pos)
3942 Off_t posn = PerlIO_tell(f);
3943 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3944 return (posn == (Off_t)-1) ? -1 : 0;
3947 #undef PerlIO_getpos
3949 PerlIO_getpos(PerlIO *f, SV *pos)
3954 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3955 code = fgetpos64(f, &fpos);
3957 code = fgetpos(f, &fpos);
3959 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3964 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3967 vprintf(char *pat, char *args)
3969 _doprnt(pat, args, stdout);
3970 return 0; /* wrong, but perl doesn't use the return value */
3974 vfprintf(FILE *fd, char *pat, char *args)
3976 _doprnt(pat, args, fd);
3977 return 0; /* wrong, but perl doesn't use the return value */
3982 #ifndef PerlIO_vsprintf
3984 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3986 int val = vsprintf(s, fmt, ap);
3989 if (strlen(s) >= (STRLEN)n)
3992 (void)PerlIO_puts(Perl_error_log,
3993 "panic: sprintf overflow - memory corrupted!\n");
4001 #ifndef PerlIO_sprintf
4003 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4008 result = PerlIO_vsprintf(s, n, fmt, ap);