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
44 #undef PerlMemShared_calloc
45 #define PerlMemShared_calloc(x,y) calloc(x,y)
46 #undef PerlMemShared_free
47 #define PerlMemShared_free(x) free(x)
50 perlsio_binmode(FILE *fp, int iotype, int mode)
52 /* This used to be contents of do_binmode in doio.c */
54 # if defined(atarist) || defined(__MINT__)
57 ((FILE*)fp)->_flag |= _IOBIN;
59 ((FILE*)fp)->_flag &= ~ _IOBIN;
65 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
66 # if defined(WIN32) && defined(__BORLANDC__)
67 /* The translation mode of the stream is maintained independent
68 * of the translation mode of the fd in the Borland RTL (heavy
69 * digging through their runtime sources reveal). User has to
70 * set the mode explicitly for the stream (though they don't
71 * document this anywhere). GSAR 97-5-24
77 fp->flags &= ~ _F_BIN;
85 # if defined(USEMYBINMODE)
86 if (my_binmode(fp, iotype, mode) != FALSE)
98 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
100 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
104 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
110 PerlIO_destruct(pTHX)
115 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
120 return perlsio_binmode(fp,iotype,mode);
124 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
127 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
131 if (*args == &PL_sv_undef)
132 return PerlIO_tmpfile();
135 char *name = SvPV_nolen(*args);
138 fd = PerlLIO_open3(name,imode,perm);
140 return PerlIO_fdopen(fd,(char *)mode+1);
144 return PerlIO_reopen(name,mode,old);
148 return PerlIO_open(name,mode);
154 return PerlIO_fdopen(fd,(char *)mode);
159 XS(XS_PerlIO__Layer__find)
163 Perl_croak(aTHX_ "Usage class->find(name[,load])");
166 char *name = SvPV_nolen(ST(1));
167 ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
174 Perl_boot_core_PerlIO(pTHX)
176 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
182 #ifdef PERLIO_IS_STDIO
187 /* Does nothing (yet) except force this file to be included
188 in perl binary. That allows this file to force inclusion
189 of other functions that may be required by loadable
190 extensions e.g. for FileHandle::tmpfile
194 #undef PerlIO_tmpfile
201 #else /* PERLIO_IS_STDIO */
208 /* This section is just to make sure these functions
209 get pulled in from libsfio.a
212 #undef PerlIO_tmpfile
222 /* Force this file to be included in perl binary. Which allows
223 * this file to force inclusion of other functions that may be
224 * required by loadable extensions e.g. for FileHandle::tmpfile
228 * sfio does its own 'autoflush' on stdout in common cases.
229 * Flush results in a lot of lseek()s to regular files and
230 * lot of small writes to pipes.
232 sfset(sfstdout,SF_SHARE,0);
236 PerlIO_importFILE(FILE *stdio, int fl)
238 int fd = fileno(stdio);
239 PerlIO *r = PerlIO_fdopen(fd,"r+");
244 PerlIO_findFILE(PerlIO *pio)
246 int fd = PerlIO_fileno(pio);
247 FILE *f = fdopen(fd,"r+");
249 if (!f && errno == EINVAL)
251 if (!f && errno == EINVAL)
258 /*======================================================================================*/
259 /* Implement all the PerlIO interface ourselves.
264 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
269 #include <sys/mman.h>
273 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
276 PerlIO_debug(const char *fmt,...)
284 char *s = PerlEnv_getenv("PERLIO_DEBUG");
286 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
293 SV *sv = newSVpvn("",0);
296 s = CopFILE(PL_curcop);
299 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
300 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
303 PerlLIO_write(dbg,s,len);
309 /*--------------------------------------------------------------------------------------*/
311 /* Inner level routines */
313 /* Table of pointers to the PerlIO structs (malloc'ed) */
314 PerlIO *_perlio = NULL;
315 #define PERLIO_TABLE_SIZE 64
320 PerlIO_allocate(pTHX)
322 /* Find a free slot in the table, allocating new table as necessary */
329 last = (PerlIO **)(f);
330 for (i=1; i < PERLIO_TABLE_SIZE; i++)
338 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
348 PerlIO_cleantable(pTHX_ PerlIO **tablep)
350 PerlIO *table = *tablep;
354 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
355 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
363 PerlMemShared_free(table);
368 PerlIO_list_t *PerlIO_known_layers;
369 PerlIO_list_t *PerlIO_def_layerlist;
372 PerlIO_list_alloc(void)
375 Newz('L',list,1,PerlIO_list_t);
381 PerlIO_list_free(PerlIO_list_t *list)
385 if (--list->refcnt == 0)
391 for (i=0; i < list->cur; i++)
393 if (list->array[i].arg)
394 SvREFCNT_dec(list->array[i].arg);
396 Safefree(list->array);
404 PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
408 if (list->cur >= list->len)
412 Renew(list->array,list->len,PerlIO_pair_t);
414 New('l',list->array,list->len,PerlIO_pair_t);
416 p = &(list->array[list->cur++]);
418 if ((p->arg = arg)) {
425 PerlIO_cleanup_layers(pTHXo_ void *data)
428 PerlIO_known_layers = Nullhv;
429 PerlIO_def_layerlist = Nullav;
437 PerlIO_cleantable(aTHX_ &_perlio);
441 PerlIO_destruct(pTHX)
443 PerlIO **table = &_perlio;
448 table = (PerlIO **)(f++);
449 for (i=1; i < PERLIO_TABLE_SIZE; i++)
455 if (l->tab->kind & PERLIO_K_DESTRUCT)
457 PerlIO_debug("Destruct popping %s\n",l->tab->name);
472 PerlIO_pop(pTHX_ PerlIO *f)
477 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
479 (*l->tab->Popped)(f);
481 PerlMemShared_free(l);
485 /*--------------------------------------------------------------------------------------*/
486 /* XS Interface for perl code */
489 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
492 if ((SSize_t) len <= 0)
494 for (i=0; i < PerlIO_known_layers->cur; i++)
496 PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
497 if (strEQ(f->name,name))
499 PerlIO_debug("%.*s => %p\n",(int)len,name,f);
503 if (load && PL_subname && PerlIO_def_layerlist && PerlIO_def_layerlist->cur >= 2)
505 SV *pkgsv = newSVpvn("PerlIO",6);
506 SV *layer = newSVpvn(name,len);
508 /* The two SVs are magically freed by load_module */
509 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
511 return PerlIO_find_layer(aTHX_ name,len,0);
513 PerlIO_debug("Cannot find %.*s\n",(int)len,name);
517 #ifdef USE_ATTRIBUTES_FOR_PERLIO
520 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
524 IO *io = GvIOn((GV *)SvRV(sv));
525 PerlIO *ifp = IoIFP(io);
526 PerlIO *ofp = IoOFP(io);
527 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
533 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
537 IO *io = GvIOn((GV *)SvRV(sv));
538 PerlIO *ifp = IoIFP(io);
539 PerlIO *ofp = IoOFP(io);
540 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
546 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
548 Perl_warn(aTHX_ "clear %"SVf,sv);
553 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
555 Perl_warn(aTHX_ "free %"SVf,sv);
559 MGVTBL perlio_vtab = {
567 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
570 SV *sv = SvRV(ST(1));
575 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
577 mg = mg_find(sv, PERL_MAGIC_ext);
578 mg->mg_virtual = &perlio_vtab;
580 Perl_warn(aTHX_ "attrib %"SVf,sv);
581 for (i=2; i < items; i++)
584 const char *name = SvPV(ST(i),len);
585 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
588 av_push(av,SvREFCNT_inc(layer));
600 #endif /* USE_ATTIBUTES_FOR_PERLIO */
603 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
605 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
606 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
610 XS(XS_PerlIO__Layer__find)
614 Perl_croak(aTHX_ "Usage class->find(name[,load])");
618 char *name = SvPV(ST(1),len);
619 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
620 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
621 ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
627 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
629 if (!PerlIO_known_layers)
630 PerlIO_known_layers = PerlIO_list_alloc();
631 PerlIO_list_push(PerlIO_known_layers,tab,Nullsv);
632 PerlIO_debug("define %s %p\n",tab->name,tab);
636 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
640 const char *s = names;
643 while (isSPACE(*s) || *s == ':')
649 const char *as = Nullch;
653 /* Message is consistent with how attribute lists are passed.
654 Even though this means "foo : : bar" is seen as an invalid separator
656 char q = ((*s == '\'') ? '"' : '\'');
657 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
663 } while (isALNUM(*e));
681 /* It's a nul terminated string, not allowed to \ the terminating null.
682 Anything other character is passed over. */
690 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
700 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s,llen,1);
703 PerlIO_list_push(av, layer, (as) ? newSVpvn(as,alen) : &PL_sv_undef);
706 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
718 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
720 PerlIO_funcs *tab = &PerlIO_perlio;
721 if (O_BINARY != O_TEXT)
727 if (PerlIO_stdio.Set_ptrcnt)
732 PerlIO_debug("Pushing %s\n",tab->name);
733 PerlIO_list_push(av,PerlIO_find_layer(aTHX_ tab->name,0,0),&PL_sv_undef);
737 PerlIO_arg_fetch(PerlIO_list_t *av,IV n)
739 return av->array[n].arg;
743 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
745 if (n >= 0 && n < av->cur)
747 PerlIO_debug("Layer %ld is %s\n",n,av->array[n].funcs->name);
748 return av->array[n].funcs;
751 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
756 PerlIO_default_layers(pTHX)
758 if (!PerlIO_def_layerlist)
760 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
761 PerlIO_def_layerlist = PerlIO_list_alloc();
763 PerlIO_define_layer(aTHX_ &PerlIO_raw);
764 PerlIO_define_layer(aTHX_ &PerlIO_unix);
765 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
766 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
767 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
769 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
771 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
772 PerlIO_define_layer(aTHX_ &PerlIO_byte);
773 PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0),&PL_sv_undef);
776 PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
780 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
783 if (PerlIO_def_layerlist->cur < 2)
785 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
787 return PerlIO_def_layerlist;
791 Perl_boot_core_PerlIO(pTHX)
793 #ifdef USE_ATTRIBUTES_FOR_PERLIO
794 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
796 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
800 PerlIO_default_layer(pTHX_ I32 n)
802 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
805 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
808 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
809 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
812 PerlIO_stdstreams(pTHX)
816 PerlIO_allocate(aTHX);
817 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
818 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
819 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
824 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
827 l = PerlMemShared_calloc(tab->size,sizeof(char));
830 Zero(l,tab->size,char);
834 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
835 (mode) ? mode : "(Null)",arg);
836 if ((*l->tab->Pushed)(f,mode,arg) != 0)
846 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
860 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
862 /* Remove the dummy layer */
865 /* Pop back to bottom layer */
869 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
877 /* Nothing bellow - push unix on top then remove it */
878 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
880 PerlIO_pop(aTHX_ PerlIONext(f));
885 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
892 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
894 IV max = layers->cur;
898 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
901 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
913 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
918 PerlIO_list_t *layers = PerlIO_list_alloc();
919 code = PerlIO_parse_layers(aTHX_ layers,names);
922 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
924 PerlIO_list_free(layers);
930 /*--------------------------------------------------------------------------------------*/
931 /* Given the abstraction above the public API functions */
934 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
936 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
937 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
938 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
944 if (PerlIOBase(top)->tab == &PerlIO_crlf)
947 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
950 top = PerlIONext(top);
953 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
958 PerlIO__close(PerlIO *f)
961 return (*PerlIOBase(f)->tab->Close)(f);
964 SETERRNO(EBADF,SS$_IVCHAN);
969 #undef PerlIO_fdupopen
971 PerlIO_fdupopen(pTHX_ PerlIO *f)
976 int fd = PerlLIO_dup(PerlIO_fileno(f));
977 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
980 Off_t posn = PerlIO_tell(f);
981 PerlIO_seek(new,posn,SEEK_SET);
987 SETERRNO(EBADF,SS$_IVCHAN);
994 PerlIO_close(PerlIO *f)
1000 code = (*PerlIOBase(f)->tab->Close)(f);
1003 PerlIO_pop(aTHX_ f);
1009 #undef PerlIO_fileno
1011 PerlIO_fileno(PerlIO *f)
1014 return (*PerlIOBase(f)->tab->Fileno)(f);
1017 SETERRNO(EBADF,SS$_IVCHAN);
1023 PerlIO_context_layers(pTHX_ const char *mode)
1025 const char *type = NULL;
1026 /* Need to supply default layer info from open.pm */
1029 SV *layers = PL_curcop->cop_io;
1033 type = SvPV(layers,len);
1034 if (type && mode[0] != 'r')
1036 /* Skip to write part */
1037 const char *s = strchr(type,0);
1038 if (s && (s-type) < len)
1048 static PerlIO_funcs *
1049 PerlIO_layer_from_ref(pTHX_ SV *sv)
1051 /* For any scalar type load the handler which is bundled with perl */
1052 if (SvTYPE(sv) < SVt_PVAV)
1053 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1055 /* For other types allow if layer is known but don't try and load it */
1059 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1061 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1063 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1065 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1071 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1073 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1076 PerlIO_stdstreams(aTHX);
1080 /* If it is a reference but not an object see if we have a handler for it */
1081 if (SvROK(arg) && !sv_isobject(arg))
1083 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1086 def = PerlIO_list_alloc();
1087 PerlIO_list_push(def,handler,&PL_sv_undef);
1090 /* Don't fail if handler cannot be found
1091 * :Via(...) etc. may do something sensible
1092 * else we will just stringfy and open resulting string.
1097 layers = PerlIO_context_layers(aTHX_ mode);
1098 if (layers && *layers)
1104 av = PerlIO_list_alloc();
1105 for (i=0; i < def->cur; i++)
1107 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1114 PerlIO_parse_layers(aTHX_ av,layers);
1126 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1128 if (!f && narg == 1 && *args == &PL_sv_undef)
1130 if ((f = PerlIO_tmpfile()))
1133 layers = PerlIO_context_layers(aTHX_ mode);
1134 if (layers && *layers)
1135 PerlIO_apply_layers(aTHX_ f,mode,layers);
1140 PerlIO_list_t *layera = NULL;
1142 PerlIO_funcs *tab = NULL;
1145 /* This is "reopen" - it is not tested as perl does not use it yet */
1147 layera = PerlIO_list_alloc();
1150 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1151 PerlIO_list_push(layera,l->tab,arg);
1152 l = *PerlIONext(&l);
1157 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1159 /* Start at "top" of layer stack */
1163 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1173 /* Found that layer 'n' can do opens - call it */
1174 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1175 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1176 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1179 if (n+1 < layera->cur)
1181 /* More layers above the one that we used to open - apply them now */
1182 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1189 PerlIO_list_free(layera);
1195 #undef PerlIO_fdopen
1197 PerlIO_fdopen(int fd, const char *mode)
1200 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1205 PerlIO_open(const char *path, const char *mode)
1208 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1209 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1212 #undef PerlIO_reopen
1214 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1217 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1218 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1223 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1226 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1229 SETERRNO(EBADF,SS$_IVCHAN);
1234 #undef PerlIO_unread
1236 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1239 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1242 SETERRNO(EBADF,SS$_IVCHAN);
1249 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1252 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1255 SETERRNO(EBADF,SS$_IVCHAN);
1262 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1265 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1268 SETERRNO(EBADF,SS$_IVCHAN);
1275 PerlIO_tell(PerlIO *f)
1278 return (*PerlIOBase(f)->tab->Tell)(f);
1281 SETERRNO(EBADF,SS$_IVCHAN);
1288 PerlIO_flush(PerlIO *f)
1294 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1295 if (tab && tab->Flush)
1297 return (*tab->Flush)(f);
1301 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1302 SETERRNO(EBADF,SS$_IVCHAN);
1308 PerlIO_debug("Cannot flush f=%p\n",f);
1309 SETERRNO(EBADF,SS$_IVCHAN);
1315 /* Is it good API design to do flush-all on NULL,
1316 * a potentially errorneous input? Maybe some magical
1317 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1318 * Yes, stdio does similar things on fflush(NULL),
1319 * but should we be bound by their design decisions?
1321 PerlIO **table = &_perlio;
1323 while ((f = *table))
1326 table = (PerlIO **)(f++);
1327 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1329 if (*f && PerlIO_flush(f) != 0)
1339 PerlIOBase_flush_linebuf()
1341 PerlIO **table = &_perlio;
1343 while ((f = *table))
1346 table = (PerlIO **)(f++);
1347 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1349 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1350 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1359 PerlIO_fill(PerlIO *f)
1362 return (*PerlIOBase(f)->tab->Fill)(f);
1365 SETERRNO(EBADF,SS$_IVCHAN);
1370 #undef PerlIO_isutf8
1372 PerlIO_isutf8(PerlIO *f)
1375 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1378 SETERRNO(EBADF,SS$_IVCHAN);
1385 PerlIO_eof(PerlIO *f)
1388 return (*PerlIOBase(f)->tab->Eof)(f);
1391 SETERRNO(EBADF,SS$_IVCHAN);
1398 PerlIO_error(PerlIO *f)
1401 return (*PerlIOBase(f)->tab->Error)(f);
1404 SETERRNO(EBADF,SS$_IVCHAN);
1409 #undef PerlIO_clearerr
1411 PerlIO_clearerr(PerlIO *f)
1414 (*PerlIOBase(f)->tab->Clearerr)(f);
1416 SETERRNO(EBADF,SS$_IVCHAN);
1419 #undef PerlIO_setlinebuf
1421 PerlIO_setlinebuf(PerlIO *f)
1424 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1426 SETERRNO(EBADF,SS$_IVCHAN);
1429 #undef PerlIO_has_base
1431 PerlIO_has_base(PerlIO *f)
1433 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1437 #undef PerlIO_fast_gets
1439 PerlIO_fast_gets(PerlIO *f)
1441 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1443 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1444 return (tab->Set_ptrcnt != NULL);
1449 #undef PerlIO_has_cntptr
1451 PerlIO_has_cntptr(PerlIO *f)
1455 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1456 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1461 #undef PerlIO_canset_cnt
1463 PerlIO_canset_cnt(PerlIO *f)
1467 PerlIOl *l = PerlIOBase(f);
1468 return (l->tab->Set_ptrcnt != NULL);
1473 #undef PerlIO_get_base
1475 PerlIO_get_base(PerlIO *f)
1478 return (*PerlIOBase(f)->tab->Get_base)(f);
1482 #undef PerlIO_get_bufsiz
1484 PerlIO_get_bufsiz(PerlIO *f)
1487 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1491 #undef PerlIO_get_ptr
1493 PerlIO_get_ptr(PerlIO *f)
1495 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1496 if (tab->Get_ptr == NULL)
1498 return (*tab->Get_ptr)(f);
1501 #undef PerlIO_get_cnt
1503 PerlIO_get_cnt(PerlIO *f)
1505 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1506 if (tab->Get_cnt == NULL)
1508 return (*tab->Get_cnt)(f);
1511 #undef PerlIO_set_cnt
1513 PerlIO_set_cnt(PerlIO *f,int cnt)
1515 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1518 #undef PerlIO_set_ptrcnt
1520 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1522 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1523 if (tab->Set_ptrcnt == NULL)
1526 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1528 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1531 /*--------------------------------------------------------------------------------------*/
1532 /* utf8 and raw dummy layers */
1535 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1540 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1541 PerlIO_pop(aTHX_ f);
1542 if (tab->kind & PERLIO_K_UTF8)
1543 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1545 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1551 PerlIO_funcs PerlIO_utf8 = {
1554 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1572 NULL, /* get_base */
1573 NULL, /* get_bufsiz */
1576 NULL, /* set_ptrcnt */
1579 PerlIO_funcs PerlIO_byte = {
1600 NULL, /* get_base */
1601 NULL, /* get_bufsiz */
1604 NULL, /* set_ptrcnt */
1608 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)
1610 PerlIO_funcs *tab = PerlIO_default_btm();
1611 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1614 PerlIO_funcs PerlIO_raw = {
1635 NULL, /* get_base */
1636 NULL, /* get_bufsiz */
1639 NULL, /* set_ptrcnt */
1641 /*--------------------------------------------------------------------------------------*/
1642 /*--------------------------------------------------------------------------------------*/
1643 /* "Methods" of the "base class" */
1646 PerlIOBase_fileno(PerlIO *f)
1648 return PerlIO_fileno(PerlIONext(f));
1652 PerlIO_modestr(PerlIO *f,char *buf)
1655 IV flags = PerlIOBase(f)->flags;
1656 if (flags & PERLIO_F_APPEND)
1659 if (flags & PERLIO_F_CANREAD)
1664 else if (flags & PERLIO_F_CANREAD)
1667 if (flags & PERLIO_F_CANWRITE)
1670 else if (flags & PERLIO_F_CANWRITE)
1673 if (flags & PERLIO_F_CANREAD)
1678 #if O_TEXT != O_BINARY
1679 if (!(flags & PERLIO_F_CRLF))
1687 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1689 PerlIOl *l = PerlIOBase(f);
1691 const char *omode = mode;
1694 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1695 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1696 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1697 if (tab->Set_ptrcnt != NULL)
1698 l->flags |= PERLIO_F_FASTGETS;
1701 if (*mode == '#' || *mode == 'I')
1706 l->flags |= PERLIO_F_CANREAD;
1709 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1712 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1715 SETERRNO(EINVAL,LIB$_INVARG);
1723 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1726 l->flags &= ~PERLIO_F_CRLF;
1729 l->flags |= PERLIO_F_CRLF;
1732 SETERRNO(EINVAL,LIB$_INVARG);
1741 l->flags |= l->next->flags &
1742 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1746 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1747 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1748 l->flags,PerlIO_modestr(f,temp));
1754 PerlIOBase_popped(PerlIO *f)
1760 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1763 Off_t old = PerlIO_tell(f);
1765 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1766 done = PerlIOBuf_unread(f,vbuf,count);
1767 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1772 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1774 STDCHAR *buf = (STDCHAR *) vbuf;
1777 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1781 SSize_t avail = PerlIO_get_cnt(f);
1784 take = (count < avail) ? count : avail;
1787 STDCHAR *ptr = PerlIO_get_ptr(f);
1788 Copy(ptr,buf,take,STDCHAR);
1789 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1793 if (count > 0 && avail <= 0)
1795 if (PerlIO_fill(f) != 0)
1799 return (buf - (STDCHAR *) vbuf);
1805 PerlIOBase_noop_ok(PerlIO *f)
1811 PerlIOBase_noop_fail(PerlIO *f)
1817 PerlIOBase_close(PerlIO *f)
1820 PerlIO *n = PerlIONext(f);
1821 if (PerlIO_flush(f) != 0)
1823 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1825 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1830 PerlIOBase_eof(PerlIO *f)
1834 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1840 PerlIOBase_error(PerlIO *f)
1844 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1850 PerlIOBase_clearerr(PerlIO *f)
1854 PerlIO *n = PerlIONext(f);
1855 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1862 PerlIOBase_setlinebuf(PerlIO *f)
1866 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1870 /*--------------------------------------------------------------------------------------*/
1871 /* Bottom-most level for UNIX-like case */
1875 struct _PerlIO base; /* The generic part */
1876 int fd; /* UNIX like file descriptor */
1877 int oflags; /* open/fcntl flags */
1881 PerlIOUnix_oflags(const char *mode)
1896 oflags = O_CREAT|O_TRUNC;
1907 oflags = O_CREAT|O_APPEND;
1923 else if (*mode == 't')
1926 oflags &= ~O_BINARY;
1929 /* Always open in binary mode */
1931 if (*mode || oflags == -1)
1933 SETERRNO(EINVAL,LIB$_INVARG);
1940 PerlIOUnix_fileno(PerlIO *f)
1942 return PerlIOSelf(f,PerlIOUnix)->fd;
1946 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1948 IV code = PerlIOBase_pushed(f,mode,arg);
1951 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1952 s->fd = PerlIO_fileno(PerlIONext(f));
1953 s->oflags = PerlIOUnix_oflags(mode);
1955 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1960 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)
1964 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1965 (*PerlIOBase(f)->tab->Close)(f);
1969 char *path = SvPV_nolen(*args);
1974 imode = PerlIOUnix_oflags(mode);
1979 fd = PerlLIO_open3(path,imode,perm);
1989 f = PerlIO_allocate(aTHX);
1990 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1993 s = PerlIOSelf(f,PerlIOUnix);
1996 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2003 /* FIXME: pop layers ??? */
2010 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2013 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2014 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2018 SSize_t len = PerlLIO_read(fd,vbuf,count);
2019 if (len >= 0 || errno != EINTR)
2022 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2023 else if (len == 0 && count != 0)
2024 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2032 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2035 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2038 SSize_t len = PerlLIO_write(fd,vbuf,count);
2039 if (len >= 0 || errno != EINTR)
2042 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2050 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2053 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2054 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2055 return (new == (Off_t) -1) ? -1 : 0;
2059 PerlIOUnix_tell(PerlIO *f)
2062 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2066 PerlIOUnix_close(PerlIO *f)
2069 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2071 while (PerlLIO_close(fd) != 0)
2082 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2087 PerlIO_funcs PerlIO_unix = {
2102 PerlIOBase_noop_ok, /* flush */
2103 PerlIOBase_noop_fail, /* fill */
2106 PerlIOBase_clearerr,
2107 PerlIOBase_setlinebuf,
2108 NULL, /* get_base */
2109 NULL, /* get_bufsiz */
2112 NULL, /* set_ptrcnt */
2115 /*--------------------------------------------------------------------------------------*/
2116 /* stdio as a layer */
2120 struct _PerlIO base;
2121 FILE * stdio; /* The stream */
2125 PerlIOStdio_fileno(PerlIO *f)
2128 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2132 PerlIOStdio_mode(const char *mode,char *tmode)
2139 if (O_BINARY != O_TEXT)
2147 /* This isn't used yet ... */
2149 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2154 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2156 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2162 return PerlIOBase_pushed(f,mode,arg);
2165 #undef PerlIO_importFILE
2167 PerlIO_importFILE(FILE *stdio, int fl)
2173 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2180 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)
2185 char *path = SvPV_nolen(*args);
2186 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2187 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2197 char *path = SvPV_nolen(*args);
2201 fd = PerlLIO_open3(path,imode,perm);
2205 FILE *stdio = PerlSIO_fopen(path,mode);
2208 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2209 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2230 stdio = PerlSIO_stdin;
2233 stdio = PerlSIO_stdout;
2236 stdio = PerlSIO_stderr;
2242 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2246 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2256 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2259 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2263 STDCHAR *buf = (STDCHAR *) vbuf;
2264 /* Perl is expecting PerlIO_getc() to fill the buffer
2265 * Linux's stdio does not do that for fread()
2267 int ch = PerlSIO_fgetc(s);
2275 got = PerlSIO_fread(vbuf,1,count,s);
2280 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2283 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2284 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2288 int ch = *buf-- & 0xff;
2289 if (PerlSIO_ungetc(ch,s) != ch)
2298 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2301 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2305 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2308 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2309 return PerlSIO_fseek(stdio,offset,whence);
2313 PerlIOStdio_tell(PerlIO *f)
2316 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2317 return PerlSIO_ftell(stdio);
2321 PerlIOStdio_close(PerlIO *f)
2324 #ifdef SOCKS5_VERSION_NAME
2326 Sock_size_t optlen = sizeof(int);
2328 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2330 #ifdef SOCKS5_VERSION_NAME
2331 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2332 PerlSIO_fclose(stdio) :
2333 close(PerlIO_fileno(f))
2335 PerlSIO_fclose(stdio)
2342 PerlIOStdio_flush(PerlIO *f)
2345 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2346 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2348 return PerlSIO_fflush(stdio);
2353 /* FIXME: This discards ungetc() and pre-read stuff which is
2354 not right if this is just a "sync" from a layer above
2355 Suspect right design is to do _this_ but not have layer above
2356 flush this layer read-to-read
2358 /* Not writeable - sync by attempting a seek */
2360 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2368 PerlIOStdio_fill(PerlIO *f)
2371 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2373 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2374 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2376 if (PerlSIO_fflush(stdio) != 0)
2379 c = PerlSIO_fgetc(stdio);
2380 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2386 PerlIOStdio_eof(PerlIO *f)
2389 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2393 PerlIOStdio_error(PerlIO *f)
2396 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2400 PerlIOStdio_clearerr(PerlIO *f)
2403 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2407 PerlIOStdio_setlinebuf(PerlIO *f)
2410 #ifdef HAS_SETLINEBUF
2411 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2413 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2419 PerlIOStdio_get_base(PerlIO *f)
2422 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2423 return PerlSIO_get_base(stdio);
2427 PerlIOStdio_get_bufsiz(PerlIO *f)
2430 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2431 return PerlSIO_get_bufsiz(stdio);
2435 #ifdef USE_STDIO_PTR
2437 PerlIOStdio_get_ptr(PerlIO *f)
2440 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2441 return PerlSIO_get_ptr(stdio);
2445 PerlIOStdio_get_cnt(PerlIO *f)
2448 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2449 return PerlSIO_get_cnt(stdio);
2453 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2455 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2459 #ifdef STDIO_PTR_LVALUE
2460 PerlSIO_set_ptr(stdio,ptr);
2461 #ifdef STDIO_PTR_LVAL_SETS_CNT
2462 if (PerlSIO_get_cnt(stdio) != (cnt))
2465 assert(PerlSIO_get_cnt(stdio) == (cnt));
2468 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2469 /* Setting ptr _does_ change cnt - we are done */
2472 #else /* STDIO_PTR_LVALUE */
2474 #endif /* STDIO_PTR_LVALUE */
2476 /* Now (or only) set cnt */
2477 #ifdef STDIO_CNT_LVALUE
2478 PerlSIO_set_cnt(stdio,cnt);
2479 #else /* STDIO_CNT_LVALUE */
2480 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2481 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2482 #else /* STDIO_PTR_LVAL_SETS_CNT */
2484 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2485 #endif /* STDIO_CNT_LVALUE */
2490 PerlIO_funcs PerlIO_stdio = {
2492 sizeof(PerlIOStdio),
2509 PerlIOStdio_clearerr,
2510 PerlIOStdio_setlinebuf,
2512 PerlIOStdio_get_base,
2513 PerlIOStdio_get_bufsiz,
2518 #ifdef USE_STDIO_PTR
2519 PerlIOStdio_get_ptr,
2520 PerlIOStdio_get_cnt,
2521 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2522 PerlIOStdio_set_ptrcnt
2523 #else /* STDIO_PTR_LVALUE */
2525 #endif /* STDIO_PTR_LVALUE */
2526 #else /* USE_STDIO_PTR */
2530 #endif /* USE_STDIO_PTR */
2533 #undef PerlIO_exportFILE
2535 PerlIO_exportFILE(PerlIO *f, int fl)
2539 stdio = fdopen(PerlIO_fileno(f),"r+");
2543 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2549 #undef PerlIO_findFILE
2551 PerlIO_findFILE(PerlIO *f)
2556 if (l->tab == &PerlIO_stdio)
2558 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2561 l = *PerlIONext(&l);
2563 return PerlIO_exportFILE(f,0);
2566 #undef PerlIO_releaseFILE
2568 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2572 /*--------------------------------------------------------------------------------------*/
2573 /* perlio buffer layer */
2576 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2579 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2580 int fd = PerlIO_fileno(f);
2582 if (fd >= 0 && PerlLIO_isatty(fd))
2584 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2586 posn = PerlIO_tell(PerlIONext(f));
2587 if (posn != (Off_t) -1)
2591 return PerlIOBase_pushed(f,mode,arg);
2595 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)
2599 PerlIO *next = PerlIONext(f);
2600 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2601 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2602 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2609 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2616 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2619 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2620 fd = PerlIO_fileno(f);
2621 #if O_BINARY != O_TEXT
2622 /* do something about failing setmode()? --jhi */
2623 PerlLIO_setmode(fd , O_BINARY);
2625 if (init && fd == 2)
2627 /* Initial stderr is unbuffered */
2628 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2635 /* This "flush" is akin to sfio's sync in that it handles files in either
2639 PerlIOBuf_flush(PerlIO *f)
2641 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2643 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2645 /* write() the buffer */
2646 STDCHAR *buf = b->buf;
2648 PerlIO *n = PerlIONext(f);
2651 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2656 else if (count < 0 || PerlIO_error(n))
2658 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2663 b->posn += (p - buf);
2665 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2667 STDCHAR *buf = PerlIO_get_base(f);
2668 /* Note position change */
2669 b->posn += (b->ptr - buf);
2670 if (b->ptr < b->end)
2672 /* We did not consume all of it */
2673 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2675 b->posn = PerlIO_tell(PerlIONext(f));
2679 b->ptr = b->end = b->buf;
2680 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2681 /* FIXME: Is this right for read case ? */
2682 if (PerlIO_flush(PerlIONext(f)) != 0)
2688 PerlIOBuf_fill(PerlIO *f)
2690 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2691 PerlIO *n = PerlIONext(f);
2693 /* FIXME: doing the down-stream flush is a bad idea if it causes
2694 pre-read data in stdio buffer to be discarded
2695 but this is too simplistic - as it skips _our_ hosekeeping
2696 and breaks tell tests.
2697 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2701 if (PerlIO_flush(f) != 0)
2703 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2704 PerlIOBase_flush_linebuf();
2707 PerlIO_get_base(f); /* allocate via vtable */
2709 b->ptr = b->end = b->buf;
2710 if (PerlIO_fast_gets(n))
2712 /* Layer below is also buffered
2713 * We do _NOT_ want to call its ->Read() because that will loop
2714 * till it gets what we asked for which may hang on a pipe etc.
2715 * Instead take anything it has to hand, or ask it to fill _once_.
2717 avail = PerlIO_get_cnt(n);
2720 avail = PerlIO_fill(n);
2722 avail = PerlIO_get_cnt(n);
2725 if (!PerlIO_error(n) && PerlIO_eof(n))
2731 STDCHAR *ptr = PerlIO_get_ptr(n);
2732 SSize_t cnt = avail;
2733 if (avail > b->bufsiz)
2735 Copy(ptr,b->buf,avail,STDCHAR);
2736 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2741 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2746 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2748 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2751 b->end = b->buf+avail;
2752 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2757 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2759 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2764 return PerlIOBase_read(f,vbuf,count);
2770 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2772 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2773 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2776 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2782 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2784 avail = (b->ptr - b->buf);
2789 b->end = b->buf + avail;
2791 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2792 b->posn -= b->bufsiz;
2794 if (avail > (SSize_t) count)
2802 Copy(buf,b->ptr,avail,STDCHAR);
2806 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2813 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2815 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2816 const STDCHAR *buf = (const STDCHAR *) vbuf;
2820 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2824 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2825 if ((SSize_t) count < avail)
2827 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2828 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2848 Copy(buf,b->ptr,avail,STDCHAR);
2855 if (b->ptr >= (b->buf + b->bufsiz))
2858 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2864 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2867 if ((code = PerlIO_flush(f)) == 0)
2869 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2870 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2871 code = PerlIO_seek(PerlIONext(f),offset,whence);
2874 b->posn = PerlIO_tell(PerlIONext(f));
2881 PerlIOBuf_tell(PerlIO *f)
2883 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2884 Off_t posn = b->posn;
2886 posn += (b->ptr - b->buf);
2891 PerlIOBuf_close(PerlIO *f)
2893 IV code = PerlIOBase_close(f);
2894 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2895 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2897 PerlMemShared_free(b->buf);
2900 b->ptr = b->end = b->buf;
2901 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2906 PerlIOBuf_get_ptr(PerlIO *f)
2908 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2915 PerlIOBuf_get_cnt(PerlIO *f)
2917 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2920 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2921 return (b->end - b->ptr);
2926 PerlIOBuf_get_base(PerlIO *f)
2928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2933 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2936 b->buf = (STDCHAR *)&b->oneword;
2937 b->bufsiz = sizeof(b->oneword);
2946 PerlIOBuf_bufsiz(PerlIO *f)
2948 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2951 return (b->end - b->buf);
2955 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2957 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2961 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2964 assert(PerlIO_get_cnt(f) == cnt);
2965 assert(b->ptr >= b->buf);
2967 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2970 PerlIO_funcs PerlIO_perlio = {
2989 PerlIOBase_clearerr,
2990 PerlIOBase_setlinebuf,
2995 PerlIOBuf_set_ptrcnt,
2998 /*--------------------------------------------------------------------------------------*/
2999 /* Temp layer to hold unread chars when cannot do it any other way */
3002 PerlIOPending_fill(PerlIO *f)
3004 /* Should never happen */
3010 PerlIOPending_close(PerlIO *f)
3012 /* A tad tricky - flush pops us, then we close new top */
3014 return PerlIO_close(f);
3018 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3020 /* A tad tricky - flush pops us, then we seek new top */
3022 return PerlIO_seek(f,offset,whence);
3027 PerlIOPending_flush(PerlIO *f)
3030 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3031 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3033 PerlMemShared_free(b->buf);
3036 PerlIO_pop(aTHX_ f);
3041 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3049 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3054 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3056 IV code = PerlIOBase_pushed(f,mode,arg);
3057 PerlIOl *l = PerlIOBase(f);
3058 /* Our PerlIO_fast_gets must match what we are pushed on,
3059 or sv_gets() etc. get muddled when it changes mid-string
3062 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3063 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3068 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3070 SSize_t avail = PerlIO_get_cnt(f);
3075 got = PerlIOBuf_read(f,vbuf,avail);
3076 if (got >= 0 && got < count)
3078 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3079 if (more >= 0 || got == 0)
3085 PerlIO_funcs PerlIO_pending = {
3089 PerlIOPending_pushed,
3099 PerlIOPending_close,
3100 PerlIOPending_flush,
3104 PerlIOBase_clearerr,
3105 PerlIOBase_setlinebuf,
3110 PerlIOPending_set_ptrcnt,
3115 /*--------------------------------------------------------------------------------------*/
3116 /* crlf - translation
3117 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3118 to hand back a line at a time and keeping a record of which nl we "lied" about.
3119 On write translate "\n" to CR,LF
3124 PerlIOBuf base; /* PerlIOBuf stuff */
3125 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3129 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3132 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3133 code = PerlIOBuf_pushed(f,mode,arg);
3135 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3136 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3137 PerlIOBase(f)->flags);
3144 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3146 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3152 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3153 return PerlIOBuf_unread(f,vbuf,count);
3156 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3157 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3159 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3165 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3167 b->end = b->ptr = b->buf + b->bufsiz;
3168 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3169 b->posn -= b->bufsiz;
3171 while (count > 0 && b->ptr > b->buf)
3176 if (b->ptr - 2 >= b->buf)
3202 PerlIOCrlf_get_cnt(PerlIO *f)
3204 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3207 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3209 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3210 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3212 STDCHAR *nl = b->ptr;
3214 while (nl < b->end && *nl != 0xd)
3216 if (nl < b->end && *nl == 0xd)
3228 /* Not CR,LF but just CR */
3235 /* Blast - found CR as last char in buffer */
3238 /* They may not care, defer work as long as possible */
3239 return (nl - b->ptr);
3244 b->ptr++; /* say we have read it as far as flush() is concerned */
3245 b->buf++; /* Leave space an front of buffer */
3246 b->bufsiz--; /* Buffer is thus smaller */
3247 code = PerlIO_fill(f); /* Fetch some more */
3248 b->bufsiz++; /* Restore size for next time */
3249 b->buf--; /* Point at space */
3250 b->ptr = nl = b->buf; /* Which is what we hand off */
3251 b->posn--; /* Buffer starts here */
3252 *nl = 0xd; /* Fill in the CR */
3254 goto test; /* fill() call worked */
3255 /* CR at EOF - just fall through */
3260 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3266 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3268 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3269 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3270 IV flags = PerlIOBase(f)->flags;
3280 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3287 /* Test code - delete when it works ... */
3294 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3302 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3303 ptr, chk, flags, c->nl, b->end, cnt);
3310 /* They have taken what we lied about */
3317 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3321 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3323 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3324 return PerlIOBuf_write(f,vbuf,count);
3327 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3328 const STDCHAR *buf = (const STDCHAR *) vbuf;
3329 const STDCHAR *ebuf = buf+count;
3332 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3336 STDCHAR *eptr = b->buf+b->bufsiz;
3337 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3338 while (buf < ebuf && b->ptr < eptr)
3342 if ((b->ptr + 2) > eptr)
3344 /* Not room for both */
3350 *(b->ptr)++ = 0xd; /* CR */
3351 *(b->ptr)++ = 0xa; /* LF */
3353 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3372 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3374 return (buf - (STDCHAR *) vbuf);
3379 PerlIOCrlf_flush(PerlIO *f)
3381 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3387 return PerlIOBuf_flush(f);
3390 PerlIO_funcs PerlIO_crlf = {
3393 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3395 PerlIOBase_noop_ok, /* popped */
3399 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3400 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3401 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3409 PerlIOBase_clearerr,
3410 PerlIOBase_setlinebuf,
3415 PerlIOCrlf_set_ptrcnt,
3419 /*--------------------------------------------------------------------------------------*/
3420 /* mmap as "buffer" layer */
3424 PerlIOBuf base; /* PerlIOBuf stuff */
3425 Mmap_t mptr; /* Mapped address */
3426 Size_t len; /* mapped length */
3427 STDCHAR *bbuf; /* malloced buffer if map fails */
3430 static size_t page_size = 0;
3433 PerlIOMmap_map(PerlIO *f)
3436 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3437 IV flags = PerlIOBase(f)->flags;
3441 if (flags & PERLIO_F_CANREAD)
3443 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3444 int fd = PerlIO_fileno(f);
3446 code = fstat(fd,&st);
3447 if (code == 0 && S_ISREG(st.st_mode))
3449 SSize_t len = st.st_size - b->posn;
3454 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3456 SETERRNO(0,SS$_NORMAL);
3457 # ifdef _SC_PAGESIZE
3458 page_size = sysconf(_SC_PAGESIZE);
3460 page_size = sysconf(_SC_PAGE_SIZE);
3462 if ((long)page_size < 0) {
3467 (void)SvUPGRADE(error, SVt_PV);
3468 msg = SvPVx(error, n_a);
3469 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3472 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3476 # ifdef HAS_GETPAGESIZE
3477 page_size = getpagesize();
3479 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3480 page_size = PAGESIZE; /* compiletime, bad */
3484 if ((IV)page_size <= 0)
3485 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3489 /* This is a hack - should never happen - open should have set it ! */
3490 b->posn = PerlIO_tell(PerlIONext(f));
3492 posn = (b->posn / page_size) * page_size;
3493 len = st.st_size - posn;
3494 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3495 if (m->mptr && m->mptr != (Mmap_t) -1)
3497 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3498 madvise(m->mptr, len, MADV_SEQUENTIAL);
3500 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3501 madvise(m->mptr, len, MADV_WILLNEED);
3503 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3504 b->end = ((STDCHAR *)m->mptr) + len;
3505 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3516 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3518 b->ptr = b->end = b->ptr;
3527 PerlIOMmap_unmap(PerlIO *f)
3529 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3530 PerlIOBuf *b = &m->base;
3536 code = munmap(m->mptr, m->len);
3540 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3543 b->ptr = b->end = b->buf;
3544 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3550 PerlIOMmap_get_base(PerlIO *f)
3552 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3553 PerlIOBuf *b = &m->base;
3554 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3556 /* Already have a readbuffer in progress */
3561 /* We have a write buffer or flushed PerlIOBuf read buffer */
3562 m->bbuf = b->buf; /* save it in case we need it again */
3563 b->buf = NULL; /* Clear to trigger below */
3567 PerlIOMmap_map(f); /* Try and map it */
3570 /* Map did not work - recover PerlIOBuf buffer if we have one */
3574 b->ptr = b->end = b->buf;
3577 return PerlIOBuf_get_base(f);
3581 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3583 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3584 PerlIOBuf *b = &m->base;
3585 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3587 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3590 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3595 /* Loose the unwritable mapped buffer */
3597 /* If flush took the "buffer" see if we have one from before */
3598 if (!b->buf && m->bbuf)
3602 PerlIOBuf_get_base(f);
3606 return PerlIOBuf_unread(f,vbuf,count);
3610 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3612 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3613 PerlIOBuf *b = &m->base;
3614 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3616 /* No, or wrong sort of, buffer */
3619 if (PerlIOMmap_unmap(f) != 0)
3622 /* If unmap took the "buffer" see if we have one from before */
3623 if (!b->buf && m->bbuf)
3627 PerlIOBuf_get_base(f);
3631 return PerlIOBuf_write(f,vbuf,count);
3635 PerlIOMmap_flush(PerlIO *f)
3637 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3638 PerlIOBuf *b = &m->base;
3639 IV code = PerlIOBuf_flush(f);
3640 /* Now we are "synced" at PerlIOBuf level */
3645 /* Unmap the buffer */
3646 if (PerlIOMmap_unmap(f) != 0)
3651 /* We seem to have a PerlIOBuf buffer which was not mapped
3652 * remember it in case we need one later
3661 PerlIOMmap_fill(PerlIO *f)
3663 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3664 IV code = PerlIO_flush(f);
3665 if (code == 0 && !b->buf)
3667 code = PerlIOMmap_map(f);
3669 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3671 code = PerlIOBuf_fill(f);
3677 PerlIOMmap_close(PerlIO *f)
3679 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3680 PerlIOBuf *b = &m->base;
3681 IV code = PerlIO_flush(f);
3686 b->ptr = b->end = b->buf;
3688 if (PerlIOBuf_close(f) != 0)
3694 PerlIO_funcs PerlIO_mmap = {
3713 PerlIOBase_clearerr,
3714 PerlIOBase_setlinebuf,
3715 PerlIOMmap_get_base,
3719 PerlIOBuf_set_ptrcnt,
3722 #endif /* HAS_MMAP */
3729 call_atexit(PerlIO_cleanup_layers, NULL);
3734 atexit(&PerlIO_cleanup);
3746 PerlIO_stdstreams(aTHX);
3751 #undef PerlIO_stdout
3758 PerlIO_stdstreams(aTHX);
3763 #undef PerlIO_stderr
3770 PerlIO_stdstreams(aTHX);
3775 /*--------------------------------------------------------------------------------------*/
3777 #undef PerlIO_getname
3779 PerlIO_getname(PerlIO *f, char *buf)
3784 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3785 if (stdio) name = fgetname(stdio, buf);
3787 Perl_croak(aTHX_ "Don't know how to get file name");
3793 /*--------------------------------------------------------------------------------------*/
3794 /* Functions which can be called on any kind of PerlIO implemented
3800 PerlIO_getc(PerlIO *f)
3803 SSize_t count = PerlIO_read(f,buf,1);
3806 return (unsigned char) buf[0];
3811 #undef PerlIO_ungetc
3813 PerlIO_ungetc(PerlIO *f, int ch)
3818 if (PerlIO_unread(f,&buf,1) == 1)
3826 PerlIO_putc(PerlIO *f, int ch)
3829 return PerlIO_write(f,&buf,1);
3834 PerlIO_puts(PerlIO *f, const char *s)
3836 STRLEN len = strlen(s);
3837 return PerlIO_write(f,s,len);
3840 #undef PerlIO_rewind
3842 PerlIO_rewind(PerlIO *f)
3844 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3848 #undef PerlIO_vprintf
3850 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3853 SV *sv = newSVpvn("",0);
3859 Perl_va_copy(ap, apc);
3860 sv_vcatpvf(sv, fmt, &apc);
3862 sv_vcatpvf(sv, fmt, &ap);
3865 wrote = PerlIO_write(f,s,len);
3870 #undef PerlIO_printf
3872 PerlIO_printf(PerlIO *f,const char *fmt,...)
3877 result = PerlIO_vprintf(f,fmt,ap);
3882 #undef PerlIO_stdoutf
3884 PerlIO_stdoutf(const char *fmt,...)
3889 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3894 #undef PerlIO_tmpfile
3896 PerlIO_tmpfile(void)
3898 /* I have no idea how portable mkstemp() is ... */
3899 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3902 FILE *stdio = PerlSIO_tmpfile();
3905 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3911 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3912 int fd = mkstemp(SvPVX(sv));
3916 f = PerlIO_fdopen(fd,"w+");
3919 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3921 PerlLIO_unlink(SvPVX(sv));
3931 #endif /* USE_SFIO */
3932 #endif /* PERLIO_IS_STDIO */
3934 /*======================================================================================*/
3935 /* Now some functions in terms of above which may be needed even if
3936 we are not in true PerlIO mode
3940 #undef PerlIO_setpos
3942 PerlIO_setpos(PerlIO *f, SV *pos)
3948 Off_t *posn = (Off_t *) SvPV(pos,len);
3949 if (f && len == sizeof(Off_t))
3950 return PerlIO_seek(f,*posn,SEEK_SET);
3952 SETERRNO(EINVAL,SS$_IVCHAN);
3956 #undef PerlIO_setpos
3958 PerlIO_setpos(PerlIO *f, SV *pos)
3964 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3965 if (f && len == sizeof(Fpos_t))
3967 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3968 return fsetpos64(f, fpos);
3970 return fsetpos(f, fpos);
3974 SETERRNO(EINVAL,SS$_IVCHAN);
3980 #undef PerlIO_getpos
3982 PerlIO_getpos(PerlIO *f, SV *pos)
3985 Off_t posn = PerlIO_tell(f);
3986 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3987 return (posn == (Off_t)-1) ? -1 : 0;
3990 #undef PerlIO_getpos
3992 PerlIO_getpos(PerlIO *f, SV *pos)
3997 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3998 code = fgetpos64(f, &fpos);
4000 code = fgetpos(f, &fpos);
4002 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4007 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4010 vprintf(char *pat, char *args)
4012 _doprnt(pat, args, stdout);
4013 return 0; /* wrong, but perl doesn't use the return value */
4017 vfprintf(FILE *fd, char *pat, char *args)
4019 _doprnt(pat, args, fd);
4020 return 0; /* wrong, but perl doesn't use the return value */
4025 #ifndef PerlIO_vsprintf
4027 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4029 int val = vsprintf(s, fmt, ap);
4032 if (strlen(s) >= (STRLEN)n)
4035 (void)PerlIO_puts(Perl_error_log,
4036 "panic: sprintf overflow - memory corrupted!\n");
4044 #ifndef PerlIO_sprintf
4046 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4051 result = PerlIO_vsprintf(s, n, fmt, ap);