3 * Copyright (c) 1996-2001, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
10 /* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need
11 a dTHX to get at the dispatch tables, even when we do not
12 need it for other reasons.
13 Invent a dSYS macro to abstract this out
15 #ifdef PERL_IMPLICIT_SYS
28 #define PERLIO_NOT_STDIO 0
29 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
30 /* #define PerlIO FILE */
33 * This file provides those parts of PerlIO abstraction
34 * which are not #defined in perlio.h.
35 * Which these are depends on various Configure #ifdef's
39 #define PERL_IN_PERLIO_C
44 #undef PerlMemShared_calloc
45 #define PerlMemShared_calloc(x,y) calloc(x,y)
46 #undef PerlMemShared_free
47 #define PerlMemShared_free(x) free(x)
50 perlsio_binmode(FILE *fp, int iotype, int mode)
52 /* This used to be contents of do_binmode in doio.c */
54 # if defined(atarist) || defined(__MINT__)
57 ((FILE*)fp)->_flag |= _IOBIN;
59 ((FILE*)fp)->_flag &= ~ _IOBIN;
65 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
66 # if defined(WIN32) && defined(__BORLANDC__)
67 /* The translation mode of the stream is maintained independent
68 * of the translation mode of the fd in the Borland RTL (heavy
69 * digging through their runtime sources reveal). User has to
70 * set the mode explicitly for the stream (though they don't
71 * document this anywhere). GSAR 97-5-24
77 fp->flags &= ~ _F_BIN;
85 # if defined(USEMYBINMODE)
86 if (my_binmode(fp, iotype, mode) != FALSE)
98 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
100 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
104 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
110 PerlIO_destruct(pTHX)
115 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
120 return perlsio_binmode(fp,iotype,mode);
124 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
127 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
131 if (*args == &PL_sv_undef)
132 return PerlIO_tmpfile();
135 char *name = SvPV_nolen(*args);
138 fd = PerlLIO_open3(name,imode,perm);
140 return PerlIO_fdopen(fd,(char *)mode+1);
144 return PerlIO_reopen(name,mode,old);
148 return PerlIO_open(name,mode);
154 return PerlIO_fdopen(fd,(char *)mode);
159 XS(XS_PerlIO__Layer__find)
163 Perl_croak(aTHX_ "Usage class->find(name[,load])");
166 char *name = SvPV_nolen(ST(1));
167 ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
174 Perl_boot_core_PerlIO(pTHX)
176 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
182 #ifdef PERLIO_IS_STDIO
187 /* Does nothing (yet) except force this file to be included
188 in perl binary. That allows this file to force inclusion
189 of other functions that may be required by loadable
190 extensions e.g. for FileHandle::tmpfile
194 #undef PerlIO_tmpfile
201 #else /* PERLIO_IS_STDIO */
208 /* This section is just to make sure these functions
209 get pulled in from libsfio.a
212 #undef PerlIO_tmpfile
222 /* Force this file to be included in perl binary. Which allows
223 * this file to force inclusion of other functions that may be
224 * required by loadable extensions e.g. for FileHandle::tmpfile
228 * sfio does its own 'autoflush' on stdout in common cases.
229 * Flush results in a lot of lseek()s to regular files and
230 * lot of small writes to pipes.
232 sfset(sfstdout,SF_SHARE,0);
236 PerlIO_importFILE(FILE *stdio, int fl)
238 int fd = fileno(stdio);
239 PerlIO *r = PerlIO_fdopen(fd,"r+");
244 PerlIO_findFILE(PerlIO *pio)
246 int fd = PerlIO_fileno(pio);
247 FILE *f = fdopen(fd,"r+");
249 if (!f && errno == EINVAL)
251 if (!f && errno == EINVAL)
258 /*======================================================================================*/
259 /* Implement all the PerlIO interface ourselves.
264 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
269 #include <sys/mman.h>
273 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
276 PerlIO_debug(const char *fmt,...)
284 char *s = PerlEnv_getenv("PERLIO_DEBUG");
286 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
293 SV *sv = newSVpvn("",0);
296 s = CopFILE(PL_curcop);
299 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
300 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
303 PerlLIO_write(dbg,s,len);
309 /*--------------------------------------------------------------------------------------*/
311 /* Inner level routines */
313 /* Table of pointers to the PerlIO structs (malloc'ed) */
314 PerlIO *_perlio = NULL;
315 #define PERLIO_TABLE_SIZE 64
320 PerlIO_allocate(pTHX)
322 /* Find a free slot in the table, allocating new table as necessary */
329 last = (PerlIO **)(f);
330 for (i=1; i < PERLIO_TABLE_SIZE; i++)
338 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
348 PerlIO_cleantable(pTHX_ PerlIO **tablep)
350 PerlIO *table = *tablep;
354 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
355 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
363 PerlMemShared_free(table);
368 PerlIO_list_t *PerlIO_known_layers;
369 PerlIO_list_t *PerlIO_def_layerlist;
372 PerlIO_list_alloc(void)
375 Newz('L',list,1,PerlIO_list_t);
381 PerlIO_list_free(PerlIO_list_t *list)
385 if (--list->refcnt == 0)
391 for (i=0; i < list->cur; i++)
393 if (list->array[i].arg)
394 SvREFCNT_dec(list->array[i].arg);
396 Safefree(list->array);
404 PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
408 if (list->cur >= list->len)
412 Renew(list->array,list->len,PerlIO_pair_t);
414 New('l',list->array,list->len,PerlIO_pair_t);
416 p = &(list->array[list->cur++]);
418 if ((p->arg = arg)) {
425 PerlIO_cleanup_layers(pTHXo_ void *data)
428 PerlIO_known_layers = Nullhv;
429 PerlIO_def_layerlist = Nullav;
437 PerlIO_cleantable(aTHX_ &_perlio);
441 PerlIO_destruct(pTHX)
443 PerlIO **table = &_perlio;
448 table = (PerlIO **)(f++);
449 for (i=1; i < PERLIO_TABLE_SIZE; i++)
455 if (l->tab->kind & PERLIO_K_DESTRUCT)
457 PerlIO_debug("Destruct popping %s\n",l->tab->name);
472 PerlIO_pop(pTHX_ PerlIO *f)
477 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
480 /* If popped returns non-zero do not free its layer structure
481 it has either done so itself, or it is shared and still in use
483 if ((*l->tab->Popped)(f) != 0)
487 PerlMemShared_free(l);
491 /*--------------------------------------------------------------------------------------*/
492 /* XS Interface for perl code */
495 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
498 if ((SSize_t) len <= 0)
500 for (i=0; i < PerlIO_known_layers->cur; i++)
502 PerlIO_funcs *f = PerlIO_known_layers->array[i].funcs;
503 if (strEQ(f->name,name))
505 PerlIO_debug("%.*s => %p\n",(int)len,name,f);
509 if (load && PL_subname && PerlIO_def_layerlist && PerlIO_def_layerlist->cur >= 2)
511 SV *pkgsv = newSVpvn("PerlIO",6);
512 SV *layer = newSVpvn(name,len);
514 /* The two SVs are magically freed by load_module */
515 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
517 return PerlIO_find_layer(aTHX_ name,len,0);
519 PerlIO_debug("Cannot find %.*s\n",(int)len,name);
523 #ifdef USE_ATTRIBUTES_FOR_PERLIO
526 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
530 IO *io = GvIOn((GV *)SvRV(sv));
531 PerlIO *ifp = IoIFP(io);
532 PerlIO *ofp = IoOFP(io);
533 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
539 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
543 IO *io = GvIOn((GV *)SvRV(sv));
544 PerlIO *ifp = IoIFP(io);
545 PerlIO *ofp = IoOFP(io);
546 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
552 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
554 Perl_warn(aTHX_ "clear %"SVf,sv);
559 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
561 Perl_warn(aTHX_ "free %"SVf,sv);
565 MGVTBL perlio_vtab = {
573 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
576 SV *sv = SvRV(ST(1));
581 sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0);
583 mg = mg_find(sv, PERL_MAGIC_ext);
584 mg->mg_virtual = &perlio_vtab;
586 Perl_warn(aTHX_ "attrib %"SVf,sv);
587 for (i=2; i < items; i++)
590 const char *name = SvPV(ST(i),len);
591 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
594 av_push(av,SvREFCNT_inc(layer));
606 #endif /* USE_ATTIBUTES_FOR_PERLIO */
609 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
611 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
612 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
616 XS(XS_PerlIO__Layer__find)
620 Perl_croak(aTHX_ "Usage class->find(name[,load])");
624 char *name = SvPV(ST(1),len);
625 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
626 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
627 ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
633 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
635 if (!PerlIO_known_layers)
636 PerlIO_known_layers = PerlIO_list_alloc();
637 PerlIO_list_push(PerlIO_known_layers,tab,Nullsv);
638 PerlIO_debug("define %s %p\n",tab->name,tab);
642 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
646 const char *s = names;
649 while (isSPACE(*s) || *s == ':')
655 const char *as = Nullch;
659 /* Message is consistent with how attribute lists are passed.
660 Even though this means "foo : : bar" is seen as an invalid separator
662 char q = ((*s == '\'') ? '"' : '\'');
663 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
669 } while (isALNUM(*e));
687 /* It's a nul terminated string, not allowed to \ the terminating null.
688 Anything other character is passed over. */
696 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
706 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ s,llen,1);
709 PerlIO_list_push(av, layer, (as) ? newSVpvn(as,alen) : &PL_sv_undef);
712 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
724 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
726 PerlIO_funcs *tab = &PerlIO_perlio;
727 if (O_BINARY != O_TEXT)
733 if (PerlIO_stdio.Set_ptrcnt)
738 PerlIO_debug("Pushing %s\n",tab->name);
739 PerlIO_list_push(av,PerlIO_find_layer(aTHX_ tab->name,0,0),&PL_sv_undef);
743 PerlIO_arg_fetch(PerlIO_list_t *av,IV n)
745 return av->array[n].arg;
749 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av,IV n,PerlIO_funcs *def)
751 if (n >= 0 && n < av->cur)
753 PerlIO_debug("Layer %ld is %s\n",n,av->array[n].funcs->name);
754 return av->array[n].funcs;
757 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
762 PerlIO_default_layers(pTHX)
764 if (!PerlIO_def_layerlist)
766 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
767 PerlIO_def_layerlist = PerlIO_list_alloc();
769 PerlIO_define_layer(aTHX_ &PerlIO_raw);
770 PerlIO_define_layer(aTHX_ &PerlIO_unix);
771 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
772 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
773 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
775 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
777 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
778 PerlIO_define_layer(aTHX_ &PerlIO_byte);
779 PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0),&PL_sv_undef);
782 PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
786 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
789 if (PerlIO_def_layerlist->cur < 2)
791 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
793 return PerlIO_def_layerlist;
797 Perl_boot_core_PerlIO(pTHX)
799 #ifdef USE_ATTRIBUTES_FOR_PERLIO
800 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
802 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
806 PerlIO_default_layer(pTHX_ I32 n)
808 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
811 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
814 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
815 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
818 PerlIO_stdstreams(pTHX)
822 PerlIO_allocate(aTHX);
823 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
824 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
825 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
830 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
833 l = PerlMemShared_calloc(tab->size,sizeof(char));
836 Zero(l,tab->size,char);
840 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
841 (mode) ? mode : "(Null)",arg);
842 if ((*l->tab->Pushed)(f,mode,arg) != 0)
852 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
866 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
868 /* Remove the dummy layer */
871 /* Pop back to bottom layer */
875 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
883 /* Nothing bellow - push unix on top then remove it */
884 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
886 PerlIO_pop(aTHX_ PerlIONext(f));
891 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
898 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
900 IV max = layers->cur;
904 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
907 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
919 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
924 PerlIO_list_t *layers = PerlIO_list_alloc();
925 code = PerlIO_parse_layers(aTHX_ layers,names);
928 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
930 PerlIO_list_free(layers);
936 /*--------------------------------------------------------------------------------------*/
937 /* Given the abstraction above the public API functions */
940 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
942 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
943 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
944 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
950 if (PerlIOBase(top)->tab == &PerlIO_crlf)
953 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
956 top = PerlIONext(top);
959 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
964 PerlIO__close(PerlIO *f)
967 return (*PerlIOBase(f)->tab->Close)(f);
970 SETERRNO(EBADF,SS$_IVCHAN);
975 #undef PerlIO_fdupopen
977 PerlIO_fdupopen(pTHX_ PerlIO *f)
982 int fd = PerlLIO_dup(PerlIO_fileno(f));
983 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
986 Off_t posn = PerlIO_tell(f);
987 PerlIO_seek(new,posn,SEEK_SET);
993 SETERRNO(EBADF,SS$_IVCHAN);
1000 PerlIO_close(PerlIO *f)
1006 code = (*PerlIOBase(f)->tab->Close)(f);
1009 PerlIO_pop(aTHX_ f);
1015 #undef PerlIO_fileno
1017 PerlIO_fileno(PerlIO *f)
1020 return (*PerlIOBase(f)->tab->Fileno)(f);
1023 SETERRNO(EBADF,SS$_IVCHAN);
1029 PerlIO_context_layers(pTHX_ const char *mode)
1031 const char *type = NULL;
1032 /* Need to supply default layer info from open.pm */
1035 SV *layers = PL_curcop->cop_io;
1039 type = SvPV(layers,len);
1040 if (type && mode[0] != 'r')
1042 /* Skip to write part */
1043 const char *s = strchr(type,0);
1044 if (s && (s-type) < len)
1054 static PerlIO_funcs *
1055 PerlIO_layer_from_ref(pTHX_ SV *sv)
1057 /* For any scalar type load the handler which is bundled with perl */
1058 if (SvTYPE(sv) < SVt_PVAV)
1059 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1061 /* For other types allow if layer is known but don't try and load it */
1065 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1067 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1069 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1071 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1077 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1079 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1082 PerlIO_stdstreams(aTHX);
1086 /* If it is a reference but not an object see if we have a handler for it */
1087 if (SvROK(arg) && !sv_isobject(arg))
1089 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1092 def = PerlIO_list_alloc();
1093 PerlIO_list_push(def,handler,&PL_sv_undef);
1096 /* Don't fail if handler cannot be found
1097 * :Via(...) etc. may do something sensible
1098 * else we will just stringfy and open resulting string.
1103 layers = PerlIO_context_layers(aTHX_ mode);
1104 if (layers && *layers)
1110 av = PerlIO_list_alloc();
1111 for (i=0; i < def->cur; i++)
1113 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1120 PerlIO_parse_layers(aTHX_ av,layers);
1132 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1134 if (!f && narg == 1 && *args == &PL_sv_undef)
1136 if ((f = PerlIO_tmpfile()))
1139 layers = PerlIO_context_layers(aTHX_ mode);
1140 if (layers && *layers)
1141 PerlIO_apply_layers(aTHX_ f,mode,layers);
1146 PerlIO_list_t *layera = NULL;
1148 PerlIO_funcs *tab = NULL;
1151 /* This is "reopen" - it is not tested as perl does not use it yet */
1153 layera = PerlIO_list_alloc();
1156 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1157 PerlIO_list_push(layera,l->tab,arg);
1158 l = *PerlIONext(&l);
1163 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1165 /* Start at "top" of layer stack */
1169 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1179 /* Found that layer 'n' can do opens - call it */
1180 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1181 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1182 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1185 if (n+1 < layera->cur)
1187 /* More layers above the one that we used to open - apply them now */
1188 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1195 PerlIO_list_free(layera);
1201 #undef PerlIO_fdopen
1203 PerlIO_fdopen(int fd, const char *mode)
1206 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1211 PerlIO_open(const char *path, const char *mode)
1214 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1215 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1218 #undef PerlIO_reopen
1220 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1223 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1224 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1229 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1232 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1235 SETERRNO(EBADF,SS$_IVCHAN);
1240 #undef PerlIO_unread
1242 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1245 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1248 SETERRNO(EBADF,SS$_IVCHAN);
1255 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1258 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1261 SETERRNO(EBADF,SS$_IVCHAN);
1268 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1271 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1274 SETERRNO(EBADF,SS$_IVCHAN);
1281 PerlIO_tell(PerlIO *f)
1284 return (*PerlIOBase(f)->tab->Tell)(f);
1287 SETERRNO(EBADF,SS$_IVCHAN);
1294 PerlIO_flush(PerlIO *f)
1300 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1301 if (tab && tab->Flush)
1303 return (*tab->Flush)(f);
1307 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1308 SETERRNO(EBADF,SS$_IVCHAN);
1314 PerlIO_debug("Cannot flush f=%p\n",f);
1315 SETERRNO(EBADF,SS$_IVCHAN);
1321 /* Is it good API design to do flush-all on NULL,
1322 * a potentially errorneous input? Maybe some magical
1323 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1324 * Yes, stdio does similar things on fflush(NULL),
1325 * but should we be bound by their design decisions?
1327 PerlIO **table = &_perlio;
1329 while ((f = *table))
1332 table = (PerlIO **)(f++);
1333 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1335 if (*f && PerlIO_flush(f) != 0)
1345 PerlIOBase_flush_linebuf()
1347 PerlIO **table = &_perlio;
1349 while ((f = *table))
1352 table = (PerlIO **)(f++);
1353 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1355 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1356 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1365 PerlIO_fill(PerlIO *f)
1368 return (*PerlIOBase(f)->tab->Fill)(f);
1371 SETERRNO(EBADF,SS$_IVCHAN);
1376 #undef PerlIO_isutf8
1378 PerlIO_isutf8(PerlIO *f)
1381 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1384 SETERRNO(EBADF,SS$_IVCHAN);
1391 PerlIO_eof(PerlIO *f)
1394 return (*PerlIOBase(f)->tab->Eof)(f);
1397 SETERRNO(EBADF,SS$_IVCHAN);
1404 PerlIO_error(PerlIO *f)
1407 return (*PerlIOBase(f)->tab->Error)(f);
1410 SETERRNO(EBADF,SS$_IVCHAN);
1415 #undef PerlIO_clearerr
1417 PerlIO_clearerr(PerlIO *f)
1420 (*PerlIOBase(f)->tab->Clearerr)(f);
1422 SETERRNO(EBADF,SS$_IVCHAN);
1425 #undef PerlIO_setlinebuf
1427 PerlIO_setlinebuf(PerlIO *f)
1430 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1432 SETERRNO(EBADF,SS$_IVCHAN);
1435 #undef PerlIO_has_base
1437 PerlIO_has_base(PerlIO *f)
1439 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1443 #undef PerlIO_fast_gets
1445 PerlIO_fast_gets(PerlIO *f)
1447 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1449 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1450 return (tab->Set_ptrcnt != NULL);
1455 #undef PerlIO_has_cntptr
1457 PerlIO_has_cntptr(PerlIO *f)
1461 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1462 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1467 #undef PerlIO_canset_cnt
1469 PerlIO_canset_cnt(PerlIO *f)
1473 PerlIOl *l = PerlIOBase(f);
1474 return (l->tab->Set_ptrcnt != NULL);
1479 #undef PerlIO_get_base
1481 PerlIO_get_base(PerlIO *f)
1484 return (*PerlIOBase(f)->tab->Get_base)(f);
1488 #undef PerlIO_get_bufsiz
1490 PerlIO_get_bufsiz(PerlIO *f)
1493 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1497 #undef PerlIO_get_ptr
1499 PerlIO_get_ptr(PerlIO *f)
1501 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1502 if (tab->Get_ptr == NULL)
1504 return (*tab->Get_ptr)(f);
1507 #undef PerlIO_get_cnt
1509 PerlIO_get_cnt(PerlIO *f)
1511 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1512 if (tab->Get_cnt == NULL)
1514 return (*tab->Get_cnt)(f);
1517 #undef PerlIO_set_cnt
1519 PerlIO_set_cnt(PerlIO *f,int cnt)
1521 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1524 #undef PerlIO_set_ptrcnt
1526 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1528 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1529 if (tab->Set_ptrcnt == NULL)
1532 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1534 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1537 /*--------------------------------------------------------------------------------------*/
1538 /* utf8 and raw dummy layers */
1541 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1546 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1547 PerlIO_pop(aTHX_ f);
1548 if (tab->kind & PERLIO_K_UTF8)
1549 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1551 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1557 PerlIO_funcs PerlIO_utf8 = {
1560 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1578 NULL, /* get_base */
1579 NULL, /* get_bufsiz */
1582 NULL, /* set_ptrcnt */
1585 PerlIO_funcs PerlIO_byte = {
1606 NULL, /* get_base */
1607 NULL, /* get_bufsiz */
1610 NULL, /* set_ptrcnt */
1614 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)
1616 PerlIO_funcs *tab = PerlIO_default_btm();
1617 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1620 PerlIO_funcs PerlIO_raw = {
1641 NULL, /* get_base */
1642 NULL, /* get_bufsiz */
1645 NULL, /* set_ptrcnt */
1647 /*--------------------------------------------------------------------------------------*/
1648 /*--------------------------------------------------------------------------------------*/
1649 /* "Methods" of the "base class" */
1652 PerlIOBase_fileno(PerlIO *f)
1654 return PerlIO_fileno(PerlIONext(f));
1658 PerlIO_modestr(PerlIO *f,char *buf)
1661 IV flags = PerlIOBase(f)->flags;
1662 if (flags & PERLIO_F_APPEND)
1665 if (flags & PERLIO_F_CANREAD)
1670 else if (flags & PERLIO_F_CANREAD)
1673 if (flags & PERLIO_F_CANWRITE)
1676 else if (flags & PERLIO_F_CANWRITE)
1679 if (flags & PERLIO_F_CANREAD)
1684 #if O_TEXT != O_BINARY
1685 if (!(flags & PERLIO_F_CRLF))
1693 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1695 PerlIOl *l = PerlIOBase(f);
1697 const char *omode = mode;
1700 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1701 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1702 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1703 if (tab->Set_ptrcnt != NULL)
1704 l->flags |= PERLIO_F_FASTGETS;
1707 if (*mode == '#' || *mode == 'I')
1712 l->flags |= PERLIO_F_CANREAD;
1715 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1718 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1721 SETERRNO(EINVAL,LIB$_INVARG);
1729 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1732 l->flags &= ~PERLIO_F_CRLF;
1735 l->flags |= PERLIO_F_CRLF;
1738 SETERRNO(EINVAL,LIB$_INVARG);
1747 l->flags |= l->next->flags &
1748 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1752 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1753 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1754 l->flags,PerlIO_modestr(f,temp));
1760 PerlIOBase_popped(PerlIO *f)
1766 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1769 Off_t old = PerlIO_tell(f);
1771 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1772 done = PerlIOBuf_unread(f,vbuf,count);
1773 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1778 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1780 STDCHAR *buf = (STDCHAR *) vbuf;
1783 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1787 SSize_t avail = PerlIO_get_cnt(f);
1790 take = (count < avail) ? count : avail;
1793 STDCHAR *ptr = PerlIO_get_ptr(f);
1794 Copy(ptr,buf,take,STDCHAR);
1795 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1799 if (count > 0 && avail <= 0)
1801 if (PerlIO_fill(f) != 0)
1805 return (buf - (STDCHAR *) vbuf);
1811 PerlIOBase_noop_ok(PerlIO *f)
1817 PerlIOBase_noop_fail(PerlIO *f)
1823 PerlIOBase_close(PerlIO *f)
1826 PerlIO *n = PerlIONext(f);
1827 if (PerlIO_flush(f) != 0)
1829 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1831 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1836 PerlIOBase_eof(PerlIO *f)
1840 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1846 PerlIOBase_error(PerlIO *f)
1850 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1856 PerlIOBase_clearerr(PerlIO *f)
1860 PerlIO *n = PerlIONext(f);
1861 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1868 PerlIOBase_setlinebuf(PerlIO *f)
1872 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1876 /*--------------------------------------------------------------------------------------*/
1877 /* Bottom-most level for UNIX-like case */
1881 struct _PerlIO base; /* The generic part */
1882 int fd; /* UNIX like file descriptor */
1883 int oflags; /* open/fcntl flags */
1887 PerlIOUnix_oflags(const char *mode)
1902 oflags = O_CREAT|O_TRUNC;
1913 oflags = O_CREAT|O_APPEND;
1929 else if (*mode == 't')
1932 oflags &= ~O_BINARY;
1935 /* Always open in binary mode */
1937 if (*mode || oflags == -1)
1939 SETERRNO(EINVAL,LIB$_INVARG);
1946 PerlIOUnix_fileno(PerlIO *f)
1948 return PerlIOSelf(f,PerlIOUnix)->fd;
1952 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1954 IV code = PerlIOBase_pushed(f,mode,arg);
1957 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1958 s->fd = PerlIO_fileno(PerlIONext(f));
1959 s->oflags = PerlIOUnix_oflags(mode);
1961 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1966 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)
1970 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1971 (*PerlIOBase(f)->tab->Close)(f);
1975 char *path = SvPV_nolen(*args);
1980 imode = PerlIOUnix_oflags(mode);
1985 fd = PerlLIO_open3(path,imode,perm);
1995 f = PerlIO_allocate(aTHX);
1996 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1999 s = PerlIOSelf(f,PerlIOUnix);
2002 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2009 /* FIXME: pop layers ??? */
2016 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2019 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2020 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2024 SSize_t len = PerlLIO_read(fd,vbuf,count);
2025 if (len >= 0 || errno != EINTR)
2028 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2029 else if (len == 0 && count != 0)
2030 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2038 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2041 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2044 SSize_t len = PerlLIO_write(fd,vbuf,count);
2045 if (len >= 0 || errno != EINTR)
2048 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2056 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2059 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2060 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2061 return (new == (Off_t) -1) ? -1 : 0;
2065 PerlIOUnix_tell(PerlIO *f)
2068 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2072 PerlIOUnix_close(PerlIO *f)
2075 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2077 while (PerlLIO_close(fd) != 0)
2088 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2093 PerlIO_funcs PerlIO_unix = {
2108 PerlIOBase_noop_ok, /* flush */
2109 PerlIOBase_noop_fail, /* fill */
2112 PerlIOBase_clearerr,
2113 PerlIOBase_setlinebuf,
2114 NULL, /* get_base */
2115 NULL, /* get_bufsiz */
2118 NULL, /* set_ptrcnt */
2121 /*--------------------------------------------------------------------------------------*/
2122 /* stdio as a layer */
2126 struct _PerlIO base;
2127 FILE * stdio; /* The stream */
2131 PerlIOStdio_fileno(PerlIO *f)
2134 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2138 PerlIOStdio_mode(const char *mode,char *tmode)
2145 if (O_BINARY != O_TEXT)
2153 /* This isn't used yet ... */
2155 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2160 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2162 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2168 return PerlIOBase_pushed(f,mode,arg);
2171 #undef PerlIO_importFILE
2173 PerlIO_importFILE(FILE *stdio, int fl)
2179 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2186 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)
2191 char *path = SvPV_nolen(*args);
2192 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2193 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2203 char *path = SvPV_nolen(*args);
2207 fd = PerlLIO_open3(path,imode,perm);
2211 FILE *stdio = PerlSIO_fopen(path,mode);
2214 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2215 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2236 stdio = PerlSIO_stdin;
2239 stdio = PerlSIO_stdout;
2242 stdio = PerlSIO_stderr;
2248 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2252 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2262 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2265 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2269 STDCHAR *buf = (STDCHAR *) vbuf;
2270 /* Perl is expecting PerlIO_getc() to fill the buffer
2271 * Linux's stdio does not do that for fread()
2273 int ch = PerlSIO_fgetc(s);
2281 got = PerlSIO_fread(vbuf,1,count,s);
2286 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2289 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2290 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2294 int ch = *buf-- & 0xff;
2295 if (PerlSIO_ungetc(ch,s) != ch)
2304 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2307 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2311 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2314 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2315 return PerlSIO_fseek(stdio,offset,whence);
2319 PerlIOStdio_tell(PerlIO *f)
2322 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2323 return PerlSIO_ftell(stdio);
2327 PerlIOStdio_close(PerlIO *f)
2330 #ifdef SOCKS5_VERSION_NAME
2332 Sock_size_t optlen = sizeof(int);
2334 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2336 #ifdef SOCKS5_VERSION_NAME
2337 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2338 PerlSIO_fclose(stdio) :
2339 close(PerlIO_fileno(f))
2341 PerlSIO_fclose(stdio)
2348 PerlIOStdio_flush(PerlIO *f)
2351 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2352 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2354 return PerlSIO_fflush(stdio);
2359 /* FIXME: This discards ungetc() and pre-read stuff which is
2360 not right if this is just a "sync" from a layer above
2361 Suspect right design is to do _this_ but not have layer above
2362 flush this layer read-to-read
2364 /* Not writeable - sync by attempting a seek */
2366 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2374 PerlIOStdio_fill(PerlIO *f)
2377 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2379 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2380 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2382 if (PerlSIO_fflush(stdio) != 0)
2385 c = PerlSIO_fgetc(stdio);
2386 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2392 PerlIOStdio_eof(PerlIO *f)
2395 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2399 PerlIOStdio_error(PerlIO *f)
2402 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2406 PerlIOStdio_clearerr(PerlIO *f)
2409 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2413 PerlIOStdio_setlinebuf(PerlIO *f)
2416 #ifdef HAS_SETLINEBUF
2417 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2419 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2425 PerlIOStdio_get_base(PerlIO *f)
2428 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2429 return PerlSIO_get_base(stdio);
2433 PerlIOStdio_get_bufsiz(PerlIO *f)
2436 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2437 return PerlSIO_get_bufsiz(stdio);
2441 #ifdef USE_STDIO_PTR
2443 PerlIOStdio_get_ptr(PerlIO *f)
2446 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2447 return PerlSIO_get_ptr(stdio);
2451 PerlIOStdio_get_cnt(PerlIO *f)
2454 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2455 return PerlSIO_get_cnt(stdio);
2459 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2461 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2465 #ifdef STDIO_PTR_LVALUE
2466 PerlSIO_set_ptr(stdio,ptr);
2467 #ifdef STDIO_PTR_LVAL_SETS_CNT
2468 if (PerlSIO_get_cnt(stdio) != (cnt))
2471 assert(PerlSIO_get_cnt(stdio) == (cnt));
2474 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2475 /* Setting ptr _does_ change cnt - we are done */
2478 #else /* STDIO_PTR_LVALUE */
2480 #endif /* STDIO_PTR_LVALUE */
2482 /* Now (or only) set cnt */
2483 #ifdef STDIO_CNT_LVALUE
2484 PerlSIO_set_cnt(stdio,cnt);
2485 #else /* STDIO_CNT_LVALUE */
2486 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2487 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2488 #else /* STDIO_PTR_LVAL_SETS_CNT */
2490 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2491 #endif /* STDIO_CNT_LVALUE */
2496 PerlIO_funcs PerlIO_stdio = {
2498 sizeof(PerlIOStdio),
2515 PerlIOStdio_clearerr,
2516 PerlIOStdio_setlinebuf,
2518 PerlIOStdio_get_base,
2519 PerlIOStdio_get_bufsiz,
2524 #ifdef USE_STDIO_PTR
2525 PerlIOStdio_get_ptr,
2526 PerlIOStdio_get_cnt,
2527 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2528 PerlIOStdio_set_ptrcnt
2529 #else /* STDIO_PTR_LVALUE */
2531 #endif /* STDIO_PTR_LVALUE */
2532 #else /* USE_STDIO_PTR */
2536 #endif /* USE_STDIO_PTR */
2539 #undef PerlIO_exportFILE
2541 PerlIO_exportFILE(PerlIO *f, int fl)
2545 stdio = fdopen(PerlIO_fileno(f),"r+");
2549 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2555 #undef PerlIO_findFILE
2557 PerlIO_findFILE(PerlIO *f)
2562 if (l->tab == &PerlIO_stdio)
2564 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2567 l = *PerlIONext(&l);
2569 return PerlIO_exportFILE(f,0);
2572 #undef PerlIO_releaseFILE
2574 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2578 /*--------------------------------------------------------------------------------------*/
2579 /* perlio buffer layer */
2582 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2585 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2586 int fd = PerlIO_fileno(f);
2588 if (fd >= 0 && PerlLIO_isatty(fd))
2590 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2592 posn = PerlIO_tell(PerlIONext(f));
2593 if (posn != (Off_t) -1)
2597 return PerlIOBase_pushed(f,mode,arg);
2601 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)
2605 PerlIO *next = PerlIONext(f);
2606 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2607 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2608 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2615 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2622 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2625 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2626 fd = PerlIO_fileno(f);
2627 #if O_BINARY != O_TEXT
2628 /* do something about failing setmode()? --jhi */
2629 PerlLIO_setmode(fd , O_BINARY);
2631 if (init && fd == 2)
2633 /* Initial stderr is unbuffered */
2634 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2641 /* This "flush" is akin to sfio's sync in that it handles files in either
2645 PerlIOBuf_flush(PerlIO *f)
2647 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2649 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2651 /* write() the buffer */
2652 STDCHAR *buf = b->buf;
2654 PerlIO *n = PerlIONext(f);
2657 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2662 else if (count < 0 || PerlIO_error(n))
2664 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2669 b->posn += (p - buf);
2671 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2673 STDCHAR *buf = PerlIO_get_base(f);
2674 /* Note position change */
2675 b->posn += (b->ptr - buf);
2676 if (b->ptr < b->end)
2678 /* We did not consume all of it */
2679 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2681 b->posn = PerlIO_tell(PerlIONext(f));
2685 b->ptr = b->end = b->buf;
2686 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2687 /* FIXME: Is this right for read case ? */
2688 if (PerlIO_flush(PerlIONext(f)) != 0)
2694 PerlIOBuf_fill(PerlIO *f)
2696 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2697 PerlIO *n = PerlIONext(f);
2699 /* FIXME: doing the down-stream flush is a bad idea if it causes
2700 pre-read data in stdio buffer to be discarded
2701 but this is too simplistic - as it skips _our_ hosekeeping
2702 and breaks tell tests.
2703 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2707 if (PerlIO_flush(f) != 0)
2709 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2710 PerlIOBase_flush_linebuf();
2713 PerlIO_get_base(f); /* allocate via vtable */
2715 b->ptr = b->end = b->buf;
2716 if (PerlIO_fast_gets(n))
2718 /* Layer below is also buffered
2719 * We do _NOT_ want to call its ->Read() because that will loop
2720 * till it gets what we asked for which may hang on a pipe etc.
2721 * Instead take anything it has to hand, or ask it to fill _once_.
2723 avail = PerlIO_get_cnt(n);
2726 avail = PerlIO_fill(n);
2728 avail = PerlIO_get_cnt(n);
2731 if (!PerlIO_error(n) && PerlIO_eof(n))
2737 STDCHAR *ptr = PerlIO_get_ptr(n);
2738 SSize_t cnt = avail;
2739 if (avail > b->bufsiz)
2741 Copy(ptr,b->buf,avail,STDCHAR);
2742 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2747 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2752 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2754 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2757 b->end = b->buf+avail;
2758 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2763 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2765 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2770 return PerlIOBase_read(f,vbuf,count);
2776 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2778 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2779 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2782 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2788 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2790 avail = (b->ptr - b->buf);
2795 b->end = b->buf + avail;
2797 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2798 b->posn -= b->bufsiz;
2800 if (avail > (SSize_t) count)
2808 Copy(buf,b->ptr,avail,STDCHAR);
2812 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2819 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2821 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2822 const STDCHAR *buf = (const STDCHAR *) vbuf;
2826 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2830 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2831 if ((SSize_t) count < avail)
2833 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2834 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2854 Copy(buf,b->ptr,avail,STDCHAR);
2861 if (b->ptr >= (b->buf + b->bufsiz))
2864 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2870 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2873 if ((code = PerlIO_flush(f)) == 0)
2875 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2876 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2877 code = PerlIO_seek(PerlIONext(f),offset,whence);
2880 b->posn = PerlIO_tell(PerlIONext(f));
2887 PerlIOBuf_tell(PerlIO *f)
2889 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2890 Off_t posn = b->posn;
2892 posn += (b->ptr - b->buf);
2897 PerlIOBuf_close(PerlIO *f)
2899 IV code = PerlIOBase_close(f);
2900 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2901 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2903 PerlMemShared_free(b->buf);
2906 b->ptr = b->end = b->buf;
2907 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2912 PerlIOBuf_get_ptr(PerlIO *f)
2914 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2921 PerlIOBuf_get_cnt(PerlIO *f)
2923 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2926 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2927 return (b->end - b->ptr);
2932 PerlIOBuf_get_base(PerlIO *f)
2934 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2939 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2942 b->buf = (STDCHAR *)&b->oneword;
2943 b->bufsiz = sizeof(b->oneword);
2952 PerlIOBuf_bufsiz(PerlIO *f)
2954 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2957 return (b->end - b->buf);
2961 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2963 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2967 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2970 assert(PerlIO_get_cnt(f) == cnt);
2971 assert(b->ptr >= b->buf);
2973 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2976 PerlIO_funcs PerlIO_perlio = {
2995 PerlIOBase_clearerr,
2996 PerlIOBase_setlinebuf,
3001 PerlIOBuf_set_ptrcnt,
3004 /*--------------------------------------------------------------------------------------*/
3005 /* Temp layer to hold unread chars when cannot do it any other way */
3008 PerlIOPending_fill(PerlIO *f)
3010 /* Should never happen */
3016 PerlIOPending_close(PerlIO *f)
3018 /* A tad tricky - flush pops us, then we close new top */
3020 return PerlIO_close(f);
3024 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3026 /* A tad tricky - flush pops us, then we seek new top */
3028 return PerlIO_seek(f,offset,whence);
3033 PerlIOPending_flush(PerlIO *f)
3036 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3037 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3039 PerlMemShared_free(b->buf);
3042 PerlIO_pop(aTHX_ f);
3047 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3055 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3060 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3062 IV code = PerlIOBase_pushed(f,mode,arg);
3063 PerlIOl *l = PerlIOBase(f);
3064 /* Our PerlIO_fast_gets must match what we are pushed on,
3065 or sv_gets() etc. get muddled when it changes mid-string
3068 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3069 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3074 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3076 SSize_t avail = PerlIO_get_cnt(f);
3081 got = PerlIOBuf_read(f,vbuf,avail);
3082 if (got >= 0 && got < count)
3084 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3085 if (more >= 0 || got == 0)
3091 PerlIO_funcs PerlIO_pending = {
3095 PerlIOPending_pushed,
3105 PerlIOPending_close,
3106 PerlIOPending_flush,
3110 PerlIOBase_clearerr,
3111 PerlIOBase_setlinebuf,
3116 PerlIOPending_set_ptrcnt,
3121 /*--------------------------------------------------------------------------------------*/
3122 /* crlf - translation
3123 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3124 to hand back a line at a time and keeping a record of which nl we "lied" about.
3125 On write translate "\n" to CR,LF
3130 PerlIOBuf base; /* PerlIOBuf stuff */
3131 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3135 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3138 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3139 code = PerlIOBuf_pushed(f,mode,arg);
3141 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3142 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3143 PerlIOBase(f)->flags);
3150 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3152 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3158 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3159 return PerlIOBuf_unread(f,vbuf,count);
3162 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3163 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3165 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3171 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3173 b->end = b->ptr = b->buf + b->bufsiz;
3174 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3175 b->posn -= b->bufsiz;
3177 while (count > 0 && b->ptr > b->buf)
3182 if (b->ptr - 2 >= b->buf)
3208 PerlIOCrlf_get_cnt(PerlIO *f)
3210 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3213 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3215 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3216 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3218 STDCHAR *nl = b->ptr;
3220 while (nl < b->end && *nl != 0xd)
3222 if (nl < b->end && *nl == 0xd)
3234 /* Not CR,LF but just CR */
3241 /* Blast - found CR as last char in buffer */
3244 /* They may not care, defer work as long as possible */
3245 return (nl - b->ptr);
3250 b->ptr++; /* say we have read it as far as flush() is concerned */
3251 b->buf++; /* Leave space an front of buffer */
3252 b->bufsiz--; /* Buffer is thus smaller */
3253 code = PerlIO_fill(f); /* Fetch some more */
3254 b->bufsiz++; /* Restore size for next time */
3255 b->buf--; /* Point at space */
3256 b->ptr = nl = b->buf; /* Which is what we hand off */
3257 b->posn--; /* Buffer starts here */
3258 *nl = 0xd; /* Fill in the CR */
3260 goto test; /* fill() call worked */
3261 /* CR at EOF - just fall through */
3266 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3272 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3274 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3275 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3276 IV flags = PerlIOBase(f)->flags;
3286 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3293 /* Test code - delete when it works ... */
3300 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3308 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3309 ptr, chk, flags, c->nl, b->end, cnt);
3316 /* They have taken what we lied about */
3323 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3327 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3329 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3330 return PerlIOBuf_write(f,vbuf,count);
3333 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3334 const STDCHAR *buf = (const STDCHAR *) vbuf;
3335 const STDCHAR *ebuf = buf+count;
3338 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3342 STDCHAR *eptr = b->buf+b->bufsiz;
3343 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3344 while (buf < ebuf && b->ptr < eptr)
3348 if ((b->ptr + 2) > eptr)
3350 /* Not room for both */
3356 *(b->ptr)++ = 0xd; /* CR */
3357 *(b->ptr)++ = 0xa; /* LF */
3359 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3378 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3380 return (buf - (STDCHAR *) vbuf);
3385 PerlIOCrlf_flush(PerlIO *f)
3387 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3393 return PerlIOBuf_flush(f);
3396 PerlIO_funcs PerlIO_crlf = {
3399 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3401 PerlIOBase_noop_ok, /* popped */
3405 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3406 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3407 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3415 PerlIOBase_clearerr,
3416 PerlIOBase_setlinebuf,
3421 PerlIOCrlf_set_ptrcnt,
3425 /*--------------------------------------------------------------------------------------*/
3426 /* mmap as "buffer" layer */
3430 PerlIOBuf base; /* PerlIOBuf stuff */
3431 Mmap_t mptr; /* Mapped address */
3432 Size_t len; /* mapped length */
3433 STDCHAR *bbuf; /* malloced buffer if map fails */
3436 static size_t page_size = 0;
3439 PerlIOMmap_map(PerlIO *f)
3442 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3443 IV flags = PerlIOBase(f)->flags;
3447 if (flags & PERLIO_F_CANREAD)
3449 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3450 int fd = PerlIO_fileno(f);
3452 code = fstat(fd,&st);
3453 if (code == 0 && S_ISREG(st.st_mode))
3455 SSize_t len = st.st_size - b->posn;
3460 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3462 SETERRNO(0,SS$_NORMAL);
3463 # ifdef _SC_PAGESIZE
3464 page_size = sysconf(_SC_PAGESIZE);
3466 page_size = sysconf(_SC_PAGE_SIZE);
3468 if ((long)page_size < 0) {
3473 (void)SvUPGRADE(error, SVt_PV);
3474 msg = SvPVx(error, n_a);
3475 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3478 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3482 # ifdef HAS_GETPAGESIZE
3483 page_size = getpagesize();
3485 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3486 page_size = PAGESIZE; /* compiletime, bad */
3490 if ((IV)page_size <= 0)
3491 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3495 /* This is a hack - should never happen - open should have set it ! */
3496 b->posn = PerlIO_tell(PerlIONext(f));
3498 posn = (b->posn / page_size) * page_size;
3499 len = st.st_size - posn;
3500 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3501 if (m->mptr && m->mptr != (Mmap_t) -1)
3503 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3504 madvise(m->mptr, len, MADV_SEQUENTIAL);
3506 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3507 madvise(m->mptr, len, MADV_WILLNEED);
3509 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3510 b->end = ((STDCHAR *)m->mptr) + len;
3511 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3522 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3524 b->ptr = b->end = b->ptr;
3533 PerlIOMmap_unmap(PerlIO *f)
3535 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3536 PerlIOBuf *b = &m->base;
3542 code = munmap(m->mptr, m->len);
3546 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3549 b->ptr = b->end = b->buf;
3550 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3556 PerlIOMmap_get_base(PerlIO *f)
3558 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3559 PerlIOBuf *b = &m->base;
3560 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3562 /* Already have a readbuffer in progress */
3567 /* We have a write buffer or flushed PerlIOBuf read buffer */
3568 m->bbuf = b->buf; /* save it in case we need it again */
3569 b->buf = NULL; /* Clear to trigger below */
3573 PerlIOMmap_map(f); /* Try and map it */
3576 /* Map did not work - recover PerlIOBuf buffer if we have one */
3580 b->ptr = b->end = b->buf;
3583 return PerlIOBuf_get_base(f);
3587 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3589 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3590 PerlIOBuf *b = &m->base;
3591 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3593 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3596 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3601 /* Loose the unwritable mapped buffer */
3603 /* If flush took the "buffer" see if we have one from before */
3604 if (!b->buf && m->bbuf)
3608 PerlIOBuf_get_base(f);
3612 return PerlIOBuf_unread(f,vbuf,count);
3616 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3618 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3619 PerlIOBuf *b = &m->base;
3620 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3622 /* No, or wrong sort of, buffer */
3625 if (PerlIOMmap_unmap(f) != 0)
3628 /* If unmap took the "buffer" see if we have one from before */
3629 if (!b->buf && m->bbuf)
3633 PerlIOBuf_get_base(f);
3637 return PerlIOBuf_write(f,vbuf,count);
3641 PerlIOMmap_flush(PerlIO *f)
3643 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3644 PerlIOBuf *b = &m->base;
3645 IV code = PerlIOBuf_flush(f);
3646 /* Now we are "synced" at PerlIOBuf level */
3651 /* Unmap the buffer */
3652 if (PerlIOMmap_unmap(f) != 0)
3657 /* We seem to have a PerlIOBuf buffer which was not mapped
3658 * remember it in case we need one later
3667 PerlIOMmap_fill(PerlIO *f)
3669 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3670 IV code = PerlIO_flush(f);
3671 if (code == 0 && !b->buf)
3673 code = PerlIOMmap_map(f);
3675 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3677 code = PerlIOBuf_fill(f);
3683 PerlIOMmap_close(PerlIO *f)
3685 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3686 PerlIOBuf *b = &m->base;
3687 IV code = PerlIO_flush(f);
3692 b->ptr = b->end = b->buf;
3694 if (PerlIOBuf_close(f) != 0)
3700 PerlIO_funcs PerlIO_mmap = {
3719 PerlIOBase_clearerr,
3720 PerlIOBase_setlinebuf,
3721 PerlIOMmap_get_base,
3725 PerlIOBuf_set_ptrcnt,
3728 #endif /* HAS_MMAP */
3735 call_atexit(PerlIO_cleanup_layers, NULL);
3740 atexit(&PerlIO_cleanup);
3752 PerlIO_stdstreams(aTHX);
3757 #undef PerlIO_stdout
3764 PerlIO_stdstreams(aTHX);
3769 #undef PerlIO_stderr
3776 PerlIO_stdstreams(aTHX);
3781 /*--------------------------------------------------------------------------------------*/
3783 #undef PerlIO_getname
3785 PerlIO_getname(PerlIO *f, char *buf)
3790 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3791 if (stdio) name = fgetname(stdio, buf);
3793 Perl_croak(aTHX_ "Don't know how to get file name");
3799 /*--------------------------------------------------------------------------------------*/
3800 /* Functions which can be called on any kind of PerlIO implemented
3806 PerlIO_getc(PerlIO *f)
3809 SSize_t count = PerlIO_read(f,buf,1);
3812 return (unsigned char) buf[0];
3817 #undef PerlIO_ungetc
3819 PerlIO_ungetc(PerlIO *f, int ch)
3824 if (PerlIO_unread(f,&buf,1) == 1)
3832 PerlIO_putc(PerlIO *f, int ch)
3835 return PerlIO_write(f,&buf,1);
3840 PerlIO_puts(PerlIO *f, const char *s)
3842 STRLEN len = strlen(s);
3843 return PerlIO_write(f,s,len);
3846 #undef PerlIO_rewind
3848 PerlIO_rewind(PerlIO *f)
3850 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3854 #undef PerlIO_vprintf
3856 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3859 SV *sv = newSVpvn("",0);
3865 Perl_va_copy(ap, apc);
3866 sv_vcatpvf(sv, fmt, &apc);
3868 sv_vcatpvf(sv, fmt, &ap);
3871 wrote = PerlIO_write(f,s,len);
3876 #undef PerlIO_printf
3878 PerlIO_printf(PerlIO *f,const char *fmt,...)
3883 result = PerlIO_vprintf(f,fmt,ap);
3888 #undef PerlIO_stdoutf
3890 PerlIO_stdoutf(const char *fmt,...)
3895 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3900 #undef PerlIO_tmpfile
3902 PerlIO_tmpfile(void)
3904 /* I have no idea how portable mkstemp() is ... */
3905 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3908 FILE *stdio = PerlSIO_tmpfile();
3911 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3917 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3918 int fd = mkstemp(SvPVX(sv));
3922 f = PerlIO_fdopen(fd,"w+");
3925 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3927 PerlLIO_unlink(SvPVX(sv));
3937 #endif /* USE_SFIO */
3938 #endif /* PERLIO_IS_STDIO */
3940 /*======================================================================================*/
3941 /* Now some functions in terms of above which may be needed even if
3942 we are not in true PerlIO mode
3946 #undef PerlIO_setpos
3948 PerlIO_setpos(PerlIO *f, SV *pos)
3954 Off_t *posn = (Off_t *) SvPV(pos,len);
3955 if (f && len == sizeof(Off_t))
3956 return PerlIO_seek(f,*posn,SEEK_SET);
3958 SETERRNO(EINVAL,SS$_IVCHAN);
3962 #undef PerlIO_setpos
3964 PerlIO_setpos(PerlIO *f, SV *pos)
3970 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3971 if (f && len == sizeof(Fpos_t))
3973 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3974 return fsetpos64(f, fpos);
3976 return fsetpos(f, fpos);
3980 SETERRNO(EINVAL,SS$_IVCHAN);
3986 #undef PerlIO_getpos
3988 PerlIO_getpos(PerlIO *f, SV *pos)
3991 Off_t posn = PerlIO_tell(f);
3992 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3993 return (posn == (Off_t)-1) ? -1 : 0;
3996 #undef PerlIO_getpos
3998 PerlIO_getpos(PerlIO *f, SV *pos)
4003 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4004 code = fgetpos64(f, &fpos);
4006 code = fgetpos(f, &fpos);
4008 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4013 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4016 vprintf(char *pat, char *args)
4018 _doprnt(pat, args, stdout);
4019 return 0; /* wrong, but perl doesn't use the return value */
4023 vfprintf(FILE *fd, char *pat, char *args)
4025 _doprnt(pat, args, fd);
4026 return 0; /* wrong, but perl doesn't use the return value */
4031 #ifndef PerlIO_vsprintf
4033 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4035 int val = vsprintf(s, fmt, ap);
4038 if (strlen(s) >= (STRLEN)n)
4041 (void)PerlIO_puts(Perl_error_log,
4042 "panic: sprintf overflow - memory corrupted!\n");
4050 #ifndef PerlIO_sprintf
4052 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4057 result = PerlIO_vsprintf(s, n, fmt, ap);