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 %ld 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 Off_t old = PerlIO_tell(f);
1781 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1782 done = PerlIOBuf_unread(f,vbuf,count);
1783 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
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 s->oflags = PerlIOUnix_oflags(mode);
1973 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1978 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)
1982 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1983 (*PerlIOBase(f)->tab->Close)(f);
1987 char *path = SvPV_nolen(*args);
1992 imode = PerlIOUnix_oflags(mode);
1997 fd = PerlLIO_open3(path,imode,perm);
2007 f = PerlIO_allocate(aTHX);
2008 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2011 s = PerlIOSelf(f,PerlIOUnix);
2014 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2021 /* FIXME: pop layers ??? */
2028 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2031 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2032 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2036 SSize_t len = PerlLIO_read(fd,vbuf,count);
2037 if (len >= 0 || errno != EINTR)
2040 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2041 else if (len == 0 && count != 0)
2042 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2050 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2053 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2056 SSize_t len = PerlLIO_write(fd,vbuf,count);
2057 if (len >= 0 || errno != EINTR)
2060 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2068 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2071 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2072 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2073 return (new == (Off_t) -1) ? -1 : 0;
2077 PerlIOUnix_tell(PerlIO *f)
2080 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2084 PerlIOUnix_close(PerlIO *f)
2087 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2089 while (PerlLIO_close(fd) != 0)
2100 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2105 PerlIO_funcs PerlIO_unix = {
2120 PerlIOBase_noop_ok, /* flush */
2121 PerlIOBase_noop_fail, /* fill */
2124 PerlIOBase_clearerr,
2125 PerlIOBase_setlinebuf,
2126 NULL, /* get_base */
2127 NULL, /* get_bufsiz */
2130 NULL, /* set_ptrcnt */
2133 /*--------------------------------------------------------------------------------------*/
2134 /* stdio as a layer */
2138 struct _PerlIO base;
2139 FILE * stdio; /* The stream */
2143 PerlIOStdio_fileno(PerlIO *f)
2146 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2150 PerlIOStdio_mode(const char *mode,char *tmode)
2157 if (O_BINARY != O_TEXT)
2165 /* This isn't used yet ... */
2167 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2172 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2174 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2180 return PerlIOBase_pushed(f,mode,arg);
2183 #undef PerlIO_importFILE
2185 PerlIO_importFILE(FILE *stdio, int fl)
2191 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2198 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)
2203 char *path = SvPV_nolen(*args);
2204 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2205 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2215 char *path = SvPV_nolen(*args);
2219 fd = PerlLIO_open3(path,imode,perm);
2223 FILE *stdio = PerlSIO_fopen(path,mode);
2226 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2227 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2248 stdio = PerlSIO_stdin;
2251 stdio = PerlSIO_stdout;
2254 stdio = PerlSIO_stderr;
2260 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2264 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2274 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2277 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2281 STDCHAR *buf = (STDCHAR *) vbuf;
2282 /* Perl is expecting PerlIO_getc() to fill the buffer
2283 * Linux's stdio does not do that for fread()
2285 int ch = PerlSIO_fgetc(s);
2293 got = PerlSIO_fread(vbuf,1,count,s);
2298 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2301 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2302 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2306 int ch = *buf-- & 0xff;
2307 if (PerlSIO_ungetc(ch,s) != ch)
2316 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2319 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2323 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2326 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2327 return PerlSIO_fseek(stdio,offset,whence);
2331 PerlIOStdio_tell(PerlIO *f)
2334 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2335 return PerlSIO_ftell(stdio);
2339 PerlIOStdio_close(PerlIO *f)
2342 #ifdef SOCKS5_VERSION_NAME
2344 Sock_size_t optlen = sizeof(int);
2346 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2348 #ifdef SOCKS5_VERSION_NAME
2349 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2350 PerlSIO_fclose(stdio) :
2351 close(PerlIO_fileno(f))
2353 PerlSIO_fclose(stdio)
2360 PerlIOStdio_flush(PerlIO *f)
2363 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2364 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2366 return PerlSIO_fflush(stdio);
2371 /* FIXME: This discards ungetc() and pre-read stuff which is
2372 not right if this is just a "sync" from a layer above
2373 Suspect right design is to do _this_ but not have layer above
2374 flush this layer read-to-read
2376 /* Not writeable - sync by attempting a seek */
2378 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2386 PerlIOStdio_fill(PerlIO *f)
2389 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2391 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2392 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2394 if (PerlSIO_fflush(stdio) != 0)
2397 c = PerlSIO_fgetc(stdio);
2398 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2404 PerlIOStdio_eof(PerlIO *f)
2407 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2411 PerlIOStdio_error(PerlIO *f)
2414 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2418 PerlIOStdio_clearerr(PerlIO *f)
2421 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2425 PerlIOStdio_setlinebuf(PerlIO *f)
2428 #ifdef HAS_SETLINEBUF
2429 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2431 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2437 PerlIOStdio_get_base(PerlIO *f)
2440 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2441 return PerlSIO_get_base(stdio);
2445 PerlIOStdio_get_bufsiz(PerlIO *f)
2448 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2449 return PerlSIO_get_bufsiz(stdio);
2453 #ifdef USE_STDIO_PTR
2455 PerlIOStdio_get_ptr(PerlIO *f)
2458 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2459 return PerlSIO_get_ptr(stdio);
2463 PerlIOStdio_get_cnt(PerlIO *f)
2466 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2467 return PerlSIO_get_cnt(stdio);
2471 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2473 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2477 #ifdef STDIO_PTR_LVALUE
2478 PerlSIO_set_ptr(stdio,ptr);
2479 #ifdef STDIO_PTR_LVAL_SETS_CNT
2480 if (PerlSIO_get_cnt(stdio) != (cnt))
2483 assert(PerlSIO_get_cnt(stdio) == (cnt));
2486 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2487 /* Setting ptr _does_ change cnt - we are done */
2490 #else /* STDIO_PTR_LVALUE */
2492 #endif /* STDIO_PTR_LVALUE */
2494 /* Now (or only) set cnt */
2495 #ifdef STDIO_CNT_LVALUE
2496 PerlSIO_set_cnt(stdio,cnt);
2497 #else /* STDIO_CNT_LVALUE */
2498 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2499 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2500 #else /* STDIO_PTR_LVAL_SETS_CNT */
2502 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2503 #endif /* STDIO_CNT_LVALUE */
2508 PerlIO_funcs PerlIO_stdio = {
2510 sizeof(PerlIOStdio),
2527 PerlIOStdio_clearerr,
2528 PerlIOStdio_setlinebuf,
2530 PerlIOStdio_get_base,
2531 PerlIOStdio_get_bufsiz,
2536 #ifdef USE_STDIO_PTR
2537 PerlIOStdio_get_ptr,
2538 PerlIOStdio_get_cnt,
2539 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2540 PerlIOStdio_set_ptrcnt
2541 #else /* STDIO_PTR_LVALUE */
2543 #endif /* STDIO_PTR_LVALUE */
2544 #else /* USE_STDIO_PTR */
2548 #endif /* USE_STDIO_PTR */
2551 #undef PerlIO_exportFILE
2553 PerlIO_exportFILE(PerlIO *f, int fl)
2557 stdio = fdopen(PerlIO_fileno(f),"r+");
2561 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2567 #undef PerlIO_findFILE
2569 PerlIO_findFILE(PerlIO *f)
2574 if (l->tab == &PerlIO_stdio)
2576 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2579 l = *PerlIONext(&l);
2581 return PerlIO_exportFILE(f,0);
2584 #undef PerlIO_releaseFILE
2586 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2590 /*--------------------------------------------------------------------------------------*/
2591 /* perlio buffer layer */
2594 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2597 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2598 int fd = PerlIO_fileno(f);
2600 if (fd >= 0 && PerlLIO_isatty(fd))
2602 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2604 posn = PerlIO_tell(PerlIONext(f));
2605 if (posn != (Off_t) -1)
2609 return PerlIOBase_pushed(f,mode,arg);
2613 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)
2617 PerlIO *next = PerlIONext(f);
2618 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2619 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2620 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2627 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2634 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2637 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2638 fd = PerlIO_fileno(f);
2639 #if O_BINARY != O_TEXT
2640 /* do something about failing setmode()? --jhi */
2641 PerlLIO_setmode(fd , O_BINARY);
2643 if (init && fd == 2)
2645 /* Initial stderr is unbuffered */
2646 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2653 /* This "flush" is akin to sfio's sync in that it handles files in either
2657 PerlIOBuf_flush(PerlIO *f)
2659 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2661 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2663 /* write() the buffer */
2664 STDCHAR *buf = b->buf;
2666 PerlIO *n = PerlIONext(f);
2669 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2674 else if (count < 0 || PerlIO_error(n))
2676 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2681 b->posn += (p - buf);
2683 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2685 STDCHAR *buf = PerlIO_get_base(f);
2686 /* Note position change */
2687 b->posn += (b->ptr - buf);
2688 if (b->ptr < b->end)
2690 /* We did not consume all of it */
2691 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2693 b->posn = PerlIO_tell(PerlIONext(f));
2697 b->ptr = b->end = b->buf;
2698 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2699 /* FIXME: Is this right for read case ? */
2700 if (PerlIO_flush(PerlIONext(f)) != 0)
2706 PerlIOBuf_fill(PerlIO *f)
2708 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2709 PerlIO *n = PerlIONext(f);
2711 /* FIXME: doing the down-stream flush is a bad idea if it causes
2712 pre-read data in stdio buffer to be discarded
2713 but this is too simplistic - as it skips _our_ hosekeeping
2714 and breaks tell tests.
2715 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2719 if (PerlIO_flush(f) != 0)
2721 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2722 PerlIOBase_flush_linebuf();
2725 PerlIO_get_base(f); /* allocate via vtable */
2727 b->ptr = b->end = b->buf;
2728 if (PerlIO_fast_gets(n))
2730 /* Layer below is also buffered
2731 * We do _NOT_ want to call its ->Read() because that will loop
2732 * till it gets what we asked for which may hang on a pipe etc.
2733 * Instead take anything it has to hand, or ask it to fill _once_.
2735 avail = PerlIO_get_cnt(n);
2738 avail = PerlIO_fill(n);
2740 avail = PerlIO_get_cnt(n);
2743 if (!PerlIO_error(n) && PerlIO_eof(n))
2749 STDCHAR *ptr = PerlIO_get_ptr(n);
2750 SSize_t cnt = avail;
2751 if (avail > b->bufsiz)
2753 Copy(ptr,b->buf,avail,STDCHAR);
2754 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2759 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2764 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2766 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2769 b->end = b->buf+avail;
2770 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2775 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2777 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2782 return PerlIOBase_read(f,vbuf,count);
2788 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2790 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2791 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2794 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2800 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2802 avail = (b->ptr - b->buf);
2807 b->end = b->buf + avail;
2809 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2810 b->posn -= b->bufsiz;
2812 if (avail > (SSize_t) count)
2820 Copy(buf,b->ptr,avail,STDCHAR);
2824 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2831 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2833 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2834 const STDCHAR *buf = (const STDCHAR *) vbuf;
2838 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2842 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2843 if ((SSize_t) count < avail)
2845 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2846 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2866 Copy(buf,b->ptr,avail,STDCHAR);
2873 if (b->ptr >= (b->buf + b->bufsiz))
2876 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2882 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2885 if ((code = PerlIO_flush(f)) == 0)
2887 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2888 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2889 code = PerlIO_seek(PerlIONext(f),offset,whence);
2892 b->posn = PerlIO_tell(PerlIONext(f));
2899 PerlIOBuf_tell(PerlIO *f)
2901 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2902 Off_t posn = b->posn;
2904 posn += (b->ptr - b->buf);
2909 PerlIOBuf_close(PerlIO *f)
2911 IV code = PerlIOBase_close(f);
2912 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2913 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2915 PerlMemShared_free(b->buf);
2918 b->ptr = b->end = b->buf;
2919 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2924 PerlIOBuf_get_ptr(PerlIO *f)
2926 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2933 PerlIOBuf_get_cnt(PerlIO *f)
2935 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2938 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2939 return (b->end - b->ptr);
2944 PerlIOBuf_get_base(PerlIO *f)
2946 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2951 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2954 b->buf = (STDCHAR *)&b->oneword;
2955 b->bufsiz = sizeof(b->oneword);
2964 PerlIOBuf_bufsiz(PerlIO *f)
2966 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2969 return (b->end - b->buf);
2973 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2975 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2979 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2982 assert(PerlIO_get_cnt(f) == cnt);
2983 assert(b->ptr >= b->buf);
2985 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2988 PerlIO_funcs PerlIO_perlio = {
3007 PerlIOBase_clearerr,
3008 PerlIOBase_setlinebuf,
3013 PerlIOBuf_set_ptrcnt,
3016 /*--------------------------------------------------------------------------------------*/
3017 /* Temp layer to hold unread chars when cannot do it any other way */
3020 PerlIOPending_fill(PerlIO *f)
3022 /* Should never happen */
3028 PerlIOPending_close(PerlIO *f)
3030 /* A tad tricky - flush pops us, then we close new top */
3032 return PerlIO_close(f);
3036 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3038 /* A tad tricky - flush pops us, then we seek new top */
3040 return PerlIO_seek(f,offset,whence);
3045 PerlIOPending_flush(PerlIO *f)
3048 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3049 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3051 PerlMemShared_free(b->buf);
3054 PerlIO_pop(aTHX_ f);
3059 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3067 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3072 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3074 IV code = PerlIOBase_pushed(f,mode,arg);
3075 PerlIOl *l = PerlIOBase(f);
3076 /* Our PerlIO_fast_gets must match what we are pushed on,
3077 or sv_gets() etc. get muddled when it changes mid-string
3080 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3081 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3086 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3088 SSize_t avail = PerlIO_get_cnt(f);
3093 got = PerlIOBuf_read(f,vbuf,avail);
3094 if (got >= 0 && got < count)
3096 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3097 if (more >= 0 || got == 0)
3103 PerlIO_funcs PerlIO_pending = {
3107 PerlIOPending_pushed,
3117 PerlIOPending_close,
3118 PerlIOPending_flush,
3122 PerlIOBase_clearerr,
3123 PerlIOBase_setlinebuf,
3128 PerlIOPending_set_ptrcnt,
3133 /*--------------------------------------------------------------------------------------*/
3134 /* crlf - translation
3135 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3136 to hand back a line at a time and keeping a record of which nl we "lied" about.
3137 On write translate "\n" to CR,LF
3142 PerlIOBuf base; /* PerlIOBuf stuff */
3143 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3147 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3150 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3151 code = PerlIOBuf_pushed(f,mode,arg);
3153 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3154 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3155 PerlIOBase(f)->flags);
3162 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3164 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3170 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3171 return PerlIOBuf_unread(f,vbuf,count);
3174 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3175 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3177 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3183 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3185 b->end = b->ptr = b->buf + b->bufsiz;
3186 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3187 b->posn -= b->bufsiz;
3189 while (count > 0 && b->ptr > b->buf)
3194 if (b->ptr - 2 >= b->buf)
3220 PerlIOCrlf_get_cnt(PerlIO *f)
3222 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3225 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3227 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3228 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3230 STDCHAR *nl = b->ptr;
3232 while (nl < b->end && *nl != 0xd)
3234 if (nl < b->end && *nl == 0xd)
3246 /* Not CR,LF but just CR */
3253 /* Blast - found CR as last char in buffer */
3256 /* They may not care, defer work as long as possible */
3257 return (nl - b->ptr);
3262 b->ptr++; /* say we have read it as far as flush() is concerned */
3263 b->buf++; /* Leave space an front of buffer */
3264 b->bufsiz--; /* Buffer is thus smaller */
3265 code = PerlIO_fill(f); /* Fetch some more */
3266 b->bufsiz++; /* Restore size for next time */
3267 b->buf--; /* Point at space */
3268 b->ptr = nl = b->buf; /* Which is what we hand off */
3269 b->posn--; /* Buffer starts here */
3270 *nl = 0xd; /* Fill in the CR */
3272 goto test; /* fill() call worked */
3273 /* CR at EOF - just fall through */
3278 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3284 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3286 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3287 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3288 IV flags = PerlIOBase(f)->flags;
3298 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3305 /* Test code - delete when it works ... */
3312 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3320 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3321 ptr, chk, flags, c->nl, b->end, cnt);
3328 /* They have taken what we lied about */
3335 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3339 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3341 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3342 return PerlIOBuf_write(f,vbuf,count);
3345 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3346 const STDCHAR *buf = (const STDCHAR *) vbuf;
3347 const STDCHAR *ebuf = buf+count;
3350 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3354 STDCHAR *eptr = b->buf+b->bufsiz;
3355 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3356 while (buf < ebuf && b->ptr < eptr)
3360 if ((b->ptr + 2) > eptr)
3362 /* Not room for both */
3368 *(b->ptr)++ = 0xd; /* CR */
3369 *(b->ptr)++ = 0xa; /* LF */
3371 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3390 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3392 return (buf - (STDCHAR *) vbuf);
3397 PerlIOCrlf_flush(PerlIO *f)
3399 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3405 return PerlIOBuf_flush(f);
3408 PerlIO_funcs PerlIO_crlf = {
3411 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3413 PerlIOBase_noop_ok, /* popped */
3417 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3418 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3419 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3427 PerlIOBase_clearerr,
3428 PerlIOBase_setlinebuf,
3433 PerlIOCrlf_set_ptrcnt,
3437 /*--------------------------------------------------------------------------------------*/
3438 /* mmap as "buffer" layer */
3442 PerlIOBuf base; /* PerlIOBuf stuff */
3443 Mmap_t mptr; /* Mapped address */
3444 Size_t len; /* mapped length */
3445 STDCHAR *bbuf; /* malloced buffer if map fails */
3448 static size_t page_size = 0;
3451 PerlIOMmap_map(PerlIO *f)
3454 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3455 IV flags = PerlIOBase(f)->flags;
3459 if (flags & PERLIO_F_CANREAD)
3461 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3462 int fd = PerlIO_fileno(f);
3464 code = fstat(fd,&st);
3465 if (code == 0 && S_ISREG(st.st_mode))
3467 SSize_t len = st.st_size - b->posn;
3472 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3474 SETERRNO(0,SS$_NORMAL);
3475 # ifdef _SC_PAGESIZE
3476 page_size = sysconf(_SC_PAGESIZE);
3478 page_size = sysconf(_SC_PAGE_SIZE);
3480 if ((long)page_size < 0) {
3485 (void)SvUPGRADE(error, SVt_PV);
3486 msg = SvPVx(error, n_a);
3487 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3490 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3494 # ifdef HAS_GETPAGESIZE
3495 page_size = getpagesize();
3497 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3498 page_size = PAGESIZE; /* compiletime, bad */
3502 if ((IV)page_size <= 0)
3503 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3507 /* This is a hack - should never happen - open should have set it ! */
3508 b->posn = PerlIO_tell(PerlIONext(f));
3510 posn = (b->posn / page_size) * page_size;
3511 len = st.st_size - posn;
3512 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3513 if (m->mptr && m->mptr != (Mmap_t) -1)
3515 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3516 madvise(m->mptr, len, MADV_SEQUENTIAL);
3518 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3519 madvise(m->mptr, len, MADV_WILLNEED);
3521 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3522 b->end = ((STDCHAR *)m->mptr) + len;
3523 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3534 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3536 b->ptr = b->end = b->ptr;
3545 PerlIOMmap_unmap(PerlIO *f)
3547 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3548 PerlIOBuf *b = &m->base;
3554 code = munmap(m->mptr, m->len);
3558 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3561 b->ptr = b->end = b->buf;
3562 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3568 PerlIOMmap_get_base(PerlIO *f)
3570 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3571 PerlIOBuf *b = &m->base;
3572 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3574 /* Already have a readbuffer in progress */
3579 /* We have a write buffer or flushed PerlIOBuf read buffer */
3580 m->bbuf = b->buf; /* save it in case we need it again */
3581 b->buf = NULL; /* Clear to trigger below */
3585 PerlIOMmap_map(f); /* Try and map it */
3588 /* Map did not work - recover PerlIOBuf buffer if we have one */
3592 b->ptr = b->end = b->buf;
3595 return PerlIOBuf_get_base(f);
3599 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3601 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3602 PerlIOBuf *b = &m->base;
3603 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3605 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3608 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3613 /* Loose the unwritable mapped buffer */
3615 /* If flush took the "buffer" see if we have one from before */
3616 if (!b->buf && m->bbuf)
3620 PerlIOBuf_get_base(f);
3624 return PerlIOBuf_unread(f,vbuf,count);
3628 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3630 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3631 PerlIOBuf *b = &m->base;
3632 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3634 /* No, or wrong sort of, buffer */
3637 if (PerlIOMmap_unmap(f) != 0)
3640 /* If unmap took the "buffer" see if we have one from before */
3641 if (!b->buf && m->bbuf)
3645 PerlIOBuf_get_base(f);
3649 return PerlIOBuf_write(f,vbuf,count);
3653 PerlIOMmap_flush(PerlIO *f)
3655 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3656 PerlIOBuf *b = &m->base;
3657 IV code = PerlIOBuf_flush(f);
3658 /* Now we are "synced" at PerlIOBuf level */
3663 /* Unmap the buffer */
3664 if (PerlIOMmap_unmap(f) != 0)
3669 /* We seem to have a PerlIOBuf buffer which was not mapped
3670 * remember it in case we need one later
3679 PerlIOMmap_fill(PerlIO *f)
3681 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3682 IV code = PerlIO_flush(f);
3683 if (code == 0 && !b->buf)
3685 code = PerlIOMmap_map(f);
3687 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3689 code = PerlIOBuf_fill(f);
3695 PerlIOMmap_close(PerlIO *f)
3697 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3698 PerlIOBuf *b = &m->base;
3699 IV code = PerlIO_flush(f);
3704 b->ptr = b->end = b->buf;
3706 if (PerlIOBuf_close(f) != 0)
3712 PerlIO_funcs PerlIO_mmap = {
3731 PerlIOBase_clearerr,
3732 PerlIOBase_setlinebuf,
3733 PerlIOMmap_get_base,
3737 PerlIOBuf_set_ptrcnt,
3740 #endif /* HAS_MMAP */
3747 call_atexit(PerlIO_cleanup_layers, NULL);
3752 atexit(&PerlIO_cleanup);
3764 PerlIO_stdstreams(aTHX);
3769 #undef PerlIO_stdout
3776 PerlIO_stdstreams(aTHX);
3781 #undef PerlIO_stderr
3788 PerlIO_stdstreams(aTHX);
3793 /*--------------------------------------------------------------------------------------*/
3795 #undef PerlIO_getname
3797 PerlIO_getname(PerlIO *f, char *buf)
3802 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3803 if (stdio) name = fgetname(stdio, buf);
3805 Perl_croak(aTHX_ "Don't know how to get file name");
3811 /*--------------------------------------------------------------------------------------*/
3812 /* Functions which can be called on any kind of PerlIO implemented
3818 PerlIO_getc(PerlIO *f)
3821 SSize_t count = PerlIO_read(f,buf,1);
3824 return (unsigned char) buf[0];
3829 #undef PerlIO_ungetc
3831 PerlIO_ungetc(PerlIO *f, int ch)
3836 if (PerlIO_unread(f,&buf,1) == 1)
3844 PerlIO_putc(PerlIO *f, int ch)
3847 return PerlIO_write(f,&buf,1);
3852 PerlIO_puts(PerlIO *f, const char *s)
3854 STRLEN len = strlen(s);
3855 return PerlIO_write(f,s,len);
3858 #undef PerlIO_rewind
3860 PerlIO_rewind(PerlIO *f)
3862 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3866 #undef PerlIO_vprintf
3868 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3871 SV *sv = newSVpvn("",0);
3877 Perl_va_copy(ap, apc);
3878 sv_vcatpvf(sv, fmt, &apc);
3880 sv_vcatpvf(sv, fmt, &ap);
3883 wrote = PerlIO_write(f,s,len);
3888 #undef PerlIO_printf
3890 PerlIO_printf(PerlIO *f,const char *fmt,...)
3895 result = PerlIO_vprintf(f,fmt,ap);
3900 #undef PerlIO_stdoutf
3902 PerlIO_stdoutf(const char *fmt,...)
3907 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3912 #undef PerlIO_tmpfile
3914 PerlIO_tmpfile(void)
3916 /* I have no idea how portable mkstemp() is ... */
3917 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3920 FILE *stdio = PerlSIO_tmpfile();
3923 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3929 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3930 int fd = mkstemp(SvPVX(sv));
3934 f = PerlIO_fdopen(fd,"w+");
3937 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3939 PerlLIO_unlink(SvPVX(sv));
3949 #endif /* USE_SFIO */
3950 #endif /* PERLIO_IS_STDIO */
3952 /*======================================================================================*/
3953 /* Now some functions in terms of above which may be needed even if
3954 we are not in true PerlIO mode
3958 #undef PerlIO_setpos
3960 PerlIO_setpos(PerlIO *f, SV *pos)
3966 Off_t *posn = (Off_t *) SvPV(pos,len);
3967 if (f && len == sizeof(Off_t))
3968 return PerlIO_seek(f,*posn,SEEK_SET);
3970 SETERRNO(EINVAL,SS$_IVCHAN);
3974 #undef PerlIO_setpos
3976 PerlIO_setpos(PerlIO *f, SV *pos)
3982 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3983 if (f && len == sizeof(Fpos_t))
3985 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3986 return fsetpos64(f, fpos);
3988 return fsetpos(f, fpos);
3992 SETERRNO(EINVAL,SS$_IVCHAN);
3998 #undef PerlIO_getpos
4000 PerlIO_getpos(PerlIO *f, SV *pos)
4003 Off_t posn = PerlIO_tell(f);
4004 sv_setpvn(pos,(char *)&posn,sizeof(posn));
4005 return (posn == (Off_t)-1) ? -1 : 0;
4008 #undef PerlIO_getpos
4010 PerlIO_getpos(PerlIO *f, SV *pos)
4015 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4016 code = fgetpos64(f, &fpos);
4018 code = fgetpos(f, &fpos);
4020 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4025 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4028 vprintf(char *pat, char *args)
4030 _doprnt(pat, args, stdout);
4031 return 0; /* wrong, but perl doesn't use the return value */
4035 vfprintf(FILE *fd, char *pat, char *args)
4037 _doprnt(pat, args, fd);
4038 return 0; /* wrong, but perl doesn't use the return value */
4043 #ifndef PerlIO_vsprintf
4045 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4047 int val = vsprintf(s, fmt, ap);
4050 if (strlen(s) >= (STRLEN)n)
4053 (void)PerlIO_puts(Perl_error_log,
4054 "panic: sprintf overflow - memory corrupted!\n");
4062 #ifndef PerlIO_sprintf
4064 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4069 result = PerlIO_vsprintf(s, n, fmt, ap);