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 (memEQ(f->name,name,len))
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);
774 #if defined(WIN32) && !defined(UNDER_CE)
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)))
959 if (PerlIOBase(top)->tab == &PerlIO_crlf)
962 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
965 top = PerlIONext(top);
968 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
973 PerlIO__close(PerlIO *f)
976 return (*PerlIOBase(f)->tab->Close)(f);
979 SETERRNO(EBADF,SS$_IVCHAN);
984 #undef PerlIO_fdupopen
986 PerlIO_fdupopen(pTHX_ PerlIO *f)
991 int fd = PerlLIO_dup(PerlIO_fileno(f));
992 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
995 Off_t posn = PerlIO_tell(f);
996 PerlIO_seek(new,posn,SEEK_SET);
1002 SETERRNO(EBADF,SS$_IVCHAN);
1009 PerlIO_close(PerlIO *f)
1015 code = (*PerlIOBase(f)->tab->Close)(f);
1018 PerlIO_pop(aTHX_ f);
1024 #undef PerlIO_fileno
1026 PerlIO_fileno(PerlIO *f)
1029 return (*PerlIOBase(f)->tab->Fileno)(f);
1032 SETERRNO(EBADF,SS$_IVCHAN);
1038 PerlIO_context_layers(pTHX_ const char *mode)
1040 const char *type = NULL;
1041 /* Need to supply default layer info from open.pm */
1044 SV *layers = PL_curcop->cop_io;
1048 type = SvPV(layers,len);
1049 if (type && mode[0] != 'r')
1051 /* Skip to write part */
1052 const char *s = strchr(type,0);
1053 if (s && (s-type) < len)
1063 static PerlIO_funcs *
1064 PerlIO_layer_from_ref(pTHX_ SV *sv)
1066 /* For any scalar type load the handler which is bundled with perl */
1067 if (SvTYPE(sv) < SVt_PVAV)
1068 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1070 /* For other types allow if layer is known but don't try and load it */
1074 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1076 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1078 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1080 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1086 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1088 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1091 PerlIO_stdstreams(aTHX);
1095 /* If it is a reference but not an object see if we have a handler for it */
1096 if (SvROK(arg) && !sv_isobject(arg))
1098 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1101 def = PerlIO_list_alloc();
1102 PerlIO_list_push(def,handler,&PL_sv_undef);
1105 /* Don't fail if handler cannot be found
1106 * :Via(...) etc. may do something sensible
1107 * else we will just stringfy and open resulting string.
1112 layers = PerlIO_context_layers(aTHX_ mode);
1113 if (layers && *layers)
1119 av = PerlIO_list_alloc();
1120 for (i=0; i < def->cur; i++)
1122 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1129 PerlIO_parse_layers(aTHX_ av,layers);
1141 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1143 if (!f && narg == 1 && *args == &PL_sv_undef)
1145 if ((f = PerlIO_tmpfile()))
1148 layers = PerlIO_context_layers(aTHX_ mode);
1149 if (layers && *layers)
1150 PerlIO_apply_layers(aTHX_ f,mode,layers);
1155 PerlIO_list_t *layera = NULL;
1157 PerlIO_funcs *tab = NULL;
1160 /* This is "reopen" - it is not tested as perl does not use it yet */
1162 layera = PerlIO_list_alloc();
1165 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1166 PerlIO_list_push(layera,l->tab,arg);
1167 l = *PerlIONext(&l);
1172 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1174 /* Start at "top" of layer stack */
1178 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1188 /* Found that layer 'n' can do opens - call it */
1189 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1190 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1191 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1194 if (n+1 < layera->cur)
1196 /* More layers above the one that we used to open - apply them now */
1197 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1204 PerlIO_list_free(layera);
1210 #undef PerlIO_fdopen
1212 PerlIO_fdopen(int fd, const char *mode)
1215 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1220 PerlIO_open(const char *path, const char *mode)
1223 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1224 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1227 #undef PerlIO_reopen
1229 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1232 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1233 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1238 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1241 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1244 SETERRNO(EBADF,SS$_IVCHAN);
1249 #undef PerlIO_unread
1251 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1254 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1257 SETERRNO(EBADF,SS$_IVCHAN);
1264 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1267 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1270 SETERRNO(EBADF,SS$_IVCHAN);
1277 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1280 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1283 SETERRNO(EBADF,SS$_IVCHAN);
1290 PerlIO_tell(PerlIO *f)
1293 return (*PerlIOBase(f)->tab->Tell)(f);
1296 SETERRNO(EBADF,SS$_IVCHAN);
1303 PerlIO_flush(PerlIO *f)
1309 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1310 if (tab && tab->Flush)
1312 return (*tab->Flush)(f);
1316 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1317 SETERRNO(EBADF,SS$_IVCHAN);
1323 PerlIO_debug("Cannot flush f=%p\n",f);
1324 SETERRNO(EBADF,SS$_IVCHAN);
1330 /* Is it good API design to do flush-all on NULL,
1331 * a potentially errorneous input? Maybe some magical
1332 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1333 * Yes, stdio does similar things on fflush(NULL),
1334 * but should we be bound by their design decisions?
1336 PerlIO **table = &_perlio;
1338 while ((f = *table))
1341 table = (PerlIO **)(f++);
1342 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1344 if (*f && PerlIO_flush(f) != 0)
1354 PerlIOBase_flush_linebuf()
1356 PerlIO **table = &_perlio;
1358 while ((f = *table))
1361 table = (PerlIO **)(f++);
1362 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1364 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1365 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1374 PerlIO_fill(PerlIO *f)
1377 return (*PerlIOBase(f)->tab->Fill)(f);
1380 SETERRNO(EBADF,SS$_IVCHAN);
1385 #undef PerlIO_isutf8
1387 PerlIO_isutf8(PerlIO *f)
1390 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1393 SETERRNO(EBADF,SS$_IVCHAN);
1400 PerlIO_eof(PerlIO *f)
1403 return (*PerlIOBase(f)->tab->Eof)(f);
1406 SETERRNO(EBADF,SS$_IVCHAN);
1413 PerlIO_error(PerlIO *f)
1416 return (*PerlIOBase(f)->tab->Error)(f);
1419 SETERRNO(EBADF,SS$_IVCHAN);
1424 #undef PerlIO_clearerr
1426 PerlIO_clearerr(PerlIO *f)
1429 (*PerlIOBase(f)->tab->Clearerr)(f);
1431 SETERRNO(EBADF,SS$_IVCHAN);
1434 #undef PerlIO_setlinebuf
1436 PerlIO_setlinebuf(PerlIO *f)
1439 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1441 SETERRNO(EBADF,SS$_IVCHAN);
1444 #undef PerlIO_has_base
1446 PerlIO_has_base(PerlIO *f)
1448 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1452 #undef PerlIO_fast_gets
1454 PerlIO_fast_gets(PerlIO *f)
1456 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1458 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1459 return (tab->Set_ptrcnt != NULL);
1464 #undef PerlIO_has_cntptr
1466 PerlIO_has_cntptr(PerlIO *f)
1470 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1471 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1476 #undef PerlIO_canset_cnt
1478 PerlIO_canset_cnt(PerlIO *f)
1482 PerlIOl *l = PerlIOBase(f);
1483 return (l->tab->Set_ptrcnt != NULL);
1488 #undef PerlIO_get_base
1490 PerlIO_get_base(PerlIO *f)
1493 return (*PerlIOBase(f)->tab->Get_base)(f);
1497 #undef PerlIO_get_bufsiz
1499 PerlIO_get_bufsiz(PerlIO *f)
1502 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1506 #undef PerlIO_get_ptr
1508 PerlIO_get_ptr(PerlIO *f)
1510 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1511 if (tab->Get_ptr == NULL)
1513 return (*tab->Get_ptr)(f);
1516 #undef PerlIO_get_cnt
1518 PerlIO_get_cnt(PerlIO *f)
1520 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1521 if (tab->Get_cnt == NULL)
1523 return (*tab->Get_cnt)(f);
1526 #undef PerlIO_set_cnt
1528 PerlIO_set_cnt(PerlIO *f,int cnt)
1530 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1533 #undef PerlIO_set_ptrcnt
1535 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1537 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1538 if (tab->Set_ptrcnt == NULL)
1541 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1543 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1546 /*--------------------------------------------------------------------------------------*/
1547 /* utf8 and raw dummy layers */
1550 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1555 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1556 PerlIO_pop(aTHX_ f);
1557 if (tab->kind & PERLIO_K_UTF8)
1558 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1560 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1566 PerlIO_funcs PerlIO_utf8 = {
1569 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1587 NULL, /* get_base */
1588 NULL, /* get_bufsiz */
1591 NULL, /* set_ptrcnt */
1594 PerlIO_funcs PerlIO_byte = {
1615 NULL, /* get_base */
1616 NULL, /* get_bufsiz */
1619 NULL, /* set_ptrcnt */
1623 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)
1625 PerlIO_funcs *tab = PerlIO_default_btm();
1626 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1629 PerlIO_funcs PerlIO_raw = {
1650 NULL, /* get_base */
1651 NULL, /* get_bufsiz */
1654 NULL, /* set_ptrcnt */
1656 /*--------------------------------------------------------------------------------------*/
1657 /*--------------------------------------------------------------------------------------*/
1658 /* "Methods" of the "base class" */
1661 PerlIOBase_fileno(PerlIO *f)
1663 return PerlIO_fileno(PerlIONext(f));
1667 PerlIO_modestr(PerlIO *f,char *buf)
1670 IV flags = PerlIOBase(f)->flags;
1671 if (flags & PERLIO_F_APPEND)
1674 if (flags & PERLIO_F_CANREAD)
1679 else if (flags & PERLIO_F_CANREAD)
1682 if (flags & PERLIO_F_CANWRITE)
1685 else if (flags & PERLIO_F_CANWRITE)
1688 if (flags & PERLIO_F_CANREAD)
1693 #if O_TEXT != O_BINARY
1694 if (!(flags & PERLIO_F_CRLF))
1702 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1704 PerlIOl *l = PerlIOBase(f);
1706 const char *omode = mode;
1709 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1710 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1711 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1712 if (tab->Set_ptrcnt != NULL)
1713 l->flags |= PERLIO_F_FASTGETS;
1716 if (*mode == '#' || *mode == 'I')
1721 l->flags |= PERLIO_F_CANREAD;
1724 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1727 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1730 SETERRNO(EINVAL,LIB$_INVARG);
1738 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1741 l->flags &= ~PERLIO_F_CRLF;
1744 l->flags |= PERLIO_F_CRLF;
1747 SETERRNO(EINVAL,LIB$_INVARG);
1756 l->flags |= l->next->flags &
1757 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1761 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1762 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1763 l->flags,PerlIO_modestr(f,temp));
1769 PerlIOBase_popped(PerlIO *f)
1775 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1778 /* Save the position as current head considers it */
1779 Off_t old = PerlIO_tell(f);
1781 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1782 PerlIOSelf(f,PerlIOBuf)->posn = old;
1783 done = PerlIOBuf_unread(f,vbuf,count);
1788 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1790 STDCHAR *buf = (STDCHAR *) vbuf;
1793 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1797 SSize_t avail = PerlIO_get_cnt(f);
1800 take = (count < avail) ? count : avail;
1803 STDCHAR *ptr = PerlIO_get_ptr(f);
1804 Copy(ptr,buf,take,STDCHAR);
1805 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1809 if (count > 0 && avail <= 0)
1811 if (PerlIO_fill(f) != 0)
1815 return (buf - (STDCHAR *) vbuf);
1821 PerlIOBase_noop_ok(PerlIO *f)
1827 PerlIOBase_noop_fail(PerlIO *f)
1833 PerlIOBase_close(PerlIO *f)
1836 PerlIO *n = PerlIONext(f);
1837 if (PerlIO_flush(f) != 0)
1839 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1841 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1846 PerlIOBase_eof(PerlIO *f)
1850 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1856 PerlIOBase_error(PerlIO *f)
1860 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1866 PerlIOBase_clearerr(PerlIO *f)
1870 PerlIO *n = PerlIONext(f);
1871 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1878 PerlIOBase_setlinebuf(PerlIO *f)
1882 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1886 /*--------------------------------------------------------------------------------------*/
1887 /* Bottom-most level for UNIX-like case */
1891 struct _PerlIO base; /* The generic part */
1892 int fd; /* UNIX like file descriptor */
1893 int oflags; /* open/fcntl flags */
1897 PerlIOUnix_oflags(const char *mode)
1900 if (*mode == 'I' || *mode == '#')
1914 oflags = O_CREAT|O_TRUNC;
1925 oflags = O_CREAT|O_APPEND;
1941 else if (*mode == 't')
1944 oflags &= ~O_BINARY;
1947 /* Always open in binary mode */
1949 if (*mode || oflags == -1)
1951 SETERRNO(EINVAL,LIB$_INVARG);
1958 PerlIOUnix_fileno(PerlIO *f)
1960 return PerlIOSelf(f,PerlIOUnix)->fd;
1964 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1966 IV code = PerlIOBase_pushed(f,mode,arg);
1969 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1970 s->fd = PerlIO_fileno(PerlIONext(f));
1971 /* XXX could (or should) we retrieve the oflags from the open file handle
1972 rather than believing the "mode" we are passed in?
1973 XXX Should the value on NULL mode be 0 or -1? */
1974 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
1976 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1981 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)
1985 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1986 (*PerlIOBase(f)->tab->Close)(f);
1990 char *path = SvPV_nolen(*args);
1995 imode = PerlIOUnix_oflags(mode);
2000 fd = PerlLIO_open3(path,imode,perm);
2010 f = PerlIO_allocate(aTHX);
2011 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2014 s = PerlIOSelf(f,PerlIOUnix);
2017 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2024 /* FIXME: pop layers ??? */
2031 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2034 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2035 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2039 SSize_t len = PerlLIO_read(fd,vbuf,count);
2040 if (len >= 0 || errno != EINTR)
2043 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2044 else if (len == 0 && count != 0)
2045 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2053 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2056 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2059 SSize_t len = PerlLIO_write(fd,vbuf,count);
2060 if (len >= 0 || errno != EINTR)
2063 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2071 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2074 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2075 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2076 return (new == (Off_t) -1) ? -1 : 0;
2080 PerlIOUnix_tell(PerlIO *f)
2083 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2087 PerlIOUnix_close(PerlIO *f)
2090 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2092 while (PerlLIO_close(fd) != 0)
2103 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2108 PerlIO_funcs PerlIO_unix = {
2123 PerlIOBase_noop_ok, /* flush */
2124 PerlIOBase_noop_fail, /* fill */
2127 PerlIOBase_clearerr,
2128 PerlIOBase_setlinebuf,
2129 NULL, /* get_base */
2130 NULL, /* get_bufsiz */
2133 NULL, /* set_ptrcnt */
2136 /*--------------------------------------------------------------------------------------*/
2137 /* stdio as a layer */
2141 struct _PerlIO base;
2142 FILE * stdio; /* The stream */
2146 PerlIOStdio_fileno(PerlIO *f)
2149 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2153 PerlIOStdio_mode(const char *mode,char *tmode)
2160 if (O_BINARY != O_TEXT)
2168 /* This isn't used yet ... */
2170 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2175 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2177 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2183 return PerlIOBase_pushed(f,mode,arg);
2186 #undef PerlIO_importFILE
2188 PerlIO_importFILE(FILE *stdio, int fl)
2194 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2201 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)
2206 char *path = SvPV_nolen(*args);
2207 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2208 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2218 char *path = SvPV_nolen(*args);
2222 fd = PerlLIO_open3(path,imode,perm);
2226 FILE *stdio = PerlSIO_fopen(path,mode);
2229 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2230 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2251 stdio = PerlSIO_stdin;
2254 stdio = PerlSIO_stdout;
2257 stdio = PerlSIO_stderr;
2263 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2267 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2277 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2280 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2284 STDCHAR *buf = (STDCHAR *) vbuf;
2285 /* Perl is expecting PerlIO_getc() to fill the buffer
2286 * Linux's stdio does not do that for fread()
2288 int ch = PerlSIO_fgetc(s);
2296 got = PerlSIO_fread(vbuf,1,count,s);
2301 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2304 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2305 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2309 int ch = *buf-- & 0xff;
2310 if (PerlSIO_ungetc(ch,s) != ch)
2319 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2322 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2326 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2329 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2330 return PerlSIO_fseek(stdio,offset,whence);
2334 PerlIOStdio_tell(PerlIO *f)
2337 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2338 return PerlSIO_ftell(stdio);
2342 PerlIOStdio_close(PerlIO *f)
2345 #ifdef SOCKS5_VERSION_NAME
2347 Sock_size_t optlen = sizeof(int);
2349 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2351 #ifdef SOCKS5_VERSION_NAME
2352 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2353 PerlSIO_fclose(stdio) :
2354 close(PerlIO_fileno(f))
2356 PerlSIO_fclose(stdio)
2363 PerlIOStdio_flush(PerlIO *f)
2366 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2367 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2369 return PerlSIO_fflush(stdio);
2374 /* FIXME: This discards ungetc() and pre-read stuff which is
2375 not right if this is just a "sync" from a layer above
2376 Suspect right design is to do _this_ but not have layer above
2377 flush this layer read-to-read
2379 /* Not writeable - sync by attempting a seek */
2381 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2389 PerlIOStdio_fill(PerlIO *f)
2392 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2394 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2395 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2397 if (PerlSIO_fflush(stdio) != 0)
2400 c = PerlSIO_fgetc(stdio);
2401 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2407 PerlIOStdio_eof(PerlIO *f)
2410 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2414 PerlIOStdio_error(PerlIO *f)
2417 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2421 PerlIOStdio_clearerr(PerlIO *f)
2424 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2428 PerlIOStdio_setlinebuf(PerlIO *f)
2431 #ifdef HAS_SETLINEBUF
2432 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2434 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2440 PerlIOStdio_get_base(PerlIO *f)
2443 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2444 return PerlSIO_get_base(stdio);
2448 PerlIOStdio_get_bufsiz(PerlIO *f)
2451 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2452 return PerlSIO_get_bufsiz(stdio);
2456 #ifdef USE_STDIO_PTR
2458 PerlIOStdio_get_ptr(PerlIO *f)
2461 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2462 return PerlSIO_get_ptr(stdio);
2466 PerlIOStdio_get_cnt(PerlIO *f)
2469 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2470 return PerlSIO_get_cnt(stdio);
2474 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2476 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2480 #ifdef STDIO_PTR_LVALUE
2481 PerlSIO_set_ptr(stdio,ptr);
2482 #ifdef STDIO_PTR_LVAL_SETS_CNT
2483 if (PerlSIO_get_cnt(stdio) != (cnt))
2486 assert(PerlSIO_get_cnt(stdio) == (cnt));
2489 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2490 /* Setting ptr _does_ change cnt - we are done */
2493 #else /* STDIO_PTR_LVALUE */
2495 #endif /* STDIO_PTR_LVALUE */
2497 /* Now (or only) set cnt */
2498 #ifdef STDIO_CNT_LVALUE
2499 PerlSIO_set_cnt(stdio,cnt);
2500 #else /* STDIO_CNT_LVALUE */
2501 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2502 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2503 #else /* STDIO_PTR_LVAL_SETS_CNT */
2505 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2506 #endif /* STDIO_CNT_LVALUE */
2511 PerlIO_funcs PerlIO_stdio = {
2513 sizeof(PerlIOStdio),
2530 PerlIOStdio_clearerr,
2531 PerlIOStdio_setlinebuf,
2533 PerlIOStdio_get_base,
2534 PerlIOStdio_get_bufsiz,
2539 #ifdef USE_STDIO_PTR
2540 PerlIOStdio_get_ptr,
2541 PerlIOStdio_get_cnt,
2542 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2543 PerlIOStdio_set_ptrcnt
2544 #else /* STDIO_PTR_LVALUE */
2546 #endif /* STDIO_PTR_LVALUE */
2547 #else /* USE_STDIO_PTR */
2551 #endif /* USE_STDIO_PTR */
2554 #undef PerlIO_exportFILE
2556 PerlIO_exportFILE(PerlIO *f, int fl)
2560 stdio = fdopen(PerlIO_fileno(f),"r+");
2564 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2570 #undef PerlIO_findFILE
2572 PerlIO_findFILE(PerlIO *f)
2577 if (l->tab == &PerlIO_stdio)
2579 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2582 l = *PerlIONext(&l);
2584 return PerlIO_exportFILE(f,0);
2587 #undef PerlIO_releaseFILE
2589 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2593 /*--------------------------------------------------------------------------------------*/
2594 /* perlio buffer layer */
2597 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2600 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2601 int fd = PerlIO_fileno(f);
2603 if (fd >= 0 && PerlLIO_isatty(fd))
2605 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2607 posn = PerlIO_tell(PerlIONext(f));
2608 if (posn != (Off_t) -1)
2612 return PerlIOBase_pushed(f,mode,arg);
2616 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)
2620 PerlIO *next = PerlIONext(f);
2621 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2622 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2623 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2630 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2637 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2640 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2641 fd = PerlIO_fileno(f);
2642 #if O_BINARY != O_TEXT
2643 /* do something about failing setmode()? --jhi */
2644 PerlLIO_setmode(fd , O_BINARY);
2646 if (init && fd == 2)
2648 /* Initial stderr is unbuffered */
2649 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2656 /* This "flush" is akin to sfio's sync in that it handles files in either
2660 PerlIOBuf_flush(PerlIO *f)
2662 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2664 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2666 /* write() the buffer */
2667 STDCHAR *buf = b->buf;
2669 PerlIO *n = PerlIONext(f);
2672 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2677 else if (count < 0 || PerlIO_error(n))
2679 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2684 b->posn += (p - buf);
2686 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2688 STDCHAR *buf = PerlIO_get_base(f);
2689 /* Note position change */
2690 b->posn += (b->ptr - buf);
2691 if (b->ptr < b->end)
2693 /* We did not consume all of it */
2694 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2696 b->posn = PerlIO_tell(PerlIONext(f));
2700 b->ptr = b->end = b->buf;
2701 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2702 /* FIXME: Is this right for read case ? */
2703 if (PerlIO_flush(PerlIONext(f)) != 0)
2709 PerlIOBuf_fill(PerlIO *f)
2711 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2712 PerlIO *n = PerlIONext(f);
2714 /* FIXME: doing the down-stream flush is a bad idea if it causes
2715 pre-read data in stdio buffer to be discarded
2716 but this is too simplistic - as it skips _our_ hosekeeping
2717 and breaks tell tests.
2718 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2722 if (PerlIO_flush(f) != 0)
2724 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2725 PerlIOBase_flush_linebuf();
2728 PerlIO_get_base(f); /* allocate via vtable */
2730 b->ptr = b->end = b->buf;
2731 if (PerlIO_fast_gets(n))
2733 /* Layer below is also buffered
2734 * We do _NOT_ want to call its ->Read() because that will loop
2735 * till it gets what we asked for which may hang on a pipe etc.
2736 * Instead take anything it has to hand, or ask it to fill _once_.
2738 avail = PerlIO_get_cnt(n);
2741 avail = PerlIO_fill(n);
2743 avail = PerlIO_get_cnt(n);
2746 if (!PerlIO_error(n) && PerlIO_eof(n))
2752 STDCHAR *ptr = PerlIO_get_ptr(n);
2753 SSize_t cnt = avail;
2754 if (avail > b->bufsiz)
2756 Copy(ptr,b->buf,avail,STDCHAR);
2757 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2762 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2767 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2769 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2772 b->end = b->buf+avail;
2773 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2778 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2780 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2785 return PerlIOBase_read(f,vbuf,count);
2791 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2793 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2794 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2797 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2803 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2805 /* Buffer is already a read buffer, we can overwrite any chars
2806 which have been read back to buffer start
2808 avail = (b->ptr - b->buf);
2812 /* Buffer is idle, set it up so whole buffer is available for unread */
2814 b->end = b->buf + avail;
2816 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2817 /* Buffer extends _back_ from where we are now */
2818 b->posn -= b->bufsiz;
2820 if (avail > (SSize_t) count)
2822 /* If we have space for more than count, just move count */
2829 /* In simple stdio-like ungetc() case chars will be already there */
2832 Copy(buf,b->ptr,avail,STDCHAR);
2836 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2843 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2845 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2846 const STDCHAR *buf = (const STDCHAR *) vbuf;
2850 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2854 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2855 if ((SSize_t) count < avail)
2857 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2858 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2878 Copy(buf,b->ptr,avail,STDCHAR);
2885 if (b->ptr >= (b->buf + b->bufsiz))
2888 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2894 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2897 if ((code = PerlIO_flush(f)) == 0)
2899 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2900 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2901 code = PerlIO_seek(PerlIONext(f),offset,whence);
2904 b->posn = PerlIO_tell(PerlIONext(f));
2911 PerlIOBuf_tell(PerlIO *f)
2913 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2914 /* b->posn is file position where b->buf was read, or will be written */
2915 Off_t posn = b->posn;
2918 /* If buffer is valid adjust position by amount in buffer */
2919 posn += (b->ptr - b->buf);
2925 PerlIOBuf_close(PerlIO *f)
2927 IV code = PerlIOBase_close(f);
2928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2929 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2931 PerlMemShared_free(b->buf);
2934 b->ptr = b->end = b->buf;
2935 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2940 PerlIOBuf_get_ptr(PerlIO *f)
2942 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2949 PerlIOBuf_get_cnt(PerlIO *f)
2951 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2954 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2955 return (b->end - b->ptr);
2960 PerlIOBuf_get_base(PerlIO *f)
2962 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2967 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2970 b->buf = (STDCHAR *)&b->oneword;
2971 b->bufsiz = sizeof(b->oneword);
2980 PerlIOBuf_bufsiz(PerlIO *f)
2982 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2985 return (b->end - b->buf);
2989 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2991 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2995 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2998 assert(PerlIO_get_cnt(f) == cnt);
2999 assert(b->ptr >= b->buf);
3001 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3004 PerlIO_funcs PerlIO_perlio = {
3023 PerlIOBase_clearerr,
3024 PerlIOBase_setlinebuf,
3029 PerlIOBuf_set_ptrcnt,
3032 /*--------------------------------------------------------------------------------------*/
3033 /* Temp layer to hold unread chars when cannot do it any other way */
3036 PerlIOPending_fill(PerlIO *f)
3038 /* Should never happen */
3044 PerlIOPending_close(PerlIO *f)
3046 /* A tad tricky - flush pops us, then we close new top */
3048 return PerlIO_close(f);
3052 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3054 /* A tad tricky - flush pops us, then we seek new top */
3056 return PerlIO_seek(f,offset,whence);
3061 PerlIOPending_flush(PerlIO *f)
3064 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3065 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3067 PerlMemShared_free(b->buf);
3070 PerlIO_pop(aTHX_ f);
3075 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3083 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3088 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3090 IV code = PerlIOBase_pushed(f,mode,arg);
3091 PerlIOl *l = PerlIOBase(f);
3092 /* Our PerlIO_fast_gets must match what we are pushed on,
3093 or sv_gets() etc. get muddled when it changes mid-string
3096 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3097 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3102 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3104 SSize_t avail = PerlIO_get_cnt(f);
3109 got = PerlIOBuf_read(f,vbuf,avail);
3110 if (got >= 0 && got < count)
3112 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3113 if (more >= 0 || got == 0)
3119 PerlIO_funcs PerlIO_pending = {
3123 PerlIOPending_pushed,
3133 PerlIOPending_close,
3134 PerlIOPending_flush,
3138 PerlIOBase_clearerr,
3139 PerlIOBase_setlinebuf,
3144 PerlIOPending_set_ptrcnt,
3149 /*--------------------------------------------------------------------------------------*/
3150 /* crlf - translation
3151 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3152 to hand back a line at a time and keeping a record of which nl we "lied" about.
3153 On write translate "\n" to CR,LF
3158 PerlIOBuf base; /* PerlIOBuf stuff */
3159 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3163 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3166 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3167 code = PerlIOBuf_pushed(f,mode,arg);
3169 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3170 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3171 PerlIOBase(f)->flags);
3178 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3180 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3186 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3187 return PerlIOBuf_unread(f,vbuf,count);
3190 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3191 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3193 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3199 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3201 b->end = b->ptr = b->buf + b->bufsiz;
3202 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3203 b->posn -= b->bufsiz;
3205 while (count > 0 && b->ptr > b->buf)
3210 if (b->ptr - 2 >= b->buf)
3236 PerlIOCrlf_get_cnt(PerlIO *f)
3238 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3241 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3243 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3244 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3246 STDCHAR *nl = b->ptr;
3248 while (nl < b->end && *nl != 0xd)
3250 if (nl < b->end && *nl == 0xd)
3262 /* Not CR,LF but just CR */
3269 /* Blast - found CR as last char in buffer */
3272 /* They may not care, defer work as long as possible */
3273 return (nl - b->ptr);
3278 b->ptr++; /* say we have read it as far as flush() is concerned */
3279 b->buf++; /* Leave space an front of buffer */
3280 b->bufsiz--; /* Buffer is thus smaller */
3281 code = PerlIO_fill(f); /* Fetch some more */
3282 b->bufsiz++; /* Restore size for next time */
3283 b->buf--; /* Point at space */
3284 b->ptr = nl = b->buf; /* Which is what we hand off */
3285 b->posn--; /* Buffer starts here */
3286 *nl = 0xd; /* Fill in the CR */
3288 goto test; /* fill() call worked */
3289 /* CR at EOF - just fall through */
3294 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3300 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3302 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3303 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3304 IV flags = PerlIOBase(f)->flags;
3314 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3321 /* Test code - delete when it works ... */
3328 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3336 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3337 ptr, chk, flags, c->nl, b->end, cnt);
3344 /* They have taken what we lied about */
3351 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3355 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3357 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3358 return PerlIOBuf_write(f,vbuf,count);
3361 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3362 const STDCHAR *buf = (const STDCHAR *) vbuf;
3363 const STDCHAR *ebuf = buf+count;
3366 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3370 STDCHAR *eptr = b->buf+b->bufsiz;
3371 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3372 while (buf < ebuf && b->ptr < eptr)
3376 if ((b->ptr + 2) > eptr)
3378 /* Not room for both */
3384 *(b->ptr)++ = 0xd; /* CR */
3385 *(b->ptr)++ = 0xa; /* LF */
3387 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3406 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3408 return (buf - (STDCHAR *) vbuf);
3413 PerlIOCrlf_flush(PerlIO *f)
3415 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3421 return PerlIOBuf_flush(f);
3424 PerlIO_funcs PerlIO_crlf = {
3427 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3429 PerlIOBase_noop_ok, /* popped */
3433 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3434 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3435 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3443 PerlIOBase_clearerr,
3444 PerlIOBase_setlinebuf,
3449 PerlIOCrlf_set_ptrcnt,
3453 /*--------------------------------------------------------------------------------------*/
3454 /* mmap as "buffer" layer */
3458 PerlIOBuf base; /* PerlIOBuf stuff */
3459 Mmap_t mptr; /* Mapped address */
3460 Size_t len; /* mapped length */
3461 STDCHAR *bbuf; /* malloced buffer if map fails */
3464 static size_t page_size = 0;
3467 PerlIOMmap_map(PerlIO *f)
3470 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3471 IV flags = PerlIOBase(f)->flags;
3475 if (flags & PERLIO_F_CANREAD)
3477 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3478 int fd = PerlIO_fileno(f);
3480 code = fstat(fd,&st);
3481 if (code == 0 && S_ISREG(st.st_mode))
3483 SSize_t len = st.st_size - b->posn;
3488 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3490 SETERRNO(0,SS$_NORMAL);
3491 # ifdef _SC_PAGESIZE
3492 page_size = sysconf(_SC_PAGESIZE);
3494 page_size = sysconf(_SC_PAGE_SIZE);
3496 if ((long)page_size < 0) {
3501 (void)SvUPGRADE(error, SVt_PV);
3502 msg = SvPVx(error, n_a);
3503 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3506 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3510 # ifdef HAS_GETPAGESIZE
3511 page_size = getpagesize();
3513 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3514 page_size = PAGESIZE; /* compiletime, bad */
3518 if ((IV)page_size <= 0)
3519 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3523 /* This is a hack - should never happen - open should have set it ! */
3524 b->posn = PerlIO_tell(PerlIONext(f));
3526 posn = (b->posn / page_size) * page_size;
3527 len = st.st_size - posn;
3528 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3529 if (m->mptr && m->mptr != (Mmap_t) -1)
3531 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3532 madvise(m->mptr, len, MADV_SEQUENTIAL);
3534 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3535 madvise(m->mptr, len, MADV_WILLNEED);
3537 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3538 b->end = ((STDCHAR *)m->mptr) + len;
3539 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3550 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3552 b->ptr = b->end = b->ptr;
3561 PerlIOMmap_unmap(PerlIO *f)
3563 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3564 PerlIOBuf *b = &m->base;
3570 code = munmap(m->mptr, m->len);
3574 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3577 b->ptr = b->end = b->buf;
3578 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3584 PerlIOMmap_get_base(PerlIO *f)
3586 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3587 PerlIOBuf *b = &m->base;
3588 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3590 /* Already have a readbuffer in progress */
3595 /* We have a write buffer or flushed PerlIOBuf read buffer */
3596 m->bbuf = b->buf; /* save it in case we need it again */
3597 b->buf = NULL; /* Clear to trigger below */
3601 PerlIOMmap_map(f); /* Try and map it */
3604 /* Map did not work - recover PerlIOBuf buffer if we have one */
3608 b->ptr = b->end = b->buf;
3611 return PerlIOBuf_get_base(f);
3615 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3617 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3618 PerlIOBuf *b = &m->base;
3619 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3621 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3624 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3629 /* Loose the unwritable mapped buffer */
3631 /* If flush took the "buffer" see if we have one from before */
3632 if (!b->buf && m->bbuf)
3636 PerlIOBuf_get_base(f);
3640 return PerlIOBuf_unread(f,vbuf,count);
3644 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3646 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3647 PerlIOBuf *b = &m->base;
3648 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3650 /* No, or wrong sort of, buffer */
3653 if (PerlIOMmap_unmap(f) != 0)
3656 /* If unmap took the "buffer" see if we have one from before */
3657 if (!b->buf && m->bbuf)
3661 PerlIOBuf_get_base(f);
3665 return PerlIOBuf_write(f,vbuf,count);
3669 PerlIOMmap_flush(PerlIO *f)
3671 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3672 PerlIOBuf *b = &m->base;
3673 IV code = PerlIOBuf_flush(f);
3674 /* Now we are "synced" at PerlIOBuf level */
3679 /* Unmap the buffer */
3680 if (PerlIOMmap_unmap(f) != 0)
3685 /* We seem to have a PerlIOBuf buffer which was not mapped
3686 * remember it in case we need one later
3695 PerlIOMmap_fill(PerlIO *f)
3697 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3698 IV code = PerlIO_flush(f);
3699 if (code == 0 && !b->buf)
3701 code = PerlIOMmap_map(f);
3703 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3705 code = PerlIOBuf_fill(f);
3711 PerlIOMmap_close(PerlIO *f)
3713 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3714 PerlIOBuf *b = &m->base;
3715 IV code = PerlIO_flush(f);
3720 b->ptr = b->end = b->buf;
3722 if (PerlIOBuf_close(f) != 0)
3728 PerlIO_funcs PerlIO_mmap = {
3747 PerlIOBase_clearerr,
3748 PerlIOBase_setlinebuf,
3749 PerlIOMmap_get_base,
3753 PerlIOBuf_set_ptrcnt,
3756 #endif /* HAS_MMAP */
3763 call_atexit(PerlIO_cleanup_layers, NULL);
3768 atexit(&PerlIO_cleanup);
3780 PerlIO_stdstreams(aTHX);
3785 #undef PerlIO_stdout
3792 PerlIO_stdstreams(aTHX);
3797 #undef PerlIO_stderr
3804 PerlIO_stdstreams(aTHX);
3809 /*--------------------------------------------------------------------------------------*/
3811 #undef PerlIO_getname
3813 PerlIO_getname(PerlIO *f, char *buf)
3818 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3819 if (stdio) name = fgetname(stdio, buf);
3821 Perl_croak(aTHX_ "Don't know how to get file name");
3827 /*--------------------------------------------------------------------------------------*/
3828 /* Functions which can be called on any kind of PerlIO implemented
3834 PerlIO_getc(PerlIO *f)
3837 SSize_t count = PerlIO_read(f,buf,1);
3840 return (unsigned char) buf[0];
3845 #undef PerlIO_ungetc
3847 PerlIO_ungetc(PerlIO *f, int ch)
3852 if (PerlIO_unread(f,&buf,1) == 1)
3860 PerlIO_putc(PerlIO *f, int ch)
3863 return PerlIO_write(f,&buf,1);
3868 PerlIO_puts(PerlIO *f, const char *s)
3870 STRLEN len = strlen(s);
3871 return PerlIO_write(f,s,len);
3874 #undef PerlIO_rewind
3876 PerlIO_rewind(PerlIO *f)
3878 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3882 #undef PerlIO_vprintf
3884 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3887 SV *sv = newSVpvn("",0);
3893 Perl_va_copy(ap, apc);
3894 sv_vcatpvf(sv, fmt, &apc);
3896 sv_vcatpvf(sv, fmt, &ap);
3899 wrote = PerlIO_write(f,s,len);
3904 #undef PerlIO_printf
3906 PerlIO_printf(PerlIO *f,const char *fmt,...)
3911 result = PerlIO_vprintf(f,fmt,ap);
3916 #undef PerlIO_stdoutf
3918 PerlIO_stdoutf(const char *fmt,...)
3923 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3928 #undef PerlIO_tmpfile
3930 PerlIO_tmpfile(void)
3932 /* I have no idea how portable mkstemp() is ... */
3933 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3936 FILE *stdio = PerlSIO_tmpfile();
3939 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3945 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3946 int fd = mkstemp(SvPVX(sv));
3950 f = PerlIO_fdopen(fd,"w+");
3953 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3955 PerlLIO_unlink(SvPVX(sv));
3965 #endif /* USE_SFIO */
3966 #endif /* PERLIO_IS_STDIO */
3968 /*======================================================================================*/
3969 /* Now some functions in terms of above which may be needed even if
3970 we are not in true PerlIO mode
3974 #undef PerlIO_setpos
3976 PerlIO_setpos(PerlIO *f, SV *pos)
3982 Off_t *posn = (Off_t *) SvPV(pos,len);
3983 if (f && len == sizeof(Off_t))
3984 return PerlIO_seek(f,*posn,SEEK_SET);
3986 SETERRNO(EINVAL,SS$_IVCHAN);
3990 #undef PerlIO_setpos
3992 PerlIO_setpos(PerlIO *f, SV *pos)
3998 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3999 if (f && len == sizeof(Fpos_t))
4001 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4002 return fsetpos64(f, fpos);
4004 return fsetpos(f, fpos);
4008 SETERRNO(EINVAL,SS$_IVCHAN);
4014 #undef PerlIO_getpos
4016 PerlIO_getpos(PerlIO *f, SV *pos)
4019 Off_t posn = PerlIO_tell(f);
4020 sv_setpvn(pos,(char *)&posn,sizeof(posn));
4021 return (posn == (Off_t)-1) ? -1 : 0;
4024 #undef PerlIO_getpos
4026 PerlIO_getpos(PerlIO *f, SV *pos)
4031 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4032 code = fgetpos64(f, &fpos);
4034 code = fgetpos(f, &fpos);
4036 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4041 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4044 vprintf(char *pat, char *args)
4046 _doprnt(pat, args, stdout);
4047 return 0; /* wrong, but perl doesn't use the return value */
4051 vfprintf(FILE *fd, char *pat, char *args)
4053 _doprnt(pat, args, fd);
4054 return 0; /* wrong, but perl doesn't use the return value */
4059 #ifndef PerlIO_vsprintf
4061 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4063 int val = vsprintf(s, fmt, ap);
4066 if (strlen(s) >= (STRLEN)n)
4069 (void)PerlIO_puts(Perl_error_log,
4070 "panic: sprintf overflow - memory corrupted!\n");
4078 #ifndef PerlIO_sprintf
4080 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4085 result = PerlIO_vsprintf(s, n, fmt, ap);