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)
411 if (list->cur >= list->len)
415 Renew(list->array,list->len,PerlIO_pair_t);
417 New('l',list->array,list->len,PerlIO_pair_t);
419 p = &(list->array[list->cur++]);
421 if ((p->arg = arg)) {
428 PerlIO_cleanup_layers(pTHXo_ void *data)
431 PerlIO_known_layers = Nullhv;
432 PerlIO_def_layerlist = Nullav;
440 PerlIO_cleantable(aTHX_ &_perlio);
444 PerlIO_destruct(pTHX)
446 PerlIO **table = &_perlio;
451 table = (PerlIO **)(f++);
452 for (i=1; i < PERLIO_TABLE_SIZE; i++)
458 if (l->tab->kind & PERLIO_K_DESTRUCT)
460 PerlIO_debug("Destruct popping %s\n",l->tab->name);
475 PerlIO_pop(pTHX_ PerlIO *f)
480 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
483 /* If popped returns non-zero do not free its layer structure
484 it has either done so itself, or it is shared and still in use
486 if ((*l->tab->Popped)(f) != 0)
490 PerlMemShared_free(l);
494 /*--------------------------------------------------------------------------------------*/
495 /* XS Interface for perl code */
498 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
501 if ((SSize_t) len <= 0)
503 for (i=0; i < PerlIO_known_layers->cur; i++)
505 PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
506 if (memEQ(f->name,name,len))
508 PerlIO_debug("%.*s => %p\n",(int)len,name,f);
512 if (load && PL_subname && PerlIO_def_layerlist && PerlIO_def_layerlist->cur >= 2)
514 SV *pkgsv = newSVpvn("PerlIO",6);
515 SV *layer = newSVpvn(name,len);
517 /* The two SVs are magically freed by load_module */
518 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
520 return PerlIO_find_layer(aTHX_ name,len,0);
522 PerlIO_debug("Cannot find %.*s\n",(int)len,name);
526 #ifdef USE_ATTRIBUTES_FOR_PERLIO
529 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
533 IO *io = GvIOn((GV *)SvRV(sv));
534 PerlIO *ifp = IoIFP(io);
535 PerlIO *ofp = IoOFP(io);
536 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
542 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
546 IO *io = GvIOn((GV *)SvRV(sv));
547 PerlIO *ifp = IoIFP(io);
548 PerlIO *ofp = IoOFP(io);
549 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
555 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
557 Perl_warn(aTHX_ "clear %"SVf,sv);
562 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
564 Perl_warn(aTHX_ "free %"SVf,sv);
568 MGVTBL perlio_vtab = {
576 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
579 SV *sv = SvRV(ST(1));
584 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
586 mg = mg_find(sv, PERL_MAGIC_ext);
587 mg->mg_virtual = &perlio_vtab;
589 Perl_warn(aTHX_ "attrib %"SVf,sv);
590 for (i=2; i < items; i++)
593 const char *name = SvPV(ST(i),len);
594 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
597 av_push(av,SvREFCNT_inc(layer));
609 #endif /* USE_ATTIBUTES_FOR_PERLIO */
612 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
614 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
615 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
619 XS(XS_PerlIO__Layer__find)
623 Perl_croak(aTHX_ "Usage class->find(name[,load])");
627 char *name = SvPV(ST(1),len);
628 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
629 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
630 ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
636 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
638 if (!PerlIO_known_layers)
639 PerlIO_known_layers = PerlIO_list_alloc();
640 PerlIO_list_push(PerlIO_known_layers,tab,Nullsv);
641 PerlIO_debug("define %s %p\n",tab->name,tab);
645 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
649 const char *s = names;
652 while (isSPACE(*s) || *s == ':')
658 const char *as = Nullch;
662 /* Message is consistent with how attribute lists are passed.
663 Even though this means "foo : : bar" is seen as an invalid separator
665 char q = ((*s == '\'') ? '"' : '\'');
666 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
672 } while (isALNUM(*e));
690 /* It's a nul terminated string, not allowed to \ the terminating null.
691 Anything other character is passed over. */
699 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
709 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s,llen,1);
712 PerlIO_list_push(av, layer, (as) ? newSVpvn(as,alen) : &PL_sv_undef);
715 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
727 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
729 PerlIO_funcs *tab = &PerlIO_perlio;
730 if (O_BINARY != O_TEXT)
736 if (PerlIO_stdio.Set_ptrcnt)
741 PerlIO_debug("Pushing %s\n",tab->name);
742 PerlIO_list_push(av,PerlIO_find_layer(aTHX_ tab->name,0,0),&PL_sv_undef);
746 PerlIO_arg_fetch(PerlIO_list_t *av,IV n)
748 return av->array[n].arg;
752 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
754 if (n >= 0 && n < av->cur)
756 PerlIO_debug("Layer %"IVdf" is %s\n",n,av->array[n].funcs->name);
757 return av->array[n].funcs;
760 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
765 PerlIO_default_layers(pTHX)
767 if (!PerlIO_def_layerlist)
769 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
770 PerlIO_funcs *osLayer = &PerlIO_unix;
771 PerlIO_def_layerlist = PerlIO_list_alloc();
772 PerlIO_define_layer(aTHX_ &PerlIO_unix);
774 PerlIO_define_layer(aTHX_ &PerlIO_win32);
776 osLayer = &PerlIO_win32;
779 PerlIO_define_layer(aTHX_ &PerlIO_raw);
780 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
781 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
782 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
784 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
786 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
787 PerlIO_define_layer(aTHX_ &PerlIO_byte);
788 PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ osLayer->name,0,0),&PL_sv_undef);
791 PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
795 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
798 if (PerlIO_def_layerlist->cur < 2)
800 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
802 return PerlIO_def_layerlist;
806 Perl_boot_core_PerlIO(pTHX)
808 #ifdef USE_ATTRIBUTES_FOR_PERLIO
809 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
811 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
815 PerlIO_default_layer(pTHX_ I32 n)
817 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
820 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
823 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
824 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
827 PerlIO_stdstreams(pTHX)
831 PerlIO_allocate(aTHX);
832 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
833 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
834 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
839 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
842 l = PerlMemShared_calloc(tab->size,sizeof(char));
845 Zero(l,tab->size,char);
849 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
850 (mode) ? mode : "(Null)",arg);
851 if ((*l->tab->Pushed)(f,mode,arg) != 0)
861 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
875 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
877 /* Remove the dummy layer */
880 /* Pop back to bottom layer */
884 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
892 /* Nothing bellow - push unix on top then remove it */
893 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
895 PerlIO_pop(aTHX_ PerlIONext(f));
900 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
907 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
909 IV max = layers->cur;
913 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
916 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
928 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
933 PerlIO_list_t *layers = PerlIO_list_alloc();
934 code = PerlIO_parse_layers(aTHX_ layers,names);
937 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
939 PerlIO_list_free(layers);
945 /*--------------------------------------------------------------------------------------*/
946 /* Given the abstraction above the public API functions */
949 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
951 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
952 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
953 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
958 if (PerlIOBase(top)->tab == &PerlIO_crlf)
961 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
964 top = PerlIONext(top);
967 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
972 PerlIO__close(PerlIO *f)
975 return (*PerlIOBase(f)->tab->Close)(f);
978 SETERRNO(EBADF,SS$_IVCHAN);
983 #undef PerlIO_fdupopen
985 PerlIO_fdupopen(pTHX_ PerlIO *f)
990 int fd = PerlLIO_dup(PerlIO_fileno(f));
991 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
994 Off_t posn = PerlIO_tell(f);
995 PerlIO_seek(new,posn,SEEK_SET);
1001 SETERRNO(EBADF,SS$_IVCHAN);
1008 PerlIO_close(PerlIO *f)
1014 code = (*PerlIOBase(f)->tab->Close)(f);
1017 PerlIO_pop(aTHX_ f);
1023 #undef PerlIO_fileno
1025 PerlIO_fileno(PerlIO *f)
1028 return (*PerlIOBase(f)->tab->Fileno)(f);
1031 SETERRNO(EBADF,SS$_IVCHAN);
1037 PerlIO_context_layers(pTHX_ const char *mode)
1039 const char *type = NULL;
1040 /* Need to supply default layer info from open.pm */
1043 SV *layers = PL_curcop->cop_io;
1047 type = SvPV(layers,len);
1048 if (type && mode[0] != 'r')
1050 /* Skip to write part */
1051 const char *s = strchr(type,0);
1052 if (s && (s-type) < len)
1062 static PerlIO_funcs *
1063 PerlIO_layer_from_ref(pTHX_ SV *sv)
1065 /* For any scalar type load the handler which is bundled with perl */
1066 if (SvTYPE(sv) < SVt_PVAV)
1067 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1069 /* For other types allow if layer is known but don't try and load it */
1073 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1075 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1077 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1079 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1085 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1087 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1090 PerlIO_stdstreams(aTHX);
1094 /* If it is a reference but not an object see if we have a handler for it */
1095 if (SvROK(arg) && !sv_isobject(arg))
1097 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1100 def = PerlIO_list_alloc();
1101 PerlIO_list_push(def,handler,&PL_sv_undef);
1104 /* Don't fail if handler cannot be found
1105 * :Via(...) etc. may do something sensible
1106 * else we will just stringfy and open resulting string.
1111 layers = PerlIO_context_layers(aTHX_ mode);
1112 if (layers && *layers)
1118 av = PerlIO_list_alloc();
1119 for (i=0; i < def->cur; i++)
1121 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1128 PerlIO_parse_layers(aTHX_ av,layers);
1140 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1142 if (!f && narg == 1 && *args == &PL_sv_undef)
1144 if ((f = PerlIO_tmpfile()))
1147 layers = PerlIO_context_layers(aTHX_ mode);
1148 if (layers && *layers)
1149 PerlIO_apply_layers(aTHX_ f,mode,layers);
1154 PerlIO_list_t *layera = NULL;
1156 PerlIO_funcs *tab = NULL;
1159 /* This is "reopen" - it is not tested as perl does not use it yet */
1161 layera = PerlIO_list_alloc();
1164 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1165 PerlIO_list_push(layera,l->tab,arg);
1166 l = *PerlIONext(&l);
1171 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1173 /* Start at "top" of layer stack */
1177 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1187 /* Found that layer 'n' can do opens - call it */
1188 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1189 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1190 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1193 if (n+1 < layera->cur)
1195 /* More layers above the one that we used to open - apply them now */
1196 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1203 PerlIO_list_free(layera);
1209 #undef PerlIO_fdopen
1211 PerlIO_fdopen(int fd, const char *mode)
1214 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1219 PerlIO_open(const char *path, const char *mode)
1222 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1223 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1226 #undef PerlIO_reopen
1228 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1231 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1232 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1237 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1240 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1243 SETERRNO(EBADF,SS$_IVCHAN);
1248 #undef PerlIO_unread
1250 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1253 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1256 SETERRNO(EBADF,SS$_IVCHAN);
1263 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1266 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1269 SETERRNO(EBADF,SS$_IVCHAN);
1276 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1279 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1282 SETERRNO(EBADF,SS$_IVCHAN);
1289 PerlIO_tell(PerlIO *f)
1292 return (*PerlIOBase(f)->tab->Tell)(f);
1295 SETERRNO(EBADF,SS$_IVCHAN);
1302 PerlIO_flush(PerlIO *f)
1308 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1309 if (tab && tab->Flush)
1311 return (*tab->Flush)(f);
1315 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1316 SETERRNO(EBADF,SS$_IVCHAN);
1322 PerlIO_debug("Cannot flush f=%p\n",f);
1323 SETERRNO(EBADF,SS$_IVCHAN);
1329 /* Is it good API design to do flush-all on NULL,
1330 * a potentially errorneous input? Maybe some magical
1331 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1332 * Yes, stdio does similar things on fflush(NULL),
1333 * but should we be bound by their design decisions?
1335 PerlIO **table = &_perlio;
1337 while ((f = *table))
1340 table = (PerlIO **)(f++);
1341 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1343 if (*f && PerlIO_flush(f) != 0)
1353 PerlIOBase_flush_linebuf()
1355 PerlIO **table = &_perlio;
1357 while ((f = *table))
1360 table = (PerlIO **)(f++);
1361 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1363 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1364 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1373 PerlIO_fill(PerlIO *f)
1376 return (*PerlIOBase(f)->tab->Fill)(f);
1379 SETERRNO(EBADF,SS$_IVCHAN);
1384 #undef PerlIO_isutf8
1386 PerlIO_isutf8(PerlIO *f)
1389 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1392 SETERRNO(EBADF,SS$_IVCHAN);
1399 PerlIO_eof(PerlIO *f)
1402 return (*PerlIOBase(f)->tab->Eof)(f);
1405 SETERRNO(EBADF,SS$_IVCHAN);
1412 PerlIO_error(PerlIO *f)
1415 return (*PerlIOBase(f)->tab->Error)(f);
1418 SETERRNO(EBADF,SS$_IVCHAN);
1423 #undef PerlIO_clearerr
1425 PerlIO_clearerr(PerlIO *f)
1428 (*PerlIOBase(f)->tab->Clearerr)(f);
1430 SETERRNO(EBADF,SS$_IVCHAN);
1433 #undef PerlIO_setlinebuf
1435 PerlIO_setlinebuf(PerlIO *f)
1438 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1440 SETERRNO(EBADF,SS$_IVCHAN);
1443 #undef PerlIO_has_base
1445 PerlIO_has_base(PerlIO *f)
1447 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1451 #undef PerlIO_fast_gets
1453 PerlIO_fast_gets(PerlIO *f)
1455 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1457 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1458 return (tab->Set_ptrcnt != NULL);
1463 #undef PerlIO_has_cntptr
1465 PerlIO_has_cntptr(PerlIO *f)
1469 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1470 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1475 #undef PerlIO_canset_cnt
1477 PerlIO_canset_cnt(PerlIO *f)
1481 PerlIOl *l = PerlIOBase(f);
1482 return (l->tab->Set_ptrcnt != NULL);
1487 #undef PerlIO_get_base
1489 PerlIO_get_base(PerlIO *f)
1492 return (*PerlIOBase(f)->tab->Get_base)(f);
1496 #undef PerlIO_get_bufsiz
1498 PerlIO_get_bufsiz(PerlIO *f)
1501 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1505 #undef PerlIO_get_ptr
1507 PerlIO_get_ptr(PerlIO *f)
1509 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1510 if (tab->Get_ptr == NULL)
1512 return (*tab->Get_ptr)(f);
1515 #undef PerlIO_get_cnt
1517 PerlIO_get_cnt(PerlIO *f)
1519 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1520 if (tab->Get_cnt == NULL)
1522 return (*tab->Get_cnt)(f);
1525 #undef PerlIO_set_cnt
1527 PerlIO_set_cnt(PerlIO *f,int cnt)
1529 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1532 #undef PerlIO_set_ptrcnt
1534 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1536 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1537 if (tab->Set_ptrcnt == NULL)
1540 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1542 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1545 /*--------------------------------------------------------------------------------------*/
1546 /* utf8 and raw dummy layers */
1549 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1554 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1555 PerlIO_pop(aTHX_ f);
1556 if (tab->kind & PERLIO_K_UTF8)
1557 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1559 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1565 PerlIO_funcs PerlIO_utf8 = {
1568 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1586 NULL, /* get_base */
1587 NULL, /* get_bufsiz */
1590 NULL, /* set_ptrcnt */
1593 PerlIO_funcs PerlIO_byte = {
1614 NULL, /* get_base */
1615 NULL, /* get_bufsiz */
1618 NULL, /* set_ptrcnt */
1622 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)
1624 PerlIO_funcs *tab = PerlIO_default_btm();
1625 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1628 PerlIO_funcs PerlIO_raw = {
1649 NULL, /* get_base */
1650 NULL, /* get_bufsiz */
1653 NULL, /* set_ptrcnt */
1655 /*--------------------------------------------------------------------------------------*/
1656 /*--------------------------------------------------------------------------------------*/
1657 /* "Methods" of the "base class" */
1660 PerlIOBase_fileno(PerlIO *f)
1662 return PerlIO_fileno(PerlIONext(f));
1666 PerlIO_modestr(PerlIO *f,char *buf)
1669 IV flags = PerlIOBase(f)->flags;
1670 if (flags & PERLIO_F_APPEND)
1673 if (flags & PERLIO_F_CANREAD)
1678 else if (flags & PERLIO_F_CANREAD)
1681 if (flags & PERLIO_F_CANWRITE)
1684 else if (flags & PERLIO_F_CANWRITE)
1687 if (flags & PERLIO_F_CANREAD)
1692 #if O_TEXT != O_BINARY
1693 if (!(flags & PERLIO_F_CRLF))
1701 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1703 PerlIOl *l = PerlIOBase(f);
1705 const char *omode = mode;
1708 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1709 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1710 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1711 if (tab->Set_ptrcnt != NULL)
1712 l->flags |= PERLIO_F_FASTGETS;
1715 if (*mode == '#' || *mode == 'I')
1720 l->flags |= PERLIO_F_CANREAD;
1723 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1726 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1729 SETERRNO(EINVAL,LIB$_INVARG);
1737 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1740 l->flags &= ~PERLIO_F_CRLF;
1743 l->flags |= PERLIO_F_CRLF;
1746 SETERRNO(EINVAL,LIB$_INVARG);
1755 l->flags |= l->next->flags &
1756 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1760 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1761 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1762 l->flags,PerlIO_modestr(f,temp));
1768 PerlIOBase_popped(PerlIO *f)
1774 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1777 /* Save the position as current head considers it */
1778 Off_t old = PerlIO_tell(f);
1780 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1781 PerlIOSelf(f,PerlIOBuf)->posn = old;
1782 done = PerlIOBuf_unread(f,vbuf,count);
1787 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1789 STDCHAR *buf = (STDCHAR *) vbuf;
1792 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1796 SSize_t avail = PerlIO_get_cnt(f);
1799 take = (count < avail) ? count : avail;
1802 STDCHAR *ptr = PerlIO_get_ptr(f);
1803 Copy(ptr,buf,take,STDCHAR);
1804 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1808 if (count > 0 && avail <= 0)
1810 if (PerlIO_fill(f) != 0)
1814 return (buf - (STDCHAR *) vbuf);
1820 PerlIOBase_noop_ok(PerlIO *f)
1826 PerlIOBase_noop_fail(PerlIO *f)
1832 PerlIOBase_close(PerlIO *f)
1835 PerlIO *n = PerlIONext(f);
1836 if (PerlIO_flush(f) != 0)
1838 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1840 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1845 PerlIOBase_eof(PerlIO *f)
1849 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1855 PerlIOBase_error(PerlIO *f)
1859 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1865 PerlIOBase_clearerr(PerlIO *f)
1869 PerlIO *n = PerlIONext(f);
1870 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1877 PerlIOBase_setlinebuf(PerlIO *f)
1881 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1885 /*--------------------------------------------------------------------------------------*/
1886 /* Bottom-most level for UNIX-like case */
1890 struct _PerlIO base; /* The generic part */
1891 int fd; /* UNIX like file descriptor */
1892 int oflags; /* open/fcntl flags */
1896 PerlIOUnix_oflags(const char *mode)
1899 if (*mode == 'I' || *mode == '#')
1913 oflags = O_CREAT|O_TRUNC;
1924 oflags = O_CREAT|O_APPEND;
1940 else if (*mode == 't')
1943 oflags &= ~O_BINARY;
1946 /* Always open in binary mode */
1948 if (*mode || oflags == -1)
1950 SETERRNO(EINVAL,LIB$_INVARG);
1957 PerlIOUnix_fileno(PerlIO *f)
1959 return PerlIOSelf(f,PerlIOUnix)->fd;
1963 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1965 IV code = PerlIOBase_pushed(f,mode,arg);
1968 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1969 s->fd = PerlIO_fileno(PerlIONext(f));
1970 s->oflags = PerlIOUnix_oflags(mode);
1972 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1977 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)
1981 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1982 (*PerlIOBase(f)->tab->Close)(f);
1986 char *path = SvPV_nolen(*args);
1991 imode = PerlIOUnix_oflags(mode);
1996 fd = PerlLIO_open3(path,imode,perm);
2006 f = PerlIO_allocate(aTHX);
2007 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2010 s = PerlIOSelf(f,PerlIOUnix);
2013 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2020 /* FIXME: pop layers ??? */
2027 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2030 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2031 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2035 SSize_t len = PerlLIO_read(fd,vbuf,count);
2036 if (len >= 0 || errno != EINTR)
2039 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2040 else if (len == 0 && count != 0)
2041 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2049 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2052 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2055 SSize_t len = PerlLIO_write(fd,vbuf,count);
2056 if (len >= 0 || errno != EINTR)
2059 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2067 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2070 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2071 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2072 return (new == (Off_t) -1) ? -1 : 0;
2076 PerlIOUnix_tell(PerlIO *f)
2079 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2083 PerlIOUnix_close(PerlIO *f)
2086 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2088 while (PerlLIO_close(fd) != 0)
2099 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2104 PerlIO_funcs PerlIO_unix = {
2119 PerlIOBase_noop_ok, /* flush */
2120 PerlIOBase_noop_fail, /* fill */
2123 PerlIOBase_clearerr,
2124 PerlIOBase_setlinebuf,
2125 NULL, /* get_base */
2126 NULL, /* get_bufsiz */
2129 NULL, /* set_ptrcnt */
2132 /*--------------------------------------------------------------------------------------*/
2133 /* stdio as a layer */
2137 struct _PerlIO base;
2138 FILE * stdio; /* The stream */
2142 PerlIOStdio_fileno(PerlIO *f)
2145 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2149 PerlIOStdio_mode(const char *mode,char *tmode)
2156 if (O_BINARY != O_TEXT)
2164 /* This isn't used yet ... */
2166 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2171 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2173 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2179 return PerlIOBase_pushed(f,mode,arg);
2182 #undef PerlIO_importFILE
2184 PerlIO_importFILE(FILE *stdio, int fl)
2190 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2197 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)
2202 char *path = SvPV_nolen(*args);
2203 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2204 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2214 char *path = SvPV_nolen(*args);
2218 fd = PerlLIO_open3(path,imode,perm);
2222 FILE *stdio = PerlSIO_fopen(path,mode);
2225 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2226 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2247 stdio = PerlSIO_stdin;
2250 stdio = PerlSIO_stdout;
2253 stdio = PerlSIO_stderr;
2259 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2263 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2273 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2276 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2280 STDCHAR *buf = (STDCHAR *) vbuf;
2281 /* Perl is expecting PerlIO_getc() to fill the buffer
2282 * Linux's stdio does not do that for fread()
2284 int ch = PerlSIO_fgetc(s);
2292 got = PerlSIO_fread(vbuf,1,count,s);
2297 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2300 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2301 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2305 int ch = *buf-- & 0xff;
2306 if (PerlSIO_ungetc(ch,s) != ch)
2315 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2318 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2322 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2325 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2326 return PerlSIO_fseek(stdio,offset,whence);
2330 PerlIOStdio_tell(PerlIO *f)
2333 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2334 return PerlSIO_ftell(stdio);
2338 PerlIOStdio_close(PerlIO *f)
2341 #ifdef SOCKS5_VERSION_NAME
2343 Sock_size_t optlen = sizeof(int);
2345 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2347 #ifdef SOCKS5_VERSION_NAME
2348 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2349 PerlSIO_fclose(stdio) :
2350 close(PerlIO_fileno(f))
2352 PerlSIO_fclose(stdio)
2359 PerlIOStdio_flush(PerlIO *f)
2362 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2363 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2365 return PerlSIO_fflush(stdio);
2370 /* FIXME: This discards ungetc() and pre-read stuff which is
2371 not right if this is just a "sync" from a layer above
2372 Suspect right design is to do _this_ but not have layer above
2373 flush this layer read-to-read
2375 /* Not writeable - sync by attempting a seek */
2377 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2385 PerlIOStdio_fill(PerlIO *f)
2388 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2390 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2391 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2393 if (PerlSIO_fflush(stdio) != 0)
2396 c = PerlSIO_fgetc(stdio);
2397 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2403 PerlIOStdio_eof(PerlIO *f)
2406 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2410 PerlIOStdio_error(PerlIO *f)
2413 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2417 PerlIOStdio_clearerr(PerlIO *f)
2420 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2424 PerlIOStdio_setlinebuf(PerlIO *f)
2427 #ifdef HAS_SETLINEBUF
2428 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2430 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2436 PerlIOStdio_get_base(PerlIO *f)
2439 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2440 return PerlSIO_get_base(stdio);
2444 PerlIOStdio_get_bufsiz(PerlIO *f)
2447 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2448 return PerlSIO_get_bufsiz(stdio);
2452 #ifdef USE_STDIO_PTR
2454 PerlIOStdio_get_ptr(PerlIO *f)
2457 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2458 return PerlSIO_get_ptr(stdio);
2462 PerlIOStdio_get_cnt(PerlIO *f)
2465 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2466 return PerlSIO_get_cnt(stdio);
2470 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2472 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2476 #ifdef STDIO_PTR_LVALUE
2477 PerlSIO_set_ptr(stdio,ptr);
2478 #ifdef STDIO_PTR_LVAL_SETS_CNT
2479 if (PerlSIO_get_cnt(stdio) != (cnt))
2482 assert(PerlSIO_get_cnt(stdio) == (cnt));
2485 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2486 /* Setting ptr _does_ change cnt - we are done */
2489 #else /* STDIO_PTR_LVALUE */
2491 #endif /* STDIO_PTR_LVALUE */
2493 /* Now (or only) set cnt */
2494 #ifdef STDIO_CNT_LVALUE
2495 PerlSIO_set_cnt(stdio,cnt);
2496 #else /* STDIO_CNT_LVALUE */
2497 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2498 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2499 #else /* STDIO_PTR_LVAL_SETS_CNT */
2501 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2502 #endif /* STDIO_CNT_LVALUE */
2507 PerlIO_funcs PerlIO_stdio = {
2509 sizeof(PerlIOStdio),
2526 PerlIOStdio_clearerr,
2527 PerlIOStdio_setlinebuf,
2529 PerlIOStdio_get_base,
2530 PerlIOStdio_get_bufsiz,
2535 #ifdef USE_STDIO_PTR
2536 PerlIOStdio_get_ptr,
2537 PerlIOStdio_get_cnt,
2538 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2539 PerlIOStdio_set_ptrcnt
2540 #else /* STDIO_PTR_LVALUE */
2542 #endif /* STDIO_PTR_LVALUE */
2543 #else /* USE_STDIO_PTR */
2547 #endif /* USE_STDIO_PTR */
2550 #undef PerlIO_exportFILE
2552 PerlIO_exportFILE(PerlIO *f, int fl)
2556 stdio = fdopen(PerlIO_fileno(f),"r+");
2560 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2566 #undef PerlIO_findFILE
2568 PerlIO_findFILE(PerlIO *f)
2573 if (l->tab == &PerlIO_stdio)
2575 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2578 l = *PerlIONext(&l);
2580 return PerlIO_exportFILE(f,0);
2583 #undef PerlIO_releaseFILE
2585 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2589 /*--------------------------------------------------------------------------------------*/
2590 /* perlio buffer layer */
2593 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2596 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2597 int fd = PerlIO_fileno(f);
2599 if (fd >= 0 && PerlLIO_isatty(fd))
2601 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2603 posn = PerlIO_tell(PerlIONext(f));
2604 if (posn != (Off_t) -1)
2608 return PerlIOBase_pushed(f,mode,arg);
2612 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)
2616 PerlIO *next = PerlIONext(f);
2617 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2618 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2619 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2626 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2633 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2636 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2637 fd = PerlIO_fileno(f);
2638 #if O_BINARY != O_TEXT
2639 /* do something about failing setmode()? --jhi */
2640 PerlLIO_setmode(fd , O_BINARY);
2642 if (init && fd == 2)
2644 /* Initial stderr is unbuffered */
2645 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2652 /* This "flush" is akin to sfio's sync in that it handles files in either
2656 PerlIOBuf_flush(PerlIO *f)
2658 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2660 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2662 /* write() the buffer */
2663 STDCHAR *buf = b->buf;
2665 PerlIO *n = PerlIONext(f);
2668 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2673 else if (count < 0 || PerlIO_error(n))
2675 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2680 b->posn += (p - buf);
2682 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2684 STDCHAR *buf = PerlIO_get_base(f);
2685 /* Note position change */
2686 b->posn += (b->ptr - buf);
2687 if (b->ptr < b->end)
2689 /* We did not consume all of it */
2690 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2692 b->posn = PerlIO_tell(PerlIONext(f));
2696 b->ptr = b->end = b->buf;
2697 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2698 /* FIXME: Is this right for read case ? */
2699 if (PerlIO_flush(PerlIONext(f)) != 0)
2705 PerlIOBuf_fill(PerlIO *f)
2707 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2708 PerlIO *n = PerlIONext(f);
2710 /* FIXME: doing the down-stream flush is a bad idea if it causes
2711 pre-read data in stdio buffer to be discarded
2712 but this is too simplistic - as it skips _our_ hosekeeping
2713 and breaks tell tests.
2714 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2718 if (PerlIO_flush(f) != 0)
2720 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2721 PerlIOBase_flush_linebuf();
2724 PerlIO_get_base(f); /* allocate via vtable */
2726 b->ptr = b->end = b->buf;
2727 if (PerlIO_fast_gets(n))
2729 /* Layer below is also buffered
2730 * We do _NOT_ want to call its ->Read() because that will loop
2731 * till it gets what we asked for which may hang on a pipe etc.
2732 * Instead take anything it has to hand, or ask it to fill _once_.
2734 avail = PerlIO_get_cnt(n);
2737 avail = PerlIO_fill(n);
2739 avail = PerlIO_get_cnt(n);
2742 if (!PerlIO_error(n) && PerlIO_eof(n))
2748 STDCHAR *ptr = PerlIO_get_ptr(n);
2749 SSize_t cnt = avail;
2750 if (avail > b->bufsiz)
2752 Copy(ptr,b->buf,avail,STDCHAR);
2753 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2758 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2763 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2765 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2768 b->end = b->buf+avail;
2769 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2774 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2776 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2781 return PerlIOBase_read(f,vbuf,count);
2787 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2789 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2790 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2793 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2799 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2801 /* Buffer is already a read buffer, we can overwrite any chars
2802 which have been read back to buffer start
2804 avail = (b->ptr - b->buf);
2808 /* Buffer is idle, set it up so whole buffer is available for unread */
2810 b->end = b->buf + avail;
2812 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2813 /* Buffer extends _back_ from where we are now */
2814 b->posn -= b->bufsiz;
2816 if (avail > (SSize_t) count)
2818 /* If we have space for more than count, just move count */
2825 /* In simple stdio-like ungetc() case chars will be already there */
2828 Copy(buf,b->ptr,avail,STDCHAR);
2832 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2839 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2841 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2842 const STDCHAR *buf = (const STDCHAR *) vbuf;
2846 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2850 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2851 if ((SSize_t) count < avail)
2853 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2854 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2874 Copy(buf,b->ptr,avail,STDCHAR);
2881 if (b->ptr >= (b->buf + b->bufsiz))
2884 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2890 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2893 if ((code = PerlIO_flush(f)) == 0)
2895 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2896 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2897 code = PerlIO_seek(PerlIONext(f),offset,whence);
2900 b->posn = PerlIO_tell(PerlIONext(f));
2907 PerlIOBuf_tell(PerlIO *f)
2909 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2910 /* b->posn is file position where b->buf was read, or will be written */
2911 Off_t posn = b->posn;
2914 /* If buffer is valid adjust position by amount in buffer */
2915 posn += (b->ptr - b->buf);
2921 PerlIOBuf_close(PerlIO *f)
2923 IV code = PerlIOBase_close(f);
2924 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2925 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2927 PerlMemShared_free(b->buf);
2930 b->ptr = b->end = b->buf;
2931 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2936 PerlIOBuf_get_ptr(PerlIO *f)
2938 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2945 PerlIOBuf_get_cnt(PerlIO *f)
2947 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2950 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2951 return (b->end - b->ptr);
2956 PerlIOBuf_get_base(PerlIO *f)
2958 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2963 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2966 b->buf = (STDCHAR *)&b->oneword;
2967 b->bufsiz = sizeof(b->oneword);
2976 PerlIOBuf_bufsiz(PerlIO *f)
2978 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2981 return (b->end - b->buf);
2985 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2987 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2991 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2994 assert(PerlIO_get_cnt(f) == cnt);
2995 assert(b->ptr >= b->buf);
2997 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3000 PerlIO_funcs PerlIO_perlio = {
3019 PerlIOBase_clearerr,
3020 PerlIOBase_setlinebuf,
3025 PerlIOBuf_set_ptrcnt,
3028 /*--------------------------------------------------------------------------------------*/
3029 /* Temp layer to hold unread chars when cannot do it any other way */
3032 PerlIOPending_fill(PerlIO *f)
3034 /* Should never happen */
3040 PerlIOPending_close(PerlIO *f)
3042 /* A tad tricky - flush pops us, then we close new top */
3044 return PerlIO_close(f);
3048 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3050 /* A tad tricky - flush pops us, then we seek new top */
3052 return PerlIO_seek(f,offset,whence);
3057 PerlIOPending_flush(PerlIO *f)
3060 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3061 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3063 PerlMemShared_free(b->buf);
3066 PerlIO_pop(aTHX_ f);
3071 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3079 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3084 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3086 IV code = PerlIOBase_pushed(f,mode,arg);
3087 PerlIOl *l = PerlIOBase(f);
3088 /* Our PerlIO_fast_gets must match what we are pushed on,
3089 or sv_gets() etc. get muddled when it changes mid-string
3092 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3093 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3098 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3100 SSize_t avail = PerlIO_get_cnt(f);
3105 got = PerlIOBuf_read(f,vbuf,avail);
3106 if (got >= 0 && got < count)
3108 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3109 if (more >= 0 || got == 0)
3115 PerlIO_funcs PerlIO_pending = {
3119 PerlIOPending_pushed,
3129 PerlIOPending_close,
3130 PerlIOPending_flush,
3134 PerlIOBase_clearerr,
3135 PerlIOBase_setlinebuf,
3140 PerlIOPending_set_ptrcnt,
3145 /*--------------------------------------------------------------------------------------*/
3146 /* crlf - translation
3147 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3148 to hand back a line at a time and keeping a record of which nl we "lied" about.
3149 On write translate "\n" to CR,LF
3154 PerlIOBuf base; /* PerlIOBuf stuff */
3155 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3159 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3162 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3163 code = PerlIOBuf_pushed(f,mode,arg);
3165 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3166 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3167 PerlIOBase(f)->flags);
3174 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3176 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3182 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3183 return PerlIOBuf_unread(f,vbuf,count);
3186 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3187 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3189 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3195 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3197 b->end = b->ptr = b->buf + b->bufsiz;
3198 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3199 b->posn -= b->bufsiz;
3201 while (count > 0 && b->ptr > b->buf)
3206 if (b->ptr - 2 >= b->buf)
3232 PerlIOCrlf_get_cnt(PerlIO *f)
3234 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3237 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3239 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3240 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3242 STDCHAR *nl = b->ptr;
3244 while (nl < b->end && *nl != 0xd)
3246 if (nl < b->end && *nl == 0xd)
3258 /* Not CR,LF but just CR */
3265 /* Blast - found CR as last char in buffer */
3268 /* They may not care, defer work as long as possible */
3269 return (nl - b->ptr);
3274 b->ptr++; /* say we have read it as far as flush() is concerned */
3275 b->buf++; /* Leave space an front of buffer */
3276 b->bufsiz--; /* Buffer is thus smaller */
3277 code = PerlIO_fill(f); /* Fetch some more */
3278 b->bufsiz++; /* Restore size for next time */
3279 b->buf--; /* Point at space */
3280 b->ptr = nl = b->buf; /* Which is what we hand off */
3281 b->posn--; /* Buffer starts here */
3282 *nl = 0xd; /* Fill in the CR */
3284 goto test; /* fill() call worked */
3285 /* CR at EOF - just fall through */
3290 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3296 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3298 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3299 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3300 IV flags = PerlIOBase(f)->flags;
3310 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3317 /* Test code - delete when it works ... */
3324 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3332 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3333 ptr, chk, flags, c->nl, b->end, cnt);
3340 /* They have taken what we lied about */
3347 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3351 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3353 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3354 return PerlIOBuf_write(f,vbuf,count);
3357 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3358 const STDCHAR *buf = (const STDCHAR *) vbuf;
3359 const STDCHAR *ebuf = buf+count;
3362 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3366 STDCHAR *eptr = b->buf+b->bufsiz;
3367 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3368 while (buf < ebuf && b->ptr < eptr)
3372 if ((b->ptr + 2) > eptr)
3374 /* Not room for both */
3380 *(b->ptr)++ = 0xd; /* CR */
3381 *(b->ptr)++ = 0xa; /* LF */
3383 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3402 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3404 return (buf - (STDCHAR *) vbuf);
3409 PerlIOCrlf_flush(PerlIO *f)
3411 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3417 return PerlIOBuf_flush(f);
3420 PerlIO_funcs PerlIO_crlf = {
3423 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3425 PerlIOBase_noop_ok, /* popped */
3429 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3430 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3431 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3439 PerlIOBase_clearerr,
3440 PerlIOBase_setlinebuf,
3445 PerlIOCrlf_set_ptrcnt,
3449 /*--------------------------------------------------------------------------------------*/
3450 /* mmap as "buffer" layer */
3454 PerlIOBuf base; /* PerlIOBuf stuff */
3455 Mmap_t mptr; /* Mapped address */
3456 Size_t len; /* mapped length */
3457 STDCHAR *bbuf; /* malloced buffer if map fails */
3460 static size_t page_size = 0;
3463 PerlIOMmap_map(PerlIO *f)
3466 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3467 IV flags = PerlIOBase(f)->flags;
3471 if (flags & PERLIO_F_CANREAD)
3473 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3474 int fd = PerlIO_fileno(f);
3476 code = fstat(fd,&st);
3477 if (code == 0 && S_ISREG(st.st_mode))
3479 SSize_t len = st.st_size - b->posn;
3484 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3486 SETERRNO(0,SS$_NORMAL);
3487 # ifdef _SC_PAGESIZE
3488 page_size = sysconf(_SC_PAGESIZE);
3490 page_size = sysconf(_SC_PAGE_SIZE);
3492 if ((long)page_size < 0) {
3497 (void)SvUPGRADE(error, SVt_PV);
3498 msg = SvPVx(error, n_a);
3499 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3502 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3506 # ifdef HAS_GETPAGESIZE
3507 page_size = getpagesize();
3509 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3510 page_size = PAGESIZE; /* compiletime, bad */
3514 if ((IV)page_size <= 0)
3515 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3519 /* This is a hack - should never happen - open should have set it ! */
3520 b->posn = PerlIO_tell(PerlIONext(f));
3522 posn = (b->posn / page_size) * page_size;
3523 len = st.st_size - posn;
3524 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3525 if (m->mptr && m->mptr != (Mmap_t) -1)
3527 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3528 madvise(m->mptr, len, MADV_SEQUENTIAL);
3530 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3531 madvise(m->mptr, len, MADV_WILLNEED);
3533 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3534 b->end = ((STDCHAR *)m->mptr) + len;
3535 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3546 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3548 b->ptr = b->end = b->ptr;
3557 PerlIOMmap_unmap(PerlIO *f)
3559 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3560 PerlIOBuf *b = &m->base;
3566 code = munmap(m->mptr, m->len);
3570 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3573 b->ptr = b->end = b->buf;
3574 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3580 PerlIOMmap_get_base(PerlIO *f)
3582 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3583 PerlIOBuf *b = &m->base;
3584 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3586 /* Already have a readbuffer in progress */
3591 /* We have a write buffer or flushed PerlIOBuf read buffer */
3592 m->bbuf = b->buf; /* save it in case we need it again */
3593 b->buf = NULL; /* Clear to trigger below */
3597 PerlIOMmap_map(f); /* Try and map it */
3600 /* Map did not work - recover PerlIOBuf buffer if we have one */
3604 b->ptr = b->end = b->buf;
3607 return PerlIOBuf_get_base(f);
3611 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3613 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3614 PerlIOBuf *b = &m->base;
3615 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3617 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3620 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3625 /* Loose the unwritable mapped buffer */
3627 /* If flush took the "buffer" see if we have one from before */
3628 if (!b->buf && m->bbuf)
3632 PerlIOBuf_get_base(f);
3636 return PerlIOBuf_unread(f,vbuf,count);
3640 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3642 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3643 PerlIOBuf *b = &m->base;
3644 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3646 /* No, or wrong sort of, buffer */
3649 if (PerlIOMmap_unmap(f) != 0)
3652 /* If unmap took the "buffer" see if we have one from before */
3653 if (!b->buf && m->bbuf)
3657 PerlIOBuf_get_base(f);
3661 return PerlIOBuf_write(f,vbuf,count);
3665 PerlIOMmap_flush(PerlIO *f)
3667 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3668 PerlIOBuf *b = &m->base;
3669 IV code = PerlIOBuf_flush(f);
3670 /* Now we are "synced" at PerlIOBuf level */
3675 /* Unmap the buffer */
3676 if (PerlIOMmap_unmap(f) != 0)
3681 /* We seem to have a PerlIOBuf buffer which was not mapped
3682 * remember it in case we need one later
3691 PerlIOMmap_fill(PerlIO *f)
3693 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3694 IV code = PerlIO_flush(f);
3695 if (code == 0 && !b->buf)
3697 code = PerlIOMmap_map(f);
3699 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3701 code = PerlIOBuf_fill(f);
3707 PerlIOMmap_close(PerlIO *f)
3709 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3710 PerlIOBuf *b = &m->base;
3711 IV code = PerlIO_flush(f);
3716 b->ptr = b->end = b->buf;
3718 if (PerlIOBuf_close(f) != 0)
3724 PerlIO_funcs PerlIO_mmap = {
3743 PerlIOBase_clearerr,
3744 PerlIOBase_setlinebuf,
3745 PerlIOMmap_get_base,
3749 PerlIOBuf_set_ptrcnt,
3752 #endif /* HAS_MMAP */
3759 call_atexit(PerlIO_cleanup_layers, NULL);
3764 atexit(&PerlIO_cleanup);
3776 PerlIO_stdstreams(aTHX);
3781 #undef PerlIO_stdout
3788 PerlIO_stdstreams(aTHX);
3793 #undef PerlIO_stderr
3800 PerlIO_stdstreams(aTHX);
3805 /*--------------------------------------------------------------------------------------*/
3807 #undef PerlIO_getname
3809 PerlIO_getname(PerlIO *f, char *buf)
3814 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3815 if (stdio) name = fgetname(stdio, buf);
3817 Perl_croak(aTHX_ "Don't know how to get file name");
3823 /*--------------------------------------------------------------------------------------*/
3824 /* Functions which can be called on any kind of PerlIO implemented
3830 PerlIO_getc(PerlIO *f)
3833 SSize_t count = PerlIO_read(f,buf,1);
3836 return (unsigned char) buf[0];
3841 #undef PerlIO_ungetc
3843 PerlIO_ungetc(PerlIO *f, int ch)
3848 if (PerlIO_unread(f,&buf,1) == 1)
3856 PerlIO_putc(PerlIO *f, int ch)
3859 return PerlIO_write(f,&buf,1);
3864 PerlIO_puts(PerlIO *f, const char *s)
3866 STRLEN len = strlen(s);
3867 return PerlIO_write(f,s,len);
3870 #undef PerlIO_rewind
3872 PerlIO_rewind(PerlIO *f)
3874 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3878 #undef PerlIO_vprintf
3880 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3883 SV *sv = newSVpvn("",0);
3889 Perl_va_copy(ap, apc);
3890 sv_vcatpvf(sv, fmt, &apc);
3892 sv_vcatpvf(sv, fmt, &ap);
3895 wrote = PerlIO_write(f,s,len);
3900 #undef PerlIO_printf
3902 PerlIO_printf(PerlIO *f,const char *fmt,...)
3907 result = PerlIO_vprintf(f,fmt,ap);
3912 #undef PerlIO_stdoutf
3914 PerlIO_stdoutf(const char *fmt,...)
3919 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3924 #undef PerlIO_tmpfile
3926 PerlIO_tmpfile(void)
3928 /* I have no idea how portable mkstemp() is ... */
3929 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3932 FILE *stdio = PerlSIO_tmpfile();
3935 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3941 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3942 int fd = mkstemp(SvPVX(sv));
3946 f = PerlIO_fdopen(fd,"w+");
3949 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3951 PerlLIO_unlink(SvPVX(sv));
3961 #endif /* USE_SFIO */
3962 #endif /* PERLIO_IS_STDIO */
3964 /*======================================================================================*/
3965 /* Now some functions in terms of above which may be needed even if
3966 we are not in true PerlIO mode
3970 #undef PerlIO_setpos
3972 PerlIO_setpos(PerlIO *f, SV *pos)
3978 Off_t *posn = (Off_t *) SvPV(pos,len);
3979 if (f && len == sizeof(Off_t))
3980 return PerlIO_seek(f,*posn,SEEK_SET);
3982 SETERRNO(EINVAL,SS$_IVCHAN);
3986 #undef PerlIO_setpos
3988 PerlIO_setpos(PerlIO *f, SV *pos)
3994 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3995 if (f && len == sizeof(Fpos_t))
3997 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3998 return fsetpos64(f, fpos);
4000 return fsetpos(f, fpos);
4004 SETERRNO(EINVAL,SS$_IVCHAN);
4010 #undef PerlIO_getpos
4012 PerlIO_getpos(PerlIO *f, SV *pos)
4015 Off_t posn = PerlIO_tell(f);
4016 sv_setpvn(pos,(char *)&posn,sizeof(posn));
4017 return (posn == (Off_t)-1) ? -1 : 0;
4020 #undef PerlIO_getpos
4022 PerlIO_getpos(PerlIO *f, SV *pos)
4027 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4028 code = fgetpos64(f, &fpos);
4030 code = fgetpos(f, &fpos);
4032 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4037 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4040 vprintf(char *pat, char *args)
4042 _doprnt(pat, args, stdout);
4043 return 0; /* wrong, but perl doesn't use the return value */
4047 vfprintf(FILE *fd, char *pat, char *args)
4049 _doprnt(pat, args, fd);
4050 return 0; /* wrong, but perl doesn't use the return value */
4055 #ifndef PerlIO_vsprintf
4057 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4059 int val = vsprintf(s, fmt, ap);
4062 if (strlen(s) >= (STRLEN)n)
4065 (void)PerlIO_puts(Perl_error_log,
4066 "panic: sprintf overflow - memory corrupted!\n");
4074 #ifndef PerlIO_sprintf
4076 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4081 result = PerlIO_vsprintf(s, n, fmt, ap);