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;
66 if (PerlLIO_setmode(fp, mode) != -1) {
68 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
70 # if defined(WIN32) && defined(__BORLANDC__)
71 /* The translation mode of the stream is maintained independent
72 * of the translation mode of the fd in the Borland RTL (heavy
73 * digging through their runtime sources reveal). User has to
74 * set the mode explicitly for the stream (though they don't
75 * document this anywhere). GSAR 97-5-24
81 fp->flags &= ~ _F_BIN;
89 # if defined(USEMYBINMODE)
90 if (my_binmode(fp, iotype, mode) != FALSE)
100 #ifndef PERLIO_LAYERS
102 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
104 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
108 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
114 PerlIO_destruct(pTHX)
119 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
124 return perlsio_binmode(fp,iotype,mode);
128 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
131 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
135 if (*args == &PL_sv_undef)
136 return PerlIO_tmpfile();
139 char *name = SvPV_nolen(*args);
142 fd = PerlLIO_open3(name,imode,perm);
144 return PerlIO_fdopen(fd,(char *)mode+1);
148 return PerlIO_reopen(name,mode,old);
152 return PerlIO_open(name,mode);
158 return PerlIO_fdopen(fd,(char *)mode);
163 XS(XS_PerlIO__Layer__find)
167 Perl_croak(aTHX_ "Usage class->find(name[,load])");
170 char *name = SvPV_nolen(ST(1));
171 ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
178 Perl_boot_core_PerlIO(pTHX)
180 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
186 #ifdef PERLIO_IS_STDIO
191 /* Does nothing (yet) except force this file to be included
192 in perl binary. That allows this file to force inclusion
193 of other functions that may be required by loadable
194 extensions e.g. for FileHandle::tmpfile
198 #undef PerlIO_tmpfile
205 #else /* PERLIO_IS_STDIO */
212 /* This section is just to make sure these functions
213 get pulled in from libsfio.a
216 #undef PerlIO_tmpfile
226 /* Force this file to be included in perl binary. Which allows
227 * this file to force inclusion of other functions that may be
228 * required by loadable extensions e.g. for FileHandle::tmpfile
232 * sfio does its own 'autoflush' on stdout in common cases.
233 * Flush results in a lot of lseek()s to regular files and
234 * lot of small writes to pipes.
236 sfset(sfstdout,SF_SHARE,0);
240 PerlIO_importFILE(FILE *stdio, int fl)
242 int fd = fileno(stdio);
243 PerlIO *r = PerlIO_fdopen(fd,"r+");
248 PerlIO_findFILE(PerlIO *pio)
250 int fd = PerlIO_fileno(pio);
251 FILE *f = fdopen(fd,"r+");
253 if (!f && errno == EINVAL)
255 if (!f && errno == EINVAL)
262 /*======================================================================================*/
263 /* Implement all the PerlIO interface ourselves.
268 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
273 #include <sys/mman.h>
277 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
280 PerlIO_debug(const char *fmt,...)
288 char *s = PerlEnv_getenv("PERLIO_DEBUG");
290 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
297 SV *sv = newSVpvn("",0);
300 s = CopFILE(PL_curcop);
303 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
304 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
307 PerlLIO_write(dbg,s,len);
313 /*--------------------------------------------------------------------------------------*/
315 /* Inner level routines */
317 /* Table of pointers to the PerlIO structs (malloc'ed) */
318 PerlIO *_perlio = NULL;
319 #define PERLIO_TABLE_SIZE 64
324 PerlIO_allocate(pTHX)
326 /* Find a free slot in the table, allocating new table as necessary */
333 last = (PerlIO **)(f);
334 for (i=1; i < PERLIO_TABLE_SIZE; i++)
342 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
352 PerlIO_cleantable(pTHX_ PerlIO **tablep)
354 PerlIO *table = *tablep;
358 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
359 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
367 PerlMemShared_free(table);
372 PerlIO_list_t *PerlIO_known_layers;
373 PerlIO_list_t *PerlIO_def_layerlist;
376 PerlIO_list_alloc(void)
379 Newz('L',list,1,PerlIO_list_t);
385 PerlIO_list_free(PerlIO_list_t *list)
389 if (--list->refcnt == 0)
395 for (i=0; i < list->cur; i++)
397 if (list->array[i].arg)
398 SvREFCNT_dec(list->array[i].arg);
400 Safefree(list->array);
408 PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
412 if (list->cur >= list->len)
416 Renew(list->array,list->len,PerlIO_pair_t);
418 New('l',list->array,list->len,PerlIO_pair_t);
420 p = &(list->array[list->cur++]);
422 if ((p->arg = arg)) {
429 PerlIO_cleanup_layers(pTHXo_ void *data)
432 PerlIO_known_layers = Nullhv;
433 PerlIO_def_layerlist = Nullav;
441 PerlIO_cleantable(aTHX_ &_perlio);
445 PerlIO_destruct(pTHX)
447 PerlIO **table = &_perlio;
452 table = (PerlIO **)(f++);
453 for (i=1; i < PERLIO_TABLE_SIZE; i++)
459 if (l->tab->kind & PERLIO_K_DESTRUCT)
461 PerlIO_debug("Destruct popping %s\n",l->tab->name);
476 PerlIO_pop(pTHX_ PerlIO *f)
481 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
484 /* If popped returns non-zero do not free its layer structure
485 it has either done so itself, or it is shared and still in use
487 if ((*l->tab->Popped)(f) != 0)
491 PerlMemShared_free(l);
495 /*--------------------------------------------------------------------------------------*/
496 /* XS Interface for perl code */
499 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
502 if ((SSize_t) len <= 0)
504 for (i=0; i < PerlIO_known_layers->cur; i++)
506 PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
507 if (strEQ(f->name,name))
509 PerlIO_debug("%.*s => %p\n",(int)len,name,f);
513 if (load && PL_subname && PerlIO_def_layerlist && PerlIO_def_layerlist->cur >= 2)
515 SV *pkgsv = newSVpvn("PerlIO",6);
516 SV *layer = newSVpvn(name,len);
518 /* The two SVs are magically freed by load_module */
519 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
521 return PerlIO_find_layer(aTHX_ name,len,0);
523 PerlIO_debug("Cannot find %.*s\n",(int)len,name);
527 #ifdef USE_ATTRIBUTES_FOR_PERLIO
530 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
534 IO *io = GvIOn((GV *)SvRV(sv));
535 PerlIO *ifp = IoIFP(io);
536 PerlIO *ofp = IoOFP(io);
537 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
543 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
547 IO *io = GvIOn((GV *)SvRV(sv));
548 PerlIO *ifp = IoIFP(io);
549 PerlIO *ofp = IoOFP(io);
550 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
556 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
558 Perl_warn(aTHX_ "clear %"SVf,sv);
563 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
565 Perl_warn(aTHX_ "free %"SVf,sv);
569 MGVTBL perlio_vtab = {
577 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
580 SV *sv = SvRV(ST(1));
585 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
587 mg = mg_find(sv, PERL_MAGIC_ext);
588 mg->mg_virtual = &perlio_vtab;
590 Perl_warn(aTHX_ "attrib %"SVf,sv);
591 for (i=2; i < items; i++)
594 const char *name = SvPV(ST(i),len);
595 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
598 av_push(av,SvREFCNT_inc(layer));
610 #endif /* USE_ATTIBUTES_FOR_PERLIO */
613 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
615 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
616 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
620 XS(XS_PerlIO__Layer__find)
624 Perl_croak(aTHX_ "Usage class->find(name[,load])");
628 char *name = SvPV(ST(1),len);
629 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
630 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
631 ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
637 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
639 if (!PerlIO_known_layers)
640 PerlIO_known_layers = PerlIO_list_alloc();
641 PerlIO_list_push(PerlIO_known_layers,tab,Nullsv);
642 PerlIO_debug("define %s %p\n",tab->name,tab);
646 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
650 const char *s = names;
653 while (isSPACE(*s) || *s == ':')
659 const char *as = Nullch;
663 /* Message is consistent with how attribute lists are passed.
664 Even though this means "foo : : bar" is seen as an invalid separator
666 char q = ((*s == '\'') ? '"' : '\'');
667 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
673 } while (isALNUM(*e));
691 /* It's a nul terminated string, not allowed to \ the terminating null.
692 Anything other character is passed over. */
700 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
710 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s,llen,1);
713 PerlIO_list_push(av, layer, (as) ? newSVpvn(as,alen) : &PL_sv_undef);
716 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
728 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
730 PerlIO_funcs *tab = &PerlIO_perlio;
731 if (O_BINARY != O_TEXT)
737 if (PerlIO_stdio.Set_ptrcnt)
742 PerlIO_debug("Pushing %s\n",tab->name);
743 PerlIO_list_push(av,PerlIO_find_layer(aTHX_ tab->name,0,0),&PL_sv_undef);
747 PerlIO_arg_fetch(PerlIO_list_t *av,IV n)
749 return av->array[n].arg;
753 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
755 if (n >= 0 && n < av->cur)
757 PerlIO_debug("Layer %"IVdf" is %s\n",n,av->array[n].funcs->name);
758 return av->array[n].funcs;
761 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
766 PerlIO_default_layers(pTHX)
768 if (!PerlIO_def_layerlist)
770 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
771 PerlIO_funcs *osLayer = &PerlIO_unix;
772 PerlIO_def_layerlist = PerlIO_list_alloc();
773 PerlIO_define_layer(aTHX_ &PerlIO_unix);
775 PerlIO_define_layer(aTHX_ &PerlIO_win32);
777 osLayer = &PerlIO_win32;
780 PerlIO_define_layer(aTHX_ &PerlIO_raw);
781 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
782 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
783 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
785 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
787 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
788 PerlIO_define_layer(aTHX_ &PerlIO_byte);
789 PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ osLayer->name,0,0),&PL_sv_undef);
792 PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
796 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
799 if (PerlIO_def_layerlist->cur < 2)
801 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
803 return PerlIO_def_layerlist;
807 Perl_boot_core_PerlIO(pTHX)
809 #ifdef USE_ATTRIBUTES_FOR_PERLIO
810 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
812 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
816 PerlIO_default_layer(pTHX_ I32 n)
818 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
821 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
824 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
825 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
828 PerlIO_stdstreams(pTHX)
832 PerlIO_allocate(aTHX);
833 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
834 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
835 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
840 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
843 l = PerlMemShared_calloc(tab->size,sizeof(char));
846 Zero(l,tab->size,char);
850 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
851 (mode) ? mode : "(Null)",arg);
852 if ((*l->tab->Pushed)(f,mode,arg) != 0)
862 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
876 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
878 /* Remove the dummy layer */
881 /* Pop back to bottom layer */
885 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
893 /* Nothing bellow - push unix on top then remove it */
894 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
896 PerlIO_pop(aTHX_ PerlIONext(f));
901 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
908 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
910 IV max = layers->cur;
914 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
917 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
929 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
934 PerlIO_list_t *layers = PerlIO_list_alloc();
935 code = PerlIO_parse_layers(aTHX_ layers,names);
938 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
940 PerlIO_list_free(layers);
946 /*--------------------------------------------------------------------------------------*/
947 /* Given the abstraction above the public API functions */
950 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
952 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
953 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
954 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
960 if (PerlIOBase(top)->tab == &PerlIO_crlf)
963 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
966 top = PerlIONext(top);
969 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
974 PerlIO__close(PerlIO *f)
977 return (*PerlIOBase(f)->tab->Close)(f);
980 SETERRNO(EBADF,SS$_IVCHAN);
985 #undef PerlIO_fdupopen
987 PerlIO_fdupopen(pTHX_ PerlIO *f)
992 int fd = PerlLIO_dup(PerlIO_fileno(f));
993 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
996 Off_t posn = PerlIO_tell(f);
997 PerlIO_seek(new,posn,SEEK_SET);
1003 SETERRNO(EBADF,SS$_IVCHAN);
1010 PerlIO_close(PerlIO *f)
1016 code = (*PerlIOBase(f)->tab->Close)(f);
1019 PerlIO_pop(aTHX_ f);
1025 #undef PerlIO_fileno
1027 PerlIO_fileno(PerlIO *f)
1030 return (*PerlIOBase(f)->tab->Fileno)(f);
1033 SETERRNO(EBADF,SS$_IVCHAN);
1039 PerlIO_context_layers(pTHX_ const char *mode)
1041 const char *type = NULL;
1042 /* Need to supply default layer info from open.pm */
1045 SV *layers = PL_curcop->cop_io;
1049 type = SvPV(layers,len);
1050 if (type && mode[0] != 'r')
1052 /* Skip to write part */
1053 const char *s = strchr(type,0);
1054 if (s && (s-type) < len)
1064 static PerlIO_funcs *
1065 PerlIO_layer_from_ref(pTHX_ SV *sv)
1067 /* For any scalar type load the handler which is bundled with perl */
1068 if (SvTYPE(sv) < SVt_PVAV)
1069 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1071 /* For other types allow if layer is known but don't try and load it */
1075 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1077 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1079 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1081 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1087 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1089 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1092 PerlIO_stdstreams(aTHX);
1096 /* If it is a reference but not an object see if we have a handler for it */
1097 if (SvROK(arg) && !sv_isobject(arg))
1099 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1102 def = PerlIO_list_alloc();
1103 PerlIO_list_push(def,handler,&PL_sv_undef);
1106 /* Don't fail if handler cannot be found
1107 * :Via(...) etc. may do something sensible
1108 * else we will just stringfy and open resulting string.
1113 layers = PerlIO_context_layers(aTHX_ mode);
1114 if (layers && *layers)
1120 av = PerlIO_list_alloc();
1121 for (i=0; i < def->cur; i++)
1123 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1130 PerlIO_parse_layers(aTHX_ av,layers);
1142 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1144 if (!f && narg == 1 && *args == &PL_sv_undef)
1146 if ((f = PerlIO_tmpfile()))
1149 layers = PerlIO_context_layers(aTHX_ mode);
1150 if (layers && *layers)
1151 PerlIO_apply_layers(aTHX_ f,mode,layers);
1156 PerlIO_list_t *layera = NULL;
1158 PerlIO_funcs *tab = NULL;
1161 /* This is "reopen" - it is not tested as perl does not use it yet */
1163 layera = PerlIO_list_alloc();
1166 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1167 PerlIO_list_push(layera,l->tab,arg);
1168 l = *PerlIONext(&l);
1173 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1175 /* Start at "top" of layer stack */
1179 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1189 /* Found that layer 'n' can do opens - call it */
1190 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1191 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1192 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1195 if (n+1 < layera->cur)
1197 /* More layers above the one that we used to open - apply them now */
1198 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1205 PerlIO_list_free(layera);
1211 #undef PerlIO_fdopen
1213 PerlIO_fdopen(int fd, const char *mode)
1216 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1221 PerlIO_open(const char *path, const char *mode)
1224 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1225 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1228 #undef PerlIO_reopen
1230 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1233 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1234 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1239 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1242 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1245 SETERRNO(EBADF,SS$_IVCHAN);
1250 #undef PerlIO_unread
1252 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1255 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1258 SETERRNO(EBADF,SS$_IVCHAN);
1265 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1268 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1271 SETERRNO(EBADF,SS$_IVCHAN);
1278 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1281 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1284 SETERRNO(EBADF,SS$_IVCHAN);
1291 PerlIO_tell(PerlIO *f)
1294 return (*PerlIOBase(f)->tab->Tell)(f);
1297 SETERRNO(EBADF,SS$_IVCHAN);
1304 PerlIO_flush(PerlIO *f)
1310 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1311 if (tab && tab->Flush)
1313 return (*tab->Flush)(f);
1317 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1318 SETERRNO(EBADF,SS$_IVCHAN);
1324 PerlIO_debug("Cannot flush f=%p\n",f);
1325 SETERRNO(EBADF,SS$_IVCHAN);
1331 /* Is it good API design to do flush-all on NULL,
1332 * a potentially errorneous input? Maybe some magical
1333 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1334 * Yes, stdio does similar things on fflush(NULL),
1335 * but should we be bound by their design decisions?
1337 PerlIO **table = &_perlio;
1339 while ((f = *table))
1342 table = (PerlIO **)(f++);
1343 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1345 if (*f && PerlIO_flush(f) != 0)
1355 PerlIOBase_flush_linebuf()
1357 PerlIO **table = &_perlio;
1359 while ((f = *table))
1362 table = (PerlIO **)(f++);
1363 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1365 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1366 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1375 PerlIO_fill(PerlIO *f)
1378 return (*PerlIOBase(f)->tab->Fill)(f);
1381 SETERRNO(EBADF,SS$_IVCHAN);
1386 #undef PerlIO_isutf8
1388 PerlIO_isutf8(PerlIO *f)
1391 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1394 SETERRNO(EBADF,SS$_IVCHAN);
1401 PerlIO_eof(PerlIO *f)
1404 return (*PerlIOBase(f)->tab->Eof)(f);
1407 SETERRNO(EBADF,SS$_IVCHAN);
1414 PerlIO_error(PerlIO *f)
1417 return (*PerlIOBase(f)->tab->Error)(f);
1420 SETERRNO(EBADF,SS$_IVCHAN);
1425 #undef PerlIO_clearerr
1427 PerlIO_clearerr(PerlIO *f)
1430 (*PerlIOBase(f)->tab->Clearerr)(f);
1432 SETERRNO(EBADF,SS$_IVCHAN);
1435 #undef PerlIO_setlinebuf
1437 PerlIO_setlinebuf(PerlIO *f)
1440 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1442 SETERRNO(EBADF,SS$_IVCHAN);
1445 #undef PerlIO_has_base
1447 PerlIO_has_base(PerlIO *f)
1449 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1453 #undef PerlIO_fast_gets
1455 PerlIO_fast_gets(PerlIO *f)
1457 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1459 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1460 return (tab->Set_ptrcnt != NULL);
1465 #undef PerlIO_has_cntptr
1467 PerlIO_has_cntptr(PerlIO *f)
1471 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1472 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1477 #undef PerlIO_canset_cnt
1479 PerlIO_canset_cnt(PerlIO *f)
1483 PerlIOl *l = PerlIOBase(f);
1484 return (l->tab->Set_ptrcnt != NULL);
1489 #undef PerlIO_get_base
1491 PerlIO_get_base(PerlIO *f)
1494 return (*PerlIOBase(f)->tab->Get_base)(f);
1498 #undef PerlIO_get_bufsiz
1500 PerlIO_get_bufsiz(PerlIO *f)
1503 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1507 #undef PerlIO_get_ptr
1509 PerlIO_get_ptr(PerlIO *f)
1511 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1512 if (tab->Get_ptr == NULL)
1514 return (*tab->Get_ptr)(f);
1517 #undef PerlIO_get_cnt
1519 PerlIO_get_cnt(PerlIO *f)
1521 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1522 if (tab->Get_cnt == NULL)
1524 return (*tab->Get_cnt)(f);
1527 #undef PerlIO_set_cnt
1529 PerlIO_set_cnt(PerlIO *f,int cnt)
1531 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1534 #undef PerlIO_set_ptrcnt
1536 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1538 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1539 if (tab->Set_ptrcnt == NULL)
1542 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1544 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1547 /*--------------------------------------------------------------------------------------*/
1548 /* utf8 and raw dummy layers */
1551 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1556 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1557 PerlIO_pop(aTHX_ f);
1558 if (tab->kind & PERLIO_K_UTF8)
1559 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1561 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1567 PerlIO_funcs PerlIO_utf8 = {
1570 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1588 NULL, /* get_base */
1589 NULL, /* get_bufsiz */
1592 NULL, /* set_ptrcnt */
1595 PerlIO_funcs PerlIO_byte = {
1616 NULL, /* get_base */
1617 NULL, /* get_bufsiz */
1620 NULL, /* set_ptrcnt */
1624 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)
1626 PerlIO_funcs *tab = PerlIO_default_btm();
1627 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1630 PerlIO_funcs PerlIO_raw = {
1651 NULL, /* get_base */
1652 NULL, /* get_bufsiz */
1655 NULL, /* set_ptrcnt */
1657 /*--------------------------------------------------------------------------------------*/
1658 /*--------------------------------------------------------------------------------------*/
1659 /* "Methods" of the "base class" */
1662 PerlIOBase_fileno(PerlIO *f)
1664 return PerlIO_fileno(PerlIONext(f));
1668 PerlIO_modestr(PerlIO *f,char *buf)
1671 IV flags = PerlIOBase(f)->flags;
1672 if (flags & PERLIO_F_APPEND)
1675 if (flags & PERLIO_F_CANREAD)
1680 else if (flags & PERLIO_F_CANREAD)
1683 if (flags & PERLIO_F_CANWRITE)
1686 else if (flags & PERLIO_F_CANWRITE)
1689 if (flags & PERLIO_F_CANREAD)
1694 #if O_TEXT != O_BINARY
1695 if (!(flags & PERLIO_F_CRLF))
1703 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1705 PerlIOl *l = PerlIOBase(f);
1707 const char *omode = mode;
1710 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1711 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1712 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1713 if (tab->Set_ptrcnt != NULL)
1714 l->flags |= PERLIO_F_FASTGETS;
1717 if (*mode == '#' || *mode == 'I')
1722 l->flags |= PERLIO_F_CANREAD;
1725 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1728 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1731 SETERRNO(EINVAL,LIB$_INVARG);
1739 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1742 l->flags &= ~PERLIO_F_CRLF;
1745 l->flags |= PERLIO_F_CRLF;
1748 SETERRNO(EINVAL,LIB$_INVARG);
1757 l->flags |= l->next->flags &
1758 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1762 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1763 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1764 l->flags,PerlIO_modestr(f,temp));
1770 PerlIOBase_popped(PerlIO *f)
1776 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1779 /* Save the position as current head considers it */
1780 Off_t old = PerlIO_tell(f);
1782 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1783 PerlIOSelf(f,PerlIOBuf)->posn = old;
1784 done = PerlIOBuf_unread(f,vbuf,count);
1789 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1791 STDCHAR *buf = (STDCHAR *) vbuf;
1794 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1798 SSize_t avail = PerlIO_get_cnt(f);
1801 take = (count < avail) ? count : avail;
1804 STDCHAR *ptr = PerlIO_get_ptr(f);
1805 Copy(ptr,buf,take,STDCHAR);
1806 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1810 if (count > 0 && avail <= 0)
1812 if (PerlIO_fill(f) != 0)
1816 return (buf - (STDCHAR *) vbuf);
1822 PerlIOBase_noop_ok(PerlIO *f)
1828 PerlIOBase_noop_fail(PerlIO *f)
1834 PerlIOBase_close(PerlIO *f)
1837 PerlIO *n = PerlIONext(f);
1838 if (PerlIO_flush(f) != 0)
1840 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1842 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1847 PerlIOBase_eof(PerlIO *f)
1851 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1857 PerlIOBase_error(PerlIO *f)
1861 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1867 PerlIOBase_clearerr(PerlIO *f)
1871 PerlIO *n = PerlIONext(f);
1872 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1879 PerlIOBase_setlinebuf(PerlIO *f)
1883 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1887 /*--------------------------------------------------------------------------------------*/
1888 /* Bottom-most level for UNIX-like case */
1892 struct _PerlIO base; /* The generic part */
1893 int fd; /* UNIX like file descriptor */
1894 int oflags; /* open/fcntl flags */
1898 PerlIOUnix_oflags(const char *mode)
1901 if (*mode == 'I' || *mode == '#')
1915 oflags = O_CREAT|O_TRUNC;
1926 oflags = O_CREAT|O_APPEND;
1942 else if (*mode == 't')
1945 oflags &= ~O_BINARY;
1948 /* Always open in binary mode */
1950 if (*mode || oflags == -1)
1952 SETERRNO(EINVAL,LIB$_INVARG);
1959 PerlIOUnix_fileno(PerlIO *f)
1961 return PerlIOSelf(f,PerlIOUnix)->fd;
1965 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1967 IV code = PerlIOBase_pushed(f,mode,arg);
1970 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1971 s->fd = PerlIO_fileno(PerlIONext(f));
1972 s->oflags = PerlIOUnix_oflags(mode);
1974 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1979 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)
1983 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1984 (*PerlIOBase(f)->tab->Close)(f);
1988 char *path = SvPV_nolen(*args);
1993 imode = PerlIOUnix_oflags(mode);
1998 fd = PerlLIO_open3(path,imode,perm);
2008 f = PerlIO_allocate(aTHX);
2009 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2012 s = PerlIOSelf(f,PerlIOUnix);
2015 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2022 /* FIXME: pop layers ??? */
2029 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2032 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2033 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2037 SSize_t len = PerlLIO_read(fd,vbuf,count);
2038 if (len >= 0 || errno != EINTR)
2041 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2042 else if (len == 0 && count != 0)
2043 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2051 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2054 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2057 SSize_t len = PerlLIO_write(fd,vbuf,count);
2058 if (len >= 0 || errno != EINTR)
2061 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2069 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2072 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2073 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2074 return (new == (Off_t) -1) ? -1 : 0;
2078 PerlIOUnix_tell(PerlIO *f)
2081 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2085 PerlIOUnix_close(PerlIO *f)
2088 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2090 while (PerlLIO_close(fd) != 0)
2101 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2106 PerlIO_funcs PerlIO_unix = {
2121 PerlIOBase_noop_ok, /* flush */
2122 PerlIOBase_noop_fail, /* fill */
2125 PerlIOBase_clearerr,
2126 PerlIOBase_setlinebuf,
2127 NULL, /* get_base */
2128 NULL, /* get_bufsiz */
2131 NULL, /* set_ptrcnt */
2134 /*--------------------------------------------------------------------------------------*/
2135 /* stdio as a layer */
2139 struct _PerlIO base;
2140 FILE * stdio; /* The stream */
2144 PerlIOStdio_fileno(PerlIO *f)
2147 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2151 PerlIOStdio_mode(const char *mode,char *tmode)
2158 if (O_BINARY != O_TEXT)
2166 /* This isn't used yet ... */
2168 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2173 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2175 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2181 return PerlIOBase_pushed(f,mode,arg);
2184 #undef PerlIO_importFILE
2186 PerlIO_importFILE(FILE *stdio, int fl)
2192 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2199 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)
2204 char *path = SvPV_nolen(*args);
2205 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2206 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2216 char *path = SvPV_nolen(*args);
2220 fd = PerlLIO_open3(path,imode,perm);
2224 FILE *stdio = PerlSIO_fopen(path,mode);
2227 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2228 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2249 stdio = PerlSIO_stdin;
2252 stdio = PerlSIO_stdout;
2255 stdio = PerlSIO_stderr;
2261 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2265 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2275 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2278 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2282 STDCHAR *buf = (STDCHAR *) vbuf;
2283 /* Perl is expecting PerlIO_getc() to fill the buffer
2284 * Linux's stdio does not do that for fread()
2286 int ch = PerlSIO_fgetc(s);
2294 got = PerlSIO_fread(vbuf,1,count,s);
2299 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2302 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2303 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2307 int ch = *buf-- & 0xff;
2308 if (PerlSIO_ungetc(ch,s) != ch)
2317 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2320 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2324 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2327 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2328 return PerlSIO_fseek(stdio,offset,whence);
2332 PerlIOStdio_tell(PerlIO *f)
2335 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2336 return PerlSIO_ftell(stdio);
2340 PerlIOStdio_close(PerlIO *f)
2343 #ifdef SOCKS5_VERSION_NAME
2345 Sock_size_t optlen = sizeof(int);
2347 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2349 #ifdef SOCKS5_VERSION_NAME
2350 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2351 PerlSIO_fclose(stdio) :
2352 close(PerlIO_fileno(f))
2354 PerlSIO_fclose(stdio)
2361 PerlIOStdio_flush(PerlIO *f)
2364 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2365 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2367 return PerlSIO_fflush(stdio);
2372 /* FIXME: This discards ungetc() and pre-read stuff which is
2373 not right if this is just a "sync" from a layer above
2374 Suspect right design is to do _this_ but not have layer above
2375 flush this layer read-to-read
2377 /* Not writeable - sync by attempting a seek */
2379 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2387 PerlIOStdio_fill(PerlIO *f)
2390 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2392 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2393 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2395 if (PerlSIO_fflush(stdio) != 0)
2398 c = PerlSIO_fgetc(stdio);
2399 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2405 PerlIOStdio_eof(PerlIO *f)
2408 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2412 PerlIOStdio_error(PerlIO *f)
2415 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2419 PerlIOStdio_clearerr(PerlIO *f)
2422 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2426 PerlIOStdio_setlinebuf(PerlIO *f)
2429 #ifdef HAS_SETLINEBUF
2430 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2432 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2438 PerlIOStdio_get_base(PerlIO *f)
2441 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2442 return PerlSIO_get_base(stdio);
2446 PerlIOStdio_get_bufsiz(PerlIO *f)
2449 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2450 return PerlSIO_get_bufsiz(stdio);
2454 #ifdef USE_STDIO_PTR
2456 PerlIOStdio_get_ptr(PerlIO *f)
2459 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2460 return PerlSIO_get_ptr(stdio);
2464 PerlIOStdio_get_cnt(PerlIO *f)
2467 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2468 return PerlSIO_get_cnt(stdio);
2472 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2474 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2478 #ifdef STDIO_PTR_LVALUE
2479 PerlSIO_set_ptr(stdio,ptr);
2480 #ifdef STDIO_PTR_LVAL_SETS_CNT
2481 if (PerlSIO_get_cnt(stdio) != (cnt))
2484 assert(PerlSIO_get_cnt(stdio) == (cnt));
2487 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2488 /* Setting ptr _does_ change cnt - we are done */
2491 #else /* STDIO_PTR_LVALUE */
2493 #endif /* STDIO_PTR_LVALUE */
2495 /* Now (or only) set cnt */
2496 #ifdef STDIO_CNT_LVALUE
2497 PerlSIO_set_cnt(stdio,cnt);
2498 #else /* STDIO_CNT_LVALUE */
2499 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2500 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2501 #else /* STDIO_PTR_LVAL_SETS_CNT */
2503 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2504 #endif /* STDIO_CNT_LVALUE */
2509 PerlIO_funcs PerlIO_stdio = {
2511 sizeof(PerlIOStdio),
2528 PerlIOStdio_clearerr,
2529 PerlIOStdio_setlinebuf,
2531 PerlIOStdio_get_base,
2532 PerlIOStdio_get_bufsiz,
2537 #ifdef USE_STDIO_PTR
2538 PerlIOStdio_get_ptr,
2539 PerlIOStdio_get_cnt,
2540 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2541 PerlIOStdio_set_ptrcnt
2542 #else /* STDIO_PTR_LVALUE */
2544 #endif /* STDIO_PTR_LVALUE */
2545 #else /* USE_STDIO_PTR */
2549 #endif /* USE_STDIO_PTR */
2552 #undef PerlIO_exportFILE
2554 PerlIO_exportFILE(PerlIO *f, int fl)
2558 stdio = fdopen(PerlIO_fileno(f),"r+");
2562 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2568 #undef PerlIO_findFILE
2570 PerlIO_findFILE(PerlIO *f)
2575 if (l->tab == &PerlIO_stdio)
2577 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2580 l = *PerlIONext(&l);
2582 return PerlIO_exportFILE(f,0);
2585 #undef PerlIO_releaseFILE
2587 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2591 /*--------------------------------------------------------------------------------------*/
2592 /* perlio buffer layer */
2595 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2598 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2599 int fd = PerlIO_fileno(f);
2601 if (fd >= 0 && PerlLIO_isatty(fd))
2603 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2605 posn = PerlIO_tell(PerlIONext(f));
2606 if (posn != (Off_t) -1)
2610 return PerlIOBase_pushed(f,mode,arg);
2614 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)
2618 PerlIO *next = PerlIONext(f);
2619 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2620 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2621 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2628 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2635 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2638 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2639 fd = PerlIO_fileno(f);
2640 #if O_BINARY != O_TEXT
2641 /* do something about failing setmode()? --jhi */
2642 PerlLIO_setmode(fd , O_BINARY);
2644 if (init && fd == 2)
2646 /* Initial stderr is unbuffered */
2647 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2654 /* This "flush" is akin to sfio's sync in that it handles files in either
2658 PerlIOBuf_flush(PerlIO *f)
2660 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2662 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2664 /* write() the buffer */
2665 STDCHAR *buf = b->buf;
2667 PerlIO *n = PerlIONext(f);
2670 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2675 else if (count < 0 || PerlIO_error(n))
2677 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2682 b->posn += (p - buf);
2684 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2686 STDCHAR *buf = PerlIO_get_base(f);
2687 /* Note position change */
2688 b->posn += (b->ptr - buf);
2689 if (b->ptr < b->end)
2691 /* We did not consume all of it */
2692 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2694 b->posn = PerlIO_tell(PerlIONext(f));
2698 b->ptr = b->end = b->buf;
2699 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2700 /* FIXME: Is this right for read case ? */
2701 if (PerlIO_flush(PerlIONext(f)) != 0)
2707 PerlIOBuf_fill(PerlIO *f)
2709 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2710 PerlIO *n = PerlIONext(f);
2712 /* FIXME: doing the down-stream flush is a bad idea if it causes
2713 pre-read data in stdio buffer to be discarded
2714 but this is too simplistic - as it skips _our_ hosekeeping
2715 and breaks tell tests.
2716 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2720 if (PerlIO_flush(f) != 0)
2722 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2723 PerlIOBase_flush_linebuf();
2726 PerlIO_get_base(f); /* allocate via vtable */
2728 b->ptr = b->end = b->buf;
2729 if (PerlIO_fast_gets(n))
2731 /* Layer below is also buffered
2732 * We do _NOT_ want to call its ->Read() because that will loop
2733 * till it gets what we asked for which may hang on a pipe etc.
2734 * Instead take anything it has to hand, or ask it to fill _once_.
2736 avail = PerlIO_get_cnt(n);
2739 avail = PerlIO_fill(n);
2741 avail = PerlIO_get_cnt(n);
2744 if (!PerlIO_error(n) && PerlIO_eof(n))
2750 STDCHAR *ptr = PerlIO_get_ptr(n);
2751 SSize_t cnt = avail;
2752 if (avail > b->bufsiz)
2754 Copy(ptr,b->buf,avail,STDCHAR);
2755 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2760 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2765 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2767 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2770 b->end = b->buf+avail;
2771 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2776 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2778 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2783 return PerlIOBase_read(f,vbuf,count);
2789 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2791 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2792 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2795 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2801 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2803 /* Buffer is already a read buffer, we can overwrite any chars
2804 which have been read back to buffer start
2806 avail = (b->ptr - b->buf);
2810 /* Buffer is idle, set it up so whole buffer is available for unread */
2812 b->end = b->buf + avail;
2814 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2815 /* Buffer extends _back_ from where we are now */
2816 b->posn -= b->bufsiz;
2818 if (avail > (SSize_t) count)
2820 /* If we have space for more than count, just move count */
2827 /* In simple stdio-like ungetc() case chars will be already there */
2830 Copy(buf,b->ptr,avail,STDCHAR);
2834 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2841 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2843 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2844 const STDCHAR *buf = (const STDCHAR *) vbuf;
2848 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2852 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2853 if ((SSize_t) count < avail)
2855 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2856 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2876 Copy(buf,b->ptr,avail,STDCHAR);
2883 if (b->ptr >= (b->buf + b->bufsiz))
2886 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2892 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2895 if ((code = PerlIO_flush(f)) == 0)
2897 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2898 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2899 code = PerlIO_seek(PerlIONext(f),offset,whence);
2902 b->posn = PerlIO_tell(PerlIONext(f));
2909 PerlIOBuf_tell(PerlIO *f)
2911 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2912 /* b->posn is file position where b->buf was read, or will be written */
2913 Off_t posn = b->posn;
2916 /* If buffer is valid adjust position by amount in buffer */
2917 posn += (b->ptr - b->buf);
2923 PerlIOBuf_close(PerlIO *f)
2925 IV code = PerlIOBase_close(f);
2926 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2927 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2929 PerlMemShared_free(b->buf);
2932 b->ptr = b->end = b->buf;
2933 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2938 PerlIOBuf_get_ptr(PerlIO *f)
2940 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2947 PerlIOBuf_get_cnt(PerlIO *f)
2949 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2952 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2953 return (b->end - b->ptr);
2958 PerlIOBuf_get_base(PerlIO *f)
2960 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2965 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2968 b->buf = (STDCHAR *)&b->oneword;
2969 b->bufsiz = sizeof(b->oneword);
2978 PerlIOBuf_bufsiz(PerlIO *f)
2980 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2983 return (b->end - b->buf);
2987 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2989 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2993 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2996 assert(PerlIO_get_cnt(f) == cnt);
2997 assert(b->ptr >= b->buf);
2999 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3002 PerlIO_funcs PerlIO_perlio = {
3021 PerlIOBase_clearerr,
3022 PerlIOBase_setlinebuf,
3027 PerlIOBuf_set_ptrcnt,
3030 /*--------------------------------------------------------------------------------------*/
3031 /* Temp layer to hold unread chars when cannot do it any other way */
3034 PerlIOPending_fill(PerlIO *f)
3036 /* Should never happen */
3042 PerlIOPending_close(PerlIO *f)
3044 /* A tad tricky - flush pops us, then we close new top */
3046 return PerlIO_close(f);
3050 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3052 /* A tad tricky - flush pops us, then we seek new top */
3054 return PerlIO_seek(f,offset,whence);
3059 PerlIOPending_flush(PerlIO *f)
3062 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3063 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3065 PerlMemShared_free(b->buf);
3068 PerlIO_pop(aTHX_ f);
3073 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3081 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3086 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3088 IV code = PerlIOBase_pushed(f,mode,arg);
3089 PerlIOl *l = PerlIOBase(f);
3090 /* Our PerlIO_fast_gets must match what we are pushed on,
3091 or sv_gets() etc. get muddled when it changes mid-string
3094 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3095 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3100 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3102 SSize_t avail = PerlIO_get_cnt(f);
3107 got = PerlIOBuf_read(f,vbuf,avail);
3108 if (got >= 0 && got < count)
3110 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3111 if (more >= 0 || got == 0)
3117 PerlIO_funcs PerlIO_pending = {
3121 PerlIOPending_pushed,
3131 PerlIOPending_close,
3132 PerlIOPending_flush,
3136 PerlIOBase_clearerr,
3137 PerlIOBase_setlinebuf,
3142 PerlIOPending_set_ptrcnt,
3147 /*--------------------------------------------------------------------------------------*/
3148 /* crlf - translation
3149 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3150 to hand back a line at a time and keeping a record of which nl we "lied" about.
3151 On write translate "\n" to CR,LF
3156 PerlIOBuf base; /* PerlIOBuf stuff */
3157 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3161 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3164 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3165 code = PerlIOBuf_pushed(f,mode,arg);
3167 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3168 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3169 PerlIOBase(f)->flags);
3176 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3178 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3184 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3185 return PerlIOBuf_unread(f,vbuf,count);
3188 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3189 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3191 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3197 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3199 b->end = b->ptr = b->buf + b->bufsiz;
3200 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3201 b->posn -= b->bufsiz;
3203 while (count > 0 && b->ptr > b->buf)
3208 if (b->ptr - 2 >= b->buf)
3234 PerlIOCrlf_get_cnt(PerlIO *f)
3236 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3239 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3241 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3242 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3244 STDCHAR *nl = b->ptr;
3246 while (nl < b->end && *nl != 0xd)
3248 if (nl < b->end && *nl == 0xd)
3260 /* Not CR,LF but just CR */
3267 /* Blast - found CR as last char in buffer */
3270 /* They may not care, defer work as long as possible */
3271 return (nl - b->ptr);
3276 b->ptr++; /* say we have read it as far as flush() is concerned */
3277 b->buf++; /* Leave space an front of buffer */
3278 b->bufsiz--; /* Buffer is thus smaller */
3279 code = PerlIO_fill(f); /* Fetch some more */
3280 b->bufsiz++; /* Restore size for next time */
3281 b->buf--; /* Point at space */
3282 b->ptr = nl = b->buf; /* Which is what we hand off */
3283 b->posn--; /* Buffer starts here */
3284 *nl = 0xd; /* Fill in the CR */
3286 goto test; /* fill() call worked */
3287 /* CR at EOF - just fall through */
3292 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3298 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3300 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3301 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3302 IV flags = PerlIOBase(f)->flags;
3312 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3319 /* Test code - delete when it works ... */
3326 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3334 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3335 ptr, chk, flags, c->nl, b->end, cnt);
3342 /* They have taken what we lied about */
3349 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3353 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3355 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3356 return PerlIOBuf_write(f,vbuf,count);
3359 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3360 const STDCHAR *buf = (const STDCHAR *) vbuf;
3361 const STDCHAR *ebuf = buf+count;
3364 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3368 STDCHAR *eptr = b->buf+b->bufsiz;
3369 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3370 while (buf < ebuf && b->ptr < eptr)
3374 if ((b->ptr + 2) > eptr)
3376 /* Not room for both */
3382 *(b->ptr)++ = 0xd; /* CR */
3383 *(b->ptr)++ = 0xa; /* LF */
3385 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3404 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3406 return (buf - (STDCHAR *) vbuf);
3411 PerlIOCrlf_flush(PerlIO *f)
3413 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3419 return PerlIOBuf_flush(f);
3422 PerlIO_funcs PerlIO_crlf = {
3425 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3427 PerlIOBase_noop_ok, /* popped */
3431 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3432 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3433 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3441 PerlIOBase_clearerr,
3442 PerlIOBase_setlinebuf,
3447 PerlIOCrlf_set_ptrcnt,
3451 /*--------------------------------------------------------------------------------------*/
3452 /* mmap as "buffer" layer */
3456 PerlIOBuf base; /* PerlIOBuf stuff */
3457 Mmap_t mptr; /* Mapped address */
3458 Size_t len; /* mapped length */
3459 STDCHAR *bbuf; /* malloced buffer if map fails */
3462 static size_t page_size = 0;
3465 PerlIOMmap_map(PerlIO *f)
3468 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3469 IV flags = PerlIOBase(f)->flags;
3473 if (flags & PERLIO_F_CANREAD)
3475 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3476 int fd = PerlIO_fileno(f);
3478 code = fstat(fd,&st);
3479 if (code == 0 && S_ISREG(st.st_mode))
3481 SSize_t len = st.st_size - b->posn;
3486 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3488 SETERRNO(0,SS$_NORMAL);
3489 # ifdef _SC_PAGESIZE
3490 page_size = sysconf(_SC_PAGESIZE);
3492 page_size = sysconf(_SC_PAGE_SIZE);
3494 if ((long)page_size < 0) {
3499 (void)SvUPGRADE(error, SVt_PV);
3500 msg = SvPVx(error, n_a);
3501 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3504 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3508 # ifdef HAS_GETPAGESIZE
3509 page_size = getpagesize();
3511 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3512 page_size = PAGESIZE; /* compiletime, bad */
3516 if ((IV)page_size <= 0)
3517 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3521 /* This is a hack - should never happen - open should have set it ! */
3522 b->posn = PerlIO_tell(PerlIONext(f));
3524 posn = (b->posn / page_size) * page_size;
3525 len = st.st_size - posn;
3526 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3527 if (m->mptr && m->mptr != (Mmap_t) -1)
3529 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3530 madvise(m->mptr, len, MADV_SEQUENTIAL);
3532 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3533 madvise(m->mptr, len, MADV_WILLNEED);
3535 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3536 b->end = ((STDCHAR *)m->mptr) + len;
3537 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3548 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3550 b->ptr = b->end = b->ptr;
3559 PerlIOMmap_unmap(PerlIO *f)
3561 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3562 PerlIOBuf *b = &m->base;
3568 code = munmap(m->mptr, m->len);
3572 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3575 b->ptr = b->end = b->buf;
3576 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3582 PerlIOMmap_get_base(PerlIO *f)
3584 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3585 PerlIOBuf *b = &m->base;
3586 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3588 /* Already have a readbuffer in progress */
3593 /* We have a write buffer or flushed PerlIOBuf read buffer */
3594 m->bbuf = b->buf; /* save it in case we need it again */
3595 b->buf = NULL; /* Clear to trigger below */
3599 PerlIOMmap_map(f); /* Try and map it */
3602 /* Map did not work - recover PerlIOBuf buffer if we have one */
3606 b->ptr = b->end = b->buf;
3609 return PerlIOBuf_get_base(f);
3613 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3615 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3616 PerlIOBuf *b = &m->base;
3617 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3619 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3622 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3627 /* Loose the unwritable mapped buffer */
3629 /* If flush took the "buffer" see if we have one from before */
3630 if (!b->buf && m->bbuf)
3634 PerlIOBuf_get_base(f);
3638 return PerlIOBuf_unread(f,vbuf,count);
3642 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3644 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3645 PerlIOBuf *b = &m->base;
3646 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3648 /* No, or wrong sort of, buffer */
3651 if (PerlIOMmap_unmap(f) != 0)
3654 /* If unmap took the "buffer" see if we have one from before */
3655 if (!b->buf && m->bbuf)
3659 PerlIOBuf_get_base(f);
3663 return PerlIOBuf_write(f,vbuf,count);
3667 PerlIOMmap_flush(PerlIO *f)
3669 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3670 PerlIOBuf *b = &m->base;
3671 IV code = PerlIOBuf_flush(f);
3672 /* Now we are "synced" at PerlIOBuf level */
3677 /* Unmap the buffer */
3678 if (PerlIOMmap_unmap(f) != 0)
3683 /* We seem to have a PerlIOBuf buffer which was not mapped
3684 * remember it in case we need one later
3693 PerlIOMmap_fill(PerlIO *f)
3695 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3696 IV code = PerlIO_flush(f);
3697 if (code == 0 && !b->buf)
3699 code = PerlIOMmap_map(f);
3701 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3703 code = PerlIOBuf_fill(f);
3709 PerlIOMmap_close(PerlIO *f)
3711 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3712 PerlIOBuf *b = &m->base;
3713 IV code = PerlIO_flush(f);
3718 b->ptr = b->end = b->buf;
3720 if (PerlIOBuf_close(f) != 0)
3726 PerlIO_funcs PerlIO_mmap = {
3745 PerlIOBase_clearerr,
3746 PerlIOBase_setlinebuf,
3747 PerlIOMmap_get_base,
3751 PerlIOBuf_set_ptrcnt,
3754 #endif /* HAS_MMAP */
3761 call_atexit(PerlIO_cleanup_layers, NULL);
3766 atexit(&PerlIO_cleanup);
3778 PerlIO_stdstreams(aTHX);
3783 #undef PerlIO_stdout
3790 PerlIO_stdstreams(aTHX);
3795 #undef PerlIO_stderr
3802 PerlIO_stdstreams(aTHX);
3807 /*--------------------------------------------------------------------------------------*/
3809 #undef PerlIO_getname
3811 PerlIO_getname(PerlIO *f, char *buf)
3816 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3817 if (stdio) name = fgetname(stdio, buf);
3819 Perl_croak(aTHX_ "Don't know how to get file name");
3825 /*--------------------------------------------------------------------------------------*/
3826 /* Functions which can be called on any kind of PerlIO implemented
3832 PerlIO_getc(PerlIO *f)
3835 SSize_t count = PerlIO_read(f,buf,1);
3838 return (unsigned char) buf[0];
3843 #undef PerlIO_ungetc
3845 PerlIO_ungetc(PerlIO *f, int ch)
3850 if (PerlIO_unread(f,&buf,1) == 1)
3858 PerlIO_putc(PerlIO *f, int ch)
3861 return PerlIO_write(f,&buf,1);
3866 PerlIO_puts(PerlIO *f, const char *s)
3868 STRLEN len = strlen(s);
3869 return PerlIO_write(f,s,len);
3872 #undef PerlIO_rewind
3874 PerlIO_rewind(PerlIO *f)
3876 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3880 #undef PerlIO_vprintf
3882 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3885 SV *sv = newSVpvn("",0);
3891 Perl_va_copy(ap, apc);
3892 sv_vcatpvf(sv, fmt, &apc);
3894 sv_vcatpvf(sv, fmt, &ap);
3897 wrote = PerlIO_write(f,s,len);
3902 #undef PerlIO_printf
3904 PerlIO_printf(PerlIO *f,const char *fmt,...)
3909 result = PerlIO_vprintf(f,fmt,ap);
3914 #undef PerlIO_stdoutf
3916 PerlIO_stdoutf(const char *fmt,...)
3921 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3926 #undef PerlIO_tmpfile
3928 PerlIO_tmpfile(void)
3930 /* I have no idea how portable mkstemp() is ... */
3931 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3934 FILE *stdio = PerlSIO_tmpfile();
3937 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3943 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3944 int fd = mkstemp(SvPVX(sv));
3948 f = PerlIO_fdopen(fd,"w+");
3951 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3953 PerlLIO_unlink(SvPVX(sv));
3963 #endif /* USE_SFIO */
3964 #endif /* PERLIO_IS_STDIO */
3966 /*======================================================================================*/
3967 /* Now some functions in terms of above which may be needed even if
3968 we are not in true PerlIO mode
3972 #undef PerlIO_setpos
3974 PerlIO_setpos(PerlIO *f, SV *pos)
3980 Off_t *posn = (Off_t *) SvPV(pos,len);
3981 if (f && len == sizeof(Off_t))
3982 return PerlIO_seek(f,*posn,SEEK_SET);
3984 SETERRNO(EINVAL,SS$_IVCHAN);
3988 #undef PerlIO_setpos
3990 PerlIO_setpos(PerlIO *f, SV *pos)
3996 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3997 if (f && len == sizeof(Fpos_t))
3999 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4000 return fsetpos64(f, fpos);
4002 return fsetpos(f, fpos);
4006 SETERRNO(EINVAL,SS$_IVCHAN);
4012 #undef PerlIO_getpos
4014 PerlIO_getpos(PerlIO *f, SV *pos)
4017 Off_t posn = PerlIO_tell(f);
4018 sv_setpvn(pos,(char *)&posn,sizeof(posn));
4019 return (posn == (Off_t)-1) ? -1 : 0;
4022 #undef PerlIO_getpos
4024 PerlIO_getpos(PerlIO *f, SV *pos)
4029 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4030 code = fgetpos64(f, &fpos);
4032 code = fgetpos(f, &fpos);
4034 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4039 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4042 vprintf(char *pat, char *args)
4044 _doprnt(pat, args, stdout);
4045 return 0; /* wrong, but perl doesn't use the return value */
4049 vfprintf(FILE *fd, char *pat, char *args)
4051 _doprnt(pat, args, fd);
4052 return 0; /* wrong, but perl doesn't use the return value */
4057 #ifndef PerlIO_vsprintf
4059 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4061 int val = vsprintf(s, fmt, ap);
4064 if (strlen(s) >= (STRLEN)n)
4067 (void)PerlIO_puts(Perl_error_log,
4068 "panic: sprintf overflow - memory corrupted!\n");
4076 #ifndef PerlIO_sprintf
4078 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4083 result = PerlIO_vsprintf(s, n, fmt, ap);