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_funcs *osLayer = &PerlIO_unix;
768 PerlIO_def_layerlist = PerlIO_list_alloc();
770 osLayer = &PerlIO_win32;
771 PerlIO_define_layer(aTHX_ &PerlIO_unix);
773 osLayer = &PerlIO_unix;
775 PerlIO_define_layer(aTHX_ osLayer);
776 PerlIO_define_layer(aTHX_ &PerlIO_raw);
777 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
778 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
779 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
781 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
783 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
784 PerlIO_define_layer(aTHX_ &PerlIO_byte);
785 PerlIO_list_push(PerlIO_def_layerlist,PerlIO_find_layer(aTHX_ osLayer->name,0,0),&PL_sv_undef);
788 PerlIO_parse_layers(aTHX_ PerlIO_def_layerlist,s);
792 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
795 if (PerlIO_def_layerlist->cur < 2)
797 PerlIO_default_buffer(aTHX_ PerlIO_def_layerlist);
799 return PerlIO_def_layerlist;
803 Perl_boot_core_PerlIO(pTHX)
805 #ifdef USE_ATTRIBUTES_FOR_PERLIO
806 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
808 newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
812 PerlIO_default_layer(pTHX_ I32 n)
814 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
817 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
820 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
821 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
824 PerlIO_stdstreams(pTHX)
828 PerlIO_allocate(aTHX);
829 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
830 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
831 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
836 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
839 l = PerlMemShared_calloc(tab->size,sizeof(char));
842 Zero(l,tab->size,char);
846 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
847 (mode) ? mode : "(Null)",arg);
848 if ((*l->tab->Pushed)(f,mode,arg) != 0)
858 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
872 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
874 /* Remove the dummy layer */
877 /* Pop back to bottom layer */
881 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
889 /* Nothing bellow - push unix on top then remove it */
890 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
892 PerlIO_pop(aTHX_ PerlIONext(f));
897 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
904 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, PerlIO_list_t *layers, IV n)
906 IV max = layers->cur;
910 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
913 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
925 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
930 PerlIO_list_t *layers = PerlIO_list_alloc();
931 code = PerlIO_parse_layers(aTHX_ layers,names);
934 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
936 PerlIO_list_free(layers);
942 /*--------------------------------------------------------------------------------------*/
943 /* Given the abstraction above the public API functions */
946 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
948 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
949 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
950 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
956 if (PerlIOBase(top)->tab == &PerlIO_crlf)
959 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
962 top = PerlIONext(top);
965 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
970 PerlIO__close(PerlIO *f)
973 return (*PerlIOBase(f)->tab->Close)(f);
976 SETERRNO(EBADF,SS$_IVCHAN);
981 #undef PerlIO_fdupopen
983 PerlIO_fdupopen(pTHX_ PerlIO *f)
988 int fd = PerlLIO_dup(PerlIO_fileno(f));
989 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
992 Off_t posn = PerlIO_tell(f);
993 PerlIO_seek(new,posn,SEEK_SET);
999 SETERRNO(EBADF,SS$_IVCHAN);
1006 PerlIO_close(PerlIO *f)
1012 code = (*PerlIOBase(f)->tab->Close)(f);
1015 PerlIO_pop(aTHX_ f);
1021 #undef PerlIO_fileno
1023 PerlIO_fileno(PerlIO *f)
1026 return (*PerlIOBase(f)->tab->Fileno)(f);
1029 SETERRNO(EBADF,SS$_IVCHAN);
1035 PerlIO_context_layers(pTHX_ const char *mode)
1037 const char *type = NULL;
1038 /* Need to supply default layer info from open.pm */
1041 SV *layers = PL_curcop->cop_io;
1045 type = SvPV(layers,len);
1046 if (type && mode[0] != 'r')
1048 /* Skip to write part */
1049 const char *s = strchr(type,0);
1050 if (s && (s-type) < len)
1060 static PerlIO_funcs *
1061 PerlIO_layer_from_ref(pTHX_ SV *sv)
1063 /* For any scalar type load the handler which is bundled with perl */
1064 if (SvTYPE(sv) < SVt_PVAV)
1065 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
1067 /* For other types allow if layer is known but don't try and load it */
1071 return PerlIO_find_layer(aTHX_ "Array",5, 0);
1073 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
1075 return PerlIO_find_layer(aTHX_ "Code",4, 0);
1077 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
1083 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
1085 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1088 PerlIO_stdstreams(aTHX);
1092 /* If it is a reference but not an object see if we have a handler for it */
1093 if (SvROK(arg) && !sv_isobject(arg))
1095 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1098 def = PerlIO_list_alloc();
1099 PerlIO_list_push(def,handler,&PL_sv_undef);
1102 /* Don't fail if handler cannot be found
1103 * :Via(...) etc. may do something sensible
1104 * else we will just stringfy and open resulting string.
1109 layers = PerlIO_context_layers(aTHX_ mode);
1110 if (layers && *layers)
1116 av = PerlIO_list_alloc();
1117 for (i=0; i < def->cur; i++)
1119 PerlIO_list_push(av,def->array[i].funcs,def->array[i].arg);
1126 PerlIO_parse_layers(aTHX_ av,layers);
1138 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1140 if (!f && narg == 1 && *args == &PL_sv_undef)
1142 if ((f = PerlIO_tmpfile()))
1145 layers = PerlIO_context_layers(aTHX_ mode);
1146 if (layers && *layers)
1147 PerlIO_apply_layers(aTHX_ f,mode,layers);
1152 PerlIO_list_t *layera = NULL;
1154 PerlIO_funcs *tab = NULL;
1157 /* This is "reopen" - it is not tested as perl does not use it yet */
1159 layera = PerlIO_list_alloc();
1162 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1163 PerlIO_list_push(layera,l->tab,arg);
1164 l = *PerlIONext(&l);
1169 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1171 /* Start at "top" of layer stack */
1175 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1185 /* Found that layer 'n' can do opens - call it */
1186 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1187 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1188 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1191 if (n+1 < layera->cur)
1193 /* More layers above the one that we used to open - apply them now */
1194 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+1) != 0)
1201 PerlIO_list_free(layera);
1207 #undef PerlIO_fdopen
1209 PerlIO_fdopen(int fd, const char *mode)
1212 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1217 PerlIO_open(const char *path, const char *mode)
1220 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1221 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1224 #undef PerlIO_reopen
1226 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1229 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1230 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1235 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1238 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1241 SETERRNO(EBADF,SS$_IVCHAN);
1246 #undef PerlIO_unread
1248 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1251 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1254 SETERRNO(EBADF,SS$_IVCHAN);
1261 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1264 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1267 SETERRNO(EBADF,SS$_IVCHAN);
1274 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1277 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1280 SETERRNO(EBADF,SS$_IVCHAN);
1287 PerlIO_tell(PerlIO *f)
1290 return (*PerlIOBase(f)->tab->Tell)(f);
1293 SETERRNO(EBADF,SS$_IVCHAN);
1300 PerlIO_flush(PerlIO *f)
1306 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1307 if (tab && tab->Flush)
1309 return (*tab->Flush)(f);
1313 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1314 SETERRNO(EBADF,SS$_IVCHAN);
1320 PerlIO_debug("Cannot flush f=%p\n",f);
1321 SETERRNO(EBADF,SS$_IVCHAN);
1327 /* Is it good API design to do flush-all on NULL,
1328 * a potentially errorneous input? Maybe some magical
1329 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1330 * Yes, stdio does similar things on fflush(NULL),
1331 * but should we be bound by their design decisions?
1333 PerlIO **table = &_perlio;
1335 while ((f = *table))
1338 table = (PerlIO **)(f++);
1339 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1341 if (*f && PerlIO_flush(f) != 0)
1351 PerlIOBase_flush_linebuf()
1353 PerlIO **table = &_perlio;
1355 while ((f = *table))
1358 table = (PerlIO **)(f++);
1359 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1361 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1362 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1371 PerlIO_fill(PerlIO *f)
1374 return (*PerlIOBase(f)->tab->Fill)(f);
1377 SETERRNO(EBADF,SS$_IVCHAN);
1382 #undef PerlIO_isutf8
1384 PerlIO_isutf8(PerlIO *f)
1387 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1390 SETERRNO(EBADF,SS$_IVCHAN);
1397 PerlIO_eof(PerlIO *f)
1400 return (*PerlIOBase(f)->tab->Eof)(f);
1403 SETERRNO(EBADF,SS$_IVCHAN);
1410 PerlIO_error(PerlIO *f)
1413 return (*PerlIOBase(f)->tab->Error)(f);
1416 SETERRNO(EBADF,SS$_IVCHAN);
1421 #undef PerlIO_clearerr
1423 PerlIO_clearerr(PerlIO *f)
1426 (*PerlIOBase(f)->tab->Clearerr)(f);
1428 SETERRNO(EBADF,SS$_IVCHAN);
1431 #undef PerlIO_setlinebuf
1433 PerlIO_setlinebuf(PerlIO *f)
1436 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1438 SETERRNO(EBADF,SS$_IVCHAN);
1441 #undef PerlIO_has_base
1443 PerlIO_has_base(PerlIO *f)
1445 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1449 #undef PerlIO_fast_gets
1451 PerlIO_fast_gets(PerlIO *f)
1453 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1455 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1456 return (tab->Set_ptrcnt != NULL);
1461 #undef PerlIO_has_cntptr
1463 PerlIO_has_cntptr(PerlIO *f)
1467 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1468 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1473 #undef PerlIO_canset_cnt
1475 PerlIO_canset_cnt(PerlIO *f)
1479 PerlIOl *l = PerlIOBase(f);
1480 return (l->tab->Set_ptrcnt != NULL);
1485 #undef PerlIO_get_base
1487 PerlIO_get_base(PerlIO *f)
1490 return (*PerlIOBase(f)->tab->Get_base)(f);
1494 #undef PerlIO_get_bufsiz
1496 PerlIO_get_bufsiz(PerlIO *f)
1499 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1503 #undef PerlIO_get_ptr
1505 PerlIO_get_ptr(PerlIO *f)
1507 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1508 if (tab->Get_ptr == NULL)
1510 return (*tab->Get_ptr)(f);
1513 #undef PerlIO_get_cnt
1515 PerlIO_get_cnt(PerlIO *f)
1517 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1518 if (tab->Get_cnt == NULL)
1520 return (*tab->Get_cnt)(f);
1523 #undef PerlIO_set_cnt
1525 PerlIO_set_cnt(PerlIO *f,int cnt)
1527 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1530 #undef PerlIO_set_ptrcnt
1532 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1534 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1535 if (tab->Set_ptrcnt == NULL)
1538 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1540 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1543 /*--------------------------------------------------------------------------------------*/
1544 /* utf8 and raw dummy layers */
1547 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1552 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1553 PerlIO_pop(aTHX_ f);
1554 if (tab->kind & PERLIO_K_UTF8)
1555 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1557 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1563 PerlIO_funcs PerlIO_utf8 = {
1566 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1584 NULL, /* get_base */
1585 NULL, /* get_bufsiz */
1588 NULL, /* set_ptrcnt */
1591 PerlIO_funcs PerlIO_byte = {
1612 NULL, /* get_base */
1613 NULL, /* get_bufsiz */
1616 NULL, /* set_ptrcnt */
1620 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)
1622 PerlIO_funcs *tab = PerlIO_default_btm();
1623 return (*tab->Open)(aTHX_ tab,layers,n-1,mode,fd,imode,perm,old,narg,args);
1626 PerlIO_funcs PerlIO_raw = {
1647 NULL, /* get_base */
1648 NULL, /* get_bufsiz */
1651 NULL, /* set_ptrcnt */
1653 /*--------------------------------------------------------------------------------------*/
1654 /*--------------------------------------------------------------------------------------*/
1655 /* "Methods" of the "base class" */
1658 PerlIOBase_fileno(PerlIO *f)
1660 return PerlIO_fileno(PerlIONext(f));
1664 PerlIO_modestr(PerlIO *f,char *buf)
1667 IV flags = PerlIOBase(f)->flags;
1668 if (flags & PERLIO_F_APPEND)
1671 if (flags & PERLIO_F_CANREAD)
1676 else if (flags & PERLIO_F_CANREAD)
1679 if (flags & PERLIO_F_CANWRITE)
1682 else if (flags & PERLIO_F_CANWRITE)
1685 if (flags & PERLIO_F_CANREAD)
1690 #if O_TEXT != O_BINARY
1691 if (!(flags & PERLIO_F_CRLF))
1699 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1701 PerlIOl *l = PerlIOBase(f);
1703 const char *omode = mode;
1706 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1707 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1708 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1709 if (tab->Set_ptrcnt != NULL)
1710 l->flags |= PERLIO_F_FASTGETS;
1713 if (*mode == '#' || *mode == 'I')
1718 l->flags |= PERLIO_F_CANREAD;
1721 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1724 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1727 SETERRNO(EINVAL,LIB$_INVARG);
1735 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1738 l->flags &= ~PERLIO_F_CRLF;
1741 l->flags |= PERLIO_F_CRLF;
1744 SETERRNO(EINVAL,LIB$_INVARG);
1753 l->flags |= l->next->flags &
1754 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1758 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1759 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1760 l->flags,PerlIO_modestr(f,temp));
1766 PerlIOBase_popped(PerlIO *f)
1772 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1775 Off_t old = PerlIO_tell(f);
1777 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1778 done = PerlIOBuf_unread(f,vbuf,count);
1779 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1784 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1786 STDCHAR *buf = (STDCHAR *) vbuf;
1789 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1793 SSize_t avail = PerlIO_get_cnt(f);
1796 take = (count < avail) ? count : avail;
1799 STDCHAR *ptr = PerlIO_get_ptr(f);
1800 Copy(ptr,buf,take,STDCHAR);
1801 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1805 if (count > 0 && avail <= 0)
1807 if (PerlIO_fill(f) != 0)
1811 return (buf - (STDCHAR *) vbuf);
1817 PerlIOBase_noop_ok(PerlIO *f)
1823 PerlIOBase_noop_fail(PerlIO *f)
1829 PerlIOBase_close(PerlIO *f)
1832 PerlIO *n = PerlIONext(f);
1833 if (PerlIO_flush(f) != 0)
1835 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1837 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1842 PerlIOBase_eof(PerlIO *f)
1846 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1852 PerlIOBase_error(PerlIO *f)
1856 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1862 PerlIOBase_clearerr(PerlIO *f)
1866 PerlIO *n = PerlIONext(f);
1867 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1874 PerlIOBase_setlinebuf(PerlIO *f)
1878 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1882 /*--------------------------------------------------------------------------------------*/
1883 /* Bottom-most level for UNIX-like case */
1887 struct _PerlIO base; /* The generic part */
1888 int fd; /* UNIX like file descriptor */
1889 int oflags; /* open/fcntl flags */
1893 PerlIOUnix_oflags(const char *mode)
1896 if (*mode == 'I' || *mode == '#')
1910 oflags = O_CREAT|O_TRUNC;
1921 oflags = O_CREAT|O_APPEND;
1937 else if (*mode == 't')
1940 oflags &= ~O_BINARY;
1943 /* Always open in binary mode */
1945 if (*mode || oflags == -1)
1947 SETERRNO(EINVAL,LIB$_INVARG);
1954 PerlIOUnix_fileno(PerlIO *f)
1956 return PerlIOSelf(f,PerlIOUnix)->fd;
1960 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1962 IV code = PerlIOBase_pushed(f,mode,arg);
1965 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1966 s->fd = PerlIO_fileno(PerlIONext(f));
1967 s->oflags = PerlIOUnix_oflags(mode);
1969 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1974 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)
1978 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1979 (*PerlIOBase(f)->tab->Close)(f);
1983 char *path = SvPV_nolen(*args);
1988 imode = PerlIOUnix_oflags(mode);
1993 fd = PerlLIO_open3(path,imode,perm);
2003 f = PerlIO_allocate(aTHX);
2004 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
2007 s = PerlIOSelf(f,PerlIOUnix);
2010 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2017 /* FIXME: pop layers ??? */
2024 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2027 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2028 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2032 SSize_t len = PerlLIO_read(fd,vbuf,count);
2033 if (len >= 0 || errno != EINTR)
2036 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2037 else if (len == 0 && count != 0)
2038 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2046 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2049 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2052 SSize_t len = PerlLIO_write(fd,vbuf,count);
2053 if (len >= 0 || errno != EINTR)
2056 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2064 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2067 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
2068 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2069 return (new == (Off_t) -1) ? -1 : 0;
2073 PerlIOUnix_tell(PerlIO *f)
2076 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
2080 PerlIOUnix_close(PerlIO *f)
2083 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2085 while (PerlLIO_close(fd) != 0)
2096 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2101 PerlIO_funcs PerlIO_unix = {
2116 PerlIOBase_noop_ok, /* flush */
2117 PerlIOBase_noop_fail, /* fill */
2120 PerlIOBase_clearerr,
2121 PerlIOBase_setlinebuf,
2122 NULL, /* get_base */
2123 NULL, /* get_bufsiz */
2126 NULL, /* set_ptrcnt */
2129 /*--------------------------------------------------------------------------------------*/
2130 /* stdio as a layer */
2134 struct _PerlIO base;
2135 FILE * stdio; /* The stream */
2139 PerlIOStdio_fileno(PerlIO *f)
2142 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2146 PerlIOStdio_mode(const char *mode,char *tmode)
2153 if (O_BINARY != O_TEXT)
2161 /* This isn't used yet ... */
2163 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2168 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2170 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2176 return PerlIOBase_pushed(f,mode,arg);
2179 #undef PerlIO_importFILE
2181 PerlIO_importFILE(FILE *stdio, int fl)
2187 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2194 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)
2199 char *path = SvPV_nolen(*args);
2200 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2201 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2211 char *path = SvPV_nolen(*args);
2215 fd = PerlLIO_open3(path,imode,perm);
2219 FILE *stdio = PerlSIO_fopen(path,mode);
2222 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2223 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2244 stdio = PerlSIO_stdin;
2247 stdio = PerlSIO_stdout;
2250 stdio = PerlSIO_stderr;
2256 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2260 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2270 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2273 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2277 STDCHAR *buf = (STDCHAR *) vbuf;
2278 /* Perl is expecting PerlIO_getc() to fill the buffer
2279 * Linux's stdio does not do that for fread()
2281 int ch = PerlSIO_fgetc(s);
2289 got = PerlSIO_fread(vbuf,1,count,s);
2294 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2297 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2298 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2302 int ch = *buf-- & 0xff;
2303 if (PerlSIO_ungetc(ch,s) != ch)
2312 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2315 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2319 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2322 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2323 return PerlSIO_fseek(stdio,offset,whence);
2327 PerlIOStdio_tell(PerlIO *f)
2330 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2331 return PerlSIO_ftell(stdio);
2335 PerlIOStdio_close(PerlIO *f)
2338 #ifdef SOCKS5_VERSION_NAME
2340 Sock_size_t optlen = sizeof(int);
2342 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2344 #ifdef SOCKS5_VERSION_NAME
2345 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2346 PerlSIO_fclose(stdio) :
2347 close(PerlIO_fileno(f))
2349 PerlSIO_fclose(stdio)
2356 PerlIOStdio_flush(PerlIO *f)
2359 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2360 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2362 return PerlSIO_fflush(stdio);
2367 /* FIXME: This discards ungetc() and pre-read stuff which is
2368 not right if this is just a "sync" from a layer above
2369 Suspect right design is to do _this_ but not have layer above
2370 flush this layer read-to-read
2372 /* Not writeable - sync by attempting a seek */
2374 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2382 PerlIOStdio_fill(PerlIO *f)
2385 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2387 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2388 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2390 if (PerlSIO_fflush(stdio) != 0)
2393 c = PerlSIO_fgetc(stdio);
2394 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2400 PerlIOStdio_eof(PerlIO *f)
2403 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2407 PerlIOStdio_error(PerlIO *f)
2410 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2414 PerlIOStdio_clearerr(PerlIO *f)
2417 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2421 PerlIOStdio_setlinebuf(PerlIO *f)
2424 #ifdef HAS_SETLINEBUF
2425 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2427 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2433 PerlIOStdio_get_base(PerlIO *f)
2436 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2437 return PerlSIO_get_base(stdio);
2441 PerlIOStdio_get_bufsiz(PerlIO *f)
2444 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2445 return PerlSIO_get_bufsiz(stdio);
2449 #ifdef USE_STDIO_PTR
2451 PerlIOStdio_get_ptr(PerlIO *f)
2454 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2455 return PerlSIO_get_ptr(stdio);
2459 PerlIOStdio_get_cnt(PerlIO *f)
2462 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2463 return PerlSIO_get_cnt(stdio);
2467 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2469 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2473 #ifdef STDIO_PTR_LVALUE
2474 PerlSIO_set_ptr(stdio,ptr);
2475 #ifdef STDIO_PTR_LVAL_SETS_CNT
2476 if (PerlSIO_get_cnt(stdio) != (cnt))
2479 assert(PerlSIO_get_cnt(stdio) == (cnt));
2482 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2483 /* Setting ptr _does_ change cnt - we are done */
2486 #else /* STDIO_PTR_LVALUE */
2488 #endif /* STDIO_PTR_LVALUE */
2490 /* Now (or only) set cnt */
2491 #ifdef STDIO_CNT_LVALUE
2492 PerlSIO_set_cnt(stdio,cnt);
2493 #else /* STDIO_CNT_LVALUE */
2494 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2495 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2496 #else /* STDIO_PTR_LVAL_SETS_CNT */
2498 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2499 #endif /* STDIO_CNT_LVALUE */
2504 PerlIO_funcs PerlIO_stdio = {
2506 sizeof(PerlIOStdio),
2523 PerlIOStdio_clearerr,
2524 PerlIOStdio_setlinebuf,
2526 PerlIOStdio_get_base,
2527 PerlIOStdio_get_bufsiz,
2532 #ifdef USE_STDIO_PTR
2533 PerlIOStdio_get_ptr,
2534 PerlIOStdio_get_cnt,
2535 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2536 PerlIOStdio_set_ptrcnt
2537 #else /* STDIO_PTR_LVALUE */
2539 #endif /* STDIO_PTR_LVALUE */
2540 #else /* USE_STDIO_PTR */
2544 #endif /* USE_STDIO_PTR */
2547 #undef PerlIO_exportFILE
2549 PerlIO_exportFILE(PerlIO *f, int fl)
2553 stdio = fdopen(PerlIO_fileno(f),"r+");
2557 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2563 #undef PerlIO_findFILE
2565 PerlIO_findFILE(PerlIO *f)
2570 if (l->tab == &PerlIO_stdio)
2572 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2575 l = *PerlIONext(&l);
2577 return PerlIO_exportFILE(f,0);
2580 #undef PerlIO_releaseFILE
2582 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2586 /*--------------------------------------------------------------------------------------*/
2587 /* perlio buffer layer */
2590 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2593 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2594 int fd = PerlIO_fileno(f);
2596 if (fd >= 0 && PerlLIO_isatty(fd))
2598 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2600 posn = PerlIO_tell(PerlIONext(f));
2601 if (posn != (Off_t) -1)
2605 return PerlIOBase_pushed(f,mode,arg);
2609 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)
2613 PerlIO *next = PerlIONext(f);
2614 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2615 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
2616 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2623 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
2630 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
2633 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
2634 fd = PerlIO_fileno(f);
2635 #if O_BINARY != O_TEXT
2636 /* do something about failing setmode()? --jhi */
2637 PerlLIO_setmode(fd , O_BINARY);
2639 if (init && fd == 2)
2641 /* Initial stderr is unbuffered */
2642 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2649 /* This "flush" is akin to sfio's sync in that it handles files in either
2653 PerlIOBuf_flush(PerlIO *f)
2655 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2657 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2659 /* write() the buffer */
2660 STDCHAR *buf = b->buf;
2662 PerlIO *n = PerlIONext(f);
2665 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2670 else if (count < 0 || PerlIO_error(n))
2672 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2677 b->posn += (p - buf);
2679 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2681 STDCHAR *buf = PerlIO_get_base(f);
2682 /* Note position change */
2683 b->posn += (b->ptr - buf);
2684 if (b->ptr < b->end)
2686 /* We did not consume all of it */
2687 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2689 b->posn = PerlIO_tell(PerlIONext(f));
2693 b->ptr = b->end = b->buf;
2694 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2695 /* FIXME: Is this right for read case ? */
2696 if (PerlIO_flush(PerlIONext(f)) != 0)
2702 PerlIOBuf_fill(PerlIO *f)
2704 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2705 PerlIO *n = PerlIONext(f);
2707 /* FIXME: doing the down-stream flush is a bad idea if it causes
2708 pre-read data in stdio buffer to be discarded
2709 but this is too simplistic - as it skips _our_ hosekeeping
2710 and breaks tell tests.
2711 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2715 if (PerlIO_flush(f) != 0)
2717 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2718 PerlIOBase_flush_linebuf();
2721 PerlIO_get_base(f); /* allocate via vtable */
2723 b->ptr = b->end = b->buf;
2724 if (PerlIO_fast_gets(n))
2726 /* Layer below is also buffered
2727 * We do _NOT_ want to call its ->Read() because that will loop
2728 * till it gets what we asked for which may hang on a pipe etc.
2729 * Instead take anything it has to hand, or ask it to fill _once_.
2731 avail = PerlIO_get_cnt(n);
2734 avail = PerlIO_fill(n);
2736 avail = PerlIO_get_cnt(n);
2739 if (!PerlIO_error(n) && PerlIO_eof(n))
2745 STDCHAR *ptr = PerlIO_get_ptr(n);
2746 SSize_t cnt = avail;
2747 if (avail > b->bufsiz)
2749 Copy(ptr,b->buf,avail,STDCHAR);
2750 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2755 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2760 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2762 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2765 b->end = b->buf+avail;
2766 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2771 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2773 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2778 return PerlIOBase_read(f,vbuf,count);
2784 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2786 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2787 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2790 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2796 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2798 avail = (b->ptr - b->buf);
2803 b->end = b->buf + avail;
2805 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2806 b->posn -= b->bufsiz;
2808 if (avail > (SSize_t) count)
2816 Copy(buf,b->ptr,avail,STDCHAR);
2820 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2827 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2829 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2830 const STDCHAR *buf = (const STDCHAR *) vbuf;
2834 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2838 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2839 if ((SSize_t) count < avail)
2841 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2842 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2862 Copy(buf,b->ptr,avail,STDCHAR);
2869 if (b->ptr >= (b->buf + b->bufsiz))
2872 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2878 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2881 if ((code = PerlIO_flush(f)) == 0)
2883 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2884 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2885 code = PerlIO_seek(PerlIONext(f),offset,whence);
2888 b->posn = PerlIO_tell(PerlIONext(f));
2895 PerlIOBuf_tell(PerlIO *f)
2897 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2898 Off_t posn = b->posn;
2900 posn += (b->ptr - b->buf);
2905 PerlIOBuf_close(PerlIO *f)
2907 IV code = PerlIOBase_close(f);
2908 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2909 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2911 PerlMemShared_free(b->buf);
2914 b->ptr = b->end = b->buf;
2915 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2920 PerlIOBuf_get_ptr(PerlIO *f)
2922 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2929 PerlIOBuf_get_cnt(PerlIO *f)
2931 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2934 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2935 return (b->end - b->ptr);
2940 PerlIOBuf_get_base(PerlIO *f)
2942 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2947 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2950 b->buf = (STDCHAR *)&b->oneword;
2951 b->bufsiz = sizeof(b->oneword);
2960 PerlIOBuf_bufsiz(PerlIO *f)
2962 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2965 return (b->end - b->buf);
2969 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2971 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2975 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2978 assert(PerlIO_get_cnt(f) == cnt);
2979 assert(b->ptr >= b->buf);
2981 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2984 PerlIO_funcs PerlIO_perlio = {
3003 PerlIOBase_clearerr,
3004 PerlIOBase_setlinebuf,
3009 PerlIOBuf_set_ptrcnt,
3012 /*--------------------------------------------------------------------------------------*/
3013 /* Temp layer to hold unread chars when cannot do it any other way */
3016 PerlIOPending_fill(PerlIO *f)
3018 /* Should never happen */
3024 PerlIOPending_close(PerlIO *f)
3026 /* A tad tricky - flush pops us, then we close new top */
3028 return PerlIO_close(f);
3032 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3034 /* A tad tricky - flush pops us, then we seek new top */
3036 return PerlIO_seek(f,offset,whence);
3041 PerlIOPending_flush(PerlIO *f)
3044 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3045 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3047 PerlMemShared_free(b->buf);
3050 PerlIO_pop(aTHX_ f);
3055 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3063 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3068 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
3070 IV code = PerlIOBase_pushed(f,mode,arg);
3071 PerlIOl *l = PerlIOBase(f);
3072 /* Our PerlIO_fast_gets must match what we are pushed on,
3073 or sv_gets() etc. get muddled when it changes mid-string
3076 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3077 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
3082 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3084 SSize_t avail = PerlIO_get_cnt(f);
3089 got = PerlIOBuf_read(f,vbuf,avail);
3090 if (got >= 0 && got < count)
3092 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3093 if (more >= 0 || got == 0)
3099 PerlIO_funcs PerlIO_pending = {
3103 PerlIOPending_pushed,
3113 PerlIOPending_close,
3114 PerlIOPending_flush,
3118 PerlIOBase_clearerr,
3119 PerlIOBase_setlinebuf,
3124 PerlIOPending_set_ptrcnt,
3129 /*--------------------------------------------------------------------------------------*/
3130 /* crlf - translation
3131 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
3132 to hand back a line at a time and keeping a record of which nl we "lied" about.
3133 On write translate "\n" to CR,LF
3138 PerlIOBuf base; /* PerlIOBuf stuff */
3139 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
3143 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3146 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3147 code = PerlIOBuf_pushed(f,mode,arg);
3149 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3150 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3151 PerlIOBase(f)->flags);
3158 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3160 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3166 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3167 return PerlIOBuf_unread(f,vbuf,count);
3170 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3171 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3173 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3179 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3181 b->end = b->ptr = b->buf + b->bufsiz;
3182 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3183 b->posn -= b->bufsiz;
3185 while (count > 0 && b->ptr > b->buf)
3190 if (b->ptr - 2 >= b->buf)
3216 PerlIOCrlf_get_cnt(PerlIO *f)
3218 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3221 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3223 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3224 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3226 STDCHAR *nl = b->ptr;
3228 while (nl < b->end && *nl != 0xd)
3230 if (nl < b->end && *nl == 0xd)
3242 /* Not CR,LF but just CR */
3249 /* Blast - found CR as last char in buffer */
3252 /* They may not care, defer work as long as possible */
3253 return (nl - b->ptr);
3258 b->ptr++; /* say we have read it as far as flush() is concerned */
3259 b->buf++; /* Leave space an front of buffer */
3260 b->bufsiz--; /* Buffer is thus smaller */
3261 code = PerlIO_fill(f); /* Fetch some more */
3262 b->bufsiz++; /* Restore size for next time */
3263 b->buf--; /* Point at space */
3264 b->ptr = nl = b->buf; /* Which is what we hand off */
3265 b->posn--; /* Buffer starts here */
3266 *nl = 0xd; /* Fill in the CR */
3268 goto test; /* fill() call worked */
3269 /* CR at EOF - just fall through */
3274 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3280 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3282 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3283 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3284 IV flags = PerlIOBase(f)->flags;
3294 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3301 /* Test code - delete when it works ... */
3308 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3316 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3317 ptr, chk, flags, c->nl, b->end, cnt);
3324 /* They have taken what we lied about */
3331 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3335 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3337 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3338 return PerlIOBuf_write(f,vbuf,count);
3341 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3342 const STDCHAR *buf = (const STDCHAR *) vbuf;
3343 const STDCHAR *ebuf = buf+count;
3346 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3350 STDCHAR *eptr = b->buf+b->bufsiz;
3351 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3352 while (buf < ebuf && b->ptr < eptr)
3356 if ((b->ptr + 2) > eptr)
3358 /* Not room for both */
3364 *(b->ptr)++ = 0xd; /* CR */
3365 *(b->ptr)++ = 0xa; /* LF */
3367 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3386 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3388 return (buf - (STDCHAR *) vbuf);
3393 PerlIOCrlf_flush(PerlIO *f)
3395 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3401 return PerlIOBuf_flush(f);
3404 PerlIO_funcs PerlIO_crlf = {
3407 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3409 PerlIOBase_noop_ok, /* popped */
3413 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3414 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3415 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3423 PerlIOBase_clearerr,
3424 PerlIOBase_setlinebuf,
3429 PerlIOCrlf_set_ptrcnt,
3433 /*--------------------------------------------------------------------------------------*/
3434 /* mmap as "buffer" layer */
3438 PerlIOBuf base; /* PerlIOBuf stuff */
3439 Mmap_t mptr; /* Mapped address */
3440 Size_t len; /* mapped length */
3441 STDCHAR *bbuf; /* malloced buffer if map fails */
3444 static size_t page_size = 0;
3447 PerlIOMmap_map(PerlIO *f)
3450 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3451 IV flags = PerlIOBase(f)->flags;
3455 if (flags & PERLIO_F_CANREAD)
3457 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3458 int fd = PerlIO_fileno(f);
3460 code = fstat(fd,&st);
3461 if (code == 0 && S_ISREG(st.st_mode))
3463 SSize_t len = st.st_size - b->posn;
3468 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3470 SETERRNO(0,SS$_NORMAL);
3471 # ifdef _SC_PAGESIZE
3472 page_size = sysconf(_SC_PAGESIZE);
3474 page_size = sysconf(_SC_PAGE_SIZE);
3476 if ((long)page_size < 0) {
3481 (void)SvUPGRADE(error, SVt_PV);
3482 msg = SvPVx(error, n_a);
3483 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3486 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3490 # ifdef HAS_GETPAGESIZE
3491 page_size = getpagesize();
3493 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3494 page_size = PAGESIZE; /* compiletime, bad */
3498 if ((IV)page_size <= 0)
3499 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3503 /* This is a hack - should never happen - open should have set it ! */
3504 b->posn = PerlIO_tell(PerlIONext(f));
3506 posn = (b->posn / page_size) * page_size;
3507 len = st.st_size - posn;
3508 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3509 if (m->mptr && m->mptr != (Mmap_t) -1)
3511 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3512 madvise(m->mptr, len, MADV_SEQUENTIAL);
3514 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3515 madvise(m->mptr, len, MADV_WILLNEED);
3517 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3518 b->end = ((STDCHAR *)m->mptr) + len;
3519 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3530 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3532 b->ptr = b->end = b->ptr;
3541 PerlIOMmap_unmap(PerlIO *f)
3543 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3544 PerlIOBuf *b = &m->base;
3550 code = munmap(m->mptr, m->len);
3554 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3557 b->ptr = b->end = b->buf;
3558 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3564 PerlIOMmap_get_base(PerlIO *f)
3566 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3567 PerlIOBuf *b = &m->base;
3568 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3570 /* Already have a readbuffer in progress */
3575 /* We have a write buffer or flushed PerlIOBuf read buffer */
3576 m->bbuf = b->buf; /* save it in case we need it again */
3577 b->buf = NULL; /* Clear to trigger below */
3581 PerlIOMmap_map(f); /* Try and map it */
3584 /* Map did not work - recover PerlIOBuf buffer if we have one */
3588 b->ptr = b->end = b->buf;
3591 return PerlIOBuf_get_base(f);
3595 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3597 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3598 PerlIOBuf *b = &m->base;
3599 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3601 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3604 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3609 /* Loose the unwritable mapped buffer */
3611 /* If flush took the "buffer" see if we have one from before */
3612 if (!b->buf && m->bbuf)
3616 PerlIOBuf_get_base(f);
3620 return PerlIOBuf_unread(f,vbuf,count);
3624 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3626 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3627 PerlIOBuf *b = &m->base;
3628 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3630 /* No, or wrong sort of, buffer */
3633 if (PerlIOMmap_unmap(f) != 0)
3636 /* If unmap took the "buffer" see if we have one from before */
3637 if (!b->buf && m->bbuf)
3641 PerlIOBuf_get_base(f);
3645 return PerlIOBuf_write(f,vbuf,count);
3649 PerlIOMmap_flush(PerlIO *f)
3651 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3652 PerlIOBuf *b = &m->base;
3653 IV code = PerlIOBuf_flush(f);
3654 /* Now we are "synced" at PerlIOBuf level */
3659 /* Unmap the buffer */
3660 if (PerlIOMmap_unmap(f) != 0)
3665 /* We seem to have a PerlIOBuf buffer which was not mapped
3666 * remember it in case we need one later
3675 PerlIOMmap_fill(PerlIO *f)
3677 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3678 IV code = PerlIO_flush(f);
3679 if (code == 0 && !b->buf)
3681 code = PerlIOMmap_map(f);
3683 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3685 code = PerlIOBuf_fill(f);
3691 PerlIOMmap_close(PerlIO *f)
3693 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3694 PerlIOBuf *b = &m->base;
3695 IV code = PerlIO_flush(f);
3700 b->ptr = b->end = b->buf;
3702 if (PerlIOBuf_close(f) != 0)
3708 PerlIO_funcs PerlIO_mmap = {
3727 PerlIOBase_clearerr,
3728 PerlIOBase_setlinebuf,
3729 PerlIOMmap_get_base,
3733 PerlIOBuf_set_ptrcnt,
3736 #endif /* HAS_MMAP */
3743 call_atexit(PerlIO_cleanup_layers, NULL);
3748 atexit(&PerlIO_cleanup);
3760 PerlIO_stdstreams(aTHX);
3765 #undef PerlIO_stdout
3772 PerlIO_stdstreams(aTHX);
3777 #undef PerlIO_stderr
3784 PerlIO_stdstreams(aTHX);
3789 /*--------------------------------------------------------------------------------------*/
3791 #undef PerlIO_getname
3793 PerlIO_getname(PerlIO *f, char *buf)
3798 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3799 if (stdio) name = fgetname(stdio, buf);
3801 Perl_croak(aTHX_ "Don't know how to get file name");
3807 /*--------------------------------------------------------------------------------------*/
3808 /* Functions which can be called on any kind of PerlIO implemented
3814 PerlIO_getc(PerlIO *f)
3817 SSize_t count = PerlIO_read(f,buf,1);
3820 return (unsigned char) buf[0];
3825 #undef PerlIO_ungetc
3827 PerlIO_ungetc(PerlIO *f, int ch)
3832 if (PerlIO_unread(f,&buf,1) == 1)
3840 PerlIO_putc(PerlIO *f, int ch)
3843 return PerlIO_write(f,&buf,1);
3848 PerlIO_puts(PerlIO *f, const char *s)
3850 STRLEN len = strlen(s);
3851 return PerlIO_write(f,s,len);
3854 #undef PerlIO_rewind
3856 PerlIO_rewind(PerlIO *f)
3858 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3862 #undef PerlIO_vprintf
3864 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3867 SV *sv = newSVpvn("",0);
3873 Perl_va_copy(ap, apc);
3874 sv_vcatpvf(sv, fmt, &apc);
3876 sv_vcatpvf(sv, fmt, &ap);
3879 wrote = PerlIO_write(f,s,len);
3884 #undef PerlIO_printf
3886 PerlIO_printf(PerlIO *f,const char *fmt,...)
3891 result = PerlIO_vprintf(f,fmt,ap);
3896 #undef PerlIO_stdoutf
3898 PerlIO_stdoutf(const char *fmt,...)
3903 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3908 #undef PerlIO_tmpfile
3910 PerlIO_tmpfile(void)
3912 /* I have no idea how portable mkstemp() is ... */
3913 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3916 FILE *stdio = PerlSIO_tmpfile();
3919 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3925 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3926 int fd = mkstemp(SvPVX(sv));
3930 f = PerlIO_fdopen(fd,"w+");
3933 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3935 PerlLIO_unlink(SvPVX(sv));
3945 #endif /* USE_SFIO */
3946 #endif /* PERLIO_IS_STDIO */
3948 /*======================================================================================*/
3949 /* Now some functions in terms of above which may be needed even if
3950 we are not in true PerlIO mode
3954 #undef PerlIO_setpos
3956 PerlIO_setpos(PerlIO *f, SV *pos)
3962 Off_t *posn = (Off_t *) SvPV(pos,len);
3963 if (f && len == sizeof(Off_t))
3964 return PerlIO_seek(f,*posn,SEEK_SET);
3966 SETERRNO(EINVAL,SS$_IVCHAN);
3970 #undef PerlIO_setpos
3972 PerlIO_setpos(PerlIO *f, SV *pos)
3978 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3979 if (f && len == sizeof(Fpos_t))
3981 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3982 return fsetpos64(f, fpos);
3984 return fsetpos(f, fpos);
3988 SETERRNO(EINVAL,SS$_IVCHAN);
3994 #undef PerlIO_getpos
3996 PerlIO_getpos(PerlIO *f, SV *pos)
3999 Off_t posn = PerlIO_tell(f);
4000 sv_setpvn(pos,(char *)&posn,sizeof(posn));
4001 return (posn == (Off_t)-1) ? -1 : 0;
4004 #undef PerlIO_getpos
4006 PerlIO_getpos(PerlIO *f, SV *pos)
4011 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4012 code = fgetpos64(f, &fpos);
4014 code = fgetpos(f, &fpos);
4016 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4021 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4024 vprintf(char *pat, char *args)
4026 _doprnt(pat, args, stdout);
4027 return 0; /* wrong, but perl doesn't use the return value */
4031 vfprintf(FILE *fd, char *pat, char *args)
4033 _doprnt(pat, args, fd);
4034 return 0; /* wrong, but perl doesn't use the return value */
4039 #ifndef PerlIO_vsprintf
4041 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4043 int val = vsprintf(s, fmt, ap);
4046 if (strlen(s) >= (STRLEN)n)
4049 (void)PerlIO_puts(Perl_error_log,
4050 "panic: sprintf overflow - memory corrupted!\n");
4058 #ifndef PerlIO_sprintf
4060 PerlIO_sprintf(char *s, int n, const char *fmt,...)
4065 result = PerlIO_vsprintf(s, n, fmt, ap);