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.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
37 perlsio_binmode(FILE *fp, int iotype, int mode)
39 /* This used to be contents of do_binmode in doio.c */
41 # if defined(atarist) || defined(__MINT__)
44 ((FILE*)fp)->_flag |= _IOBIN;
46 ((FILE*)fp)->_flag &= ~ _IOBIN;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
53 # if defined(WIN32) && defined(__BORLANDC__)
54 /* The translation mode of the stream is maintained independent
55 * of the translation mode of the fd in the Borland RTL (heavy
56 * digging through their runtime sources reveal). User has to
57 * set the mode explicitly for the stream (though they don't
58 * document this anywhere). GSAR 97-5-24
64 fp->flags &= ~ _F_BIN;
72 # if defined(USEMYBINMODE)
73 if (my_binmode(fp, iotype, mode) != FALSE)
85 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
87 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
91 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
102 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
105 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
109 if (*args == &PL_sv_undef)
110 return PerlIO_tmpfile();
113 char *name = SvPV_nolen(*args);
116 fd = PerlLIO_open3(name,imode,perm);
118 return PerlIO_fdopen(fd,mode+1);
122 return PerlIO_reopen(name,mode,old);
126 return PerlIO_open(name,mode);
132 return PerlIO_fdopen(fd,mode);
140 #ifdef PERLIO_IS_STDIO
145 /* Does nothing (yet) except force this file to be included
146 in perl binary. That allows this file to force inclusion
147 of other functions that may be required by loadable
148 extensions e.g. for FileHandle::tmpfile
152 #undef PerlIO_tmpfile
159 #else /* PERLIO_IS_STDIO */
166 /* This section is just to make sure these functions
167 get pulled in from libsfio.a
170 #undef PerlIO_tmpfile
180 /* Force this file to be included in perl binary. Which allows
181 * this file to force inclusion of other functions that may be
182 * required by loadable extensions e.g. for FileHandle::tmpfile
186 * sfio does its own 'autoflush' on stdout in common cases.
187 * Flush results in a lot of lseek()s to regular files and
188 * lot of small writes to pipes.
190 sfset(sfstdout,SF_SHARE,0);
194 /*======================================================================================*/
195 /* Implement all the PerlIO interface ourselves.
200 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
205 #include <sys/mman.h>
210 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
213 PerlIO_debug(const char *fmt,...)
221 char *s = PerlEnv_getenv("PERLIO_DEBUG");
223 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
230 SV *sv = newSVpvn("",0);
233 s = CopFILE(PL_curcop);
236 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
237 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
240 PerlLIO_write(dbg,s,len);
246 /*--------------------------------------------------------------------------------------*/
248 /* Inner level routines */
250 /* Table of pointers to the PerlIO structs (malloc'ed) */
251 PerlIO *_perlio = NULL;
252 #define PERLIO_TABLE_SIZE 64
257 PerlIO_allocate(pTHX)
259 /* Find a free slot in the table, allocating new table as necessary */
266 last = (PerlIO **)(f);
267 for (i=1; i < PERLIO_TABLE_SIZE; i++)
275 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
285 PerlIO_cleantable(pTHX_ PerlIO **tablep)
287 PerlIO *table = *tablep;
291 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
292 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
300 PerlMemShared_free(table);
312 PerlIO_cleantable(aTHX_ &_perlio);
316 PerlIO_pop(pTHX_ PerlIO *f)
321 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
323 (*l->tab->Popped)(f);
325 PerlMemShared_free(l);
329 /*--------------------------------------------------------------------------------------*/
330 /* XS Interface for perl code */
336 char *s = GvNAME(gv);
337 STRLEN l = GvNAMELEN(gv);
338 PerlIO_debug("%.*s\n",(int) l,s);
342 XS(XS_perlio_unimport)
346 char *s = GvNAME(gv);
347 STRLEN l = GvNAMELEN(gv);
348 PerlIO_debug("%.*s\n",(int) l,s);
353 PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
357 if ((SSize_t) len <= 0)
359 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
360 if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
362 SV *pkgsv = newSVpvn("PerlIO",6);
363 SV *layer = newSVpvn(name,len);
365 /* The two SVs are magically freed by load_module */
366 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
368 /* Say this is lvalue so we get an 'undef' if still not there */
369 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
371 if (svp && (sv = *svp))
381 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
385 IO *io = GvIOn((GV *)SvRV(sv));
386 PerlIO *ifp = IoIFP(io);
387 PerlIO *ofp = IoOFP(io);
388 AV *av = (AV *) mg->mg_obj;
389 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
395 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
399 IO *io = GvIOn((GV *)SvRV(sv));
400 PerlIO *ifp = IoIFP(io);
401 PerlIO *ofp = IoOFP(io);
402 AV *av = (AV *) mg->mg_obj;
403 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
409 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
411 Perl_warn(aTHX_ "clear %"SVf,sv);
416 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
418 Perl_warn(aTHX_ "free %"SVf,sv);
422 MGVTBL perlio_vtab = {
430 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
433 SV *sv = SvRV(ST(1));
438 sv_magic(sv, (SV *)av, '~', NULL, 0);
440 mg = mg_find(sv,'~');
441 mg->mg_virtual = &perlio_vtab;
443 Perl_warn(aTHX_ "attrib %"SVf,sv);
444 for (i=2; i < items; i++)
447 const char *name = SvPV(ST(i),len);
448 SV *layer = PerlIO_find_layer(aTHX_ name,len);
451 av_push(av,SvREFCNT_inc(layer));
464 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
466 HV *stash = gv_stashpv("perlio::Layer", TRUE);
467 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
472 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
474 if (!PerlIO_layer_hv)
476 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
478 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
479 PerlIO_debug("define %s %p\n",tab->name,tab);
483 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
487 const char *s = names;
490 while (isSPACE(*s) || *s == ':')
496 const char *as = Nullch;
500 /* Message is consistent with how attribute lists are passed.
501 Even though this means "foo : : bar" is seen as an invalid separator
503 char q = ((*s == '\'') ? '"' : '\'');
504 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
510 } while (isALNUM(*e));
528 /* It's a nul terminated string, not allowed to \ the terminating null.
529 Anything other character is passed over. */
537 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
547 SV *layer = PerlIO_find_layer(aTHX_ s,llen);
550 av_push(av,SvREFCNT_inc(layer));
551 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
554 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
566 PerlIO_default_buffer(pTHX_ AV *av)
568 PerlIO_funcs *tab = &PerlIO_perlio;
569 if (O_BINARY != O_TEXT)
575 if (PerlIO_stdio.Set_ptrcnt)
580 PerlIO_debug("Pushing %s\n",tab->name);
581 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
582 av_push(av,&PL_sv_undef);
586 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
588 SV **svp = av_fetch(av,n,FALSE);
589 return (svp) ? *svp : Nullsv;
593 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
595 SV **svp = av_fetch(av,n,FALSE);
597 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
599 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
600 return INT2PTR(PerlIO_funcs *, SvIV(layer));
603 Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
608 PerlIO_default_layers(pTHX)
611 if (!PerlIO_layer_av)
613 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
614 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
615 newXS("perlio::import",XS_perlio_import,__FILE__);
616 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
618 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
620 PerlIO_define_layer(aTHX_ &PerlIO_raw);
621 PerlIO_define_layer(aTHX_ &PerlIO_unix);
622 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
623 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
624 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
626 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
628 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
629 PerlIO_define_layer(aTHX_ &PerlIO_byte);
630 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
631 av_push(PerlIO_layer_av,&PL_sv_undef);
634 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
638 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
641 len = av_len(PerlIO_layer_av)+1;
644 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
645 len = av_len(PerlIO_layer_av);
647 return PerlIO_layer_av;
652 PerlIO_default_layer(pTHX_ I32 n)
654 AV *av = PerlIO_default_layers(aTHX);
657 n += av_len(PerlIO_layer_av)+1;
658 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
661 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
662 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
665 PerlIO_stdstreams(pTHX)
669 PerlIO_allocate(aTHX);
670 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
671 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
672 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
677 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
680 l = PerlMemShared_calloc(tab->size,sizeof(char));
683 Zero(l,tab->size,char);
687 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
688 (mode) ? mode : "(Null)",arg);
689 if ((*l->tab->Pushed)(f,mode,arg) != 0)
699 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
713 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
715 /* Remove the dummy layer */
718 /* Pop back to bottom layer */
723 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
731 /* Nothing bellow - push unix on top then remove it */
732 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
734 PerlIO_pop(aTHX_ PerlIONext(f));
739 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
746 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
748 IV max = av_len(layers)+1;
752 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
755 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
767 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
772 AV *layers = newAV();
773 code = PerlIO_parse_layers(aTHX_ layers,names);
776 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
778 SvREFCNT_dec((SV *) layers);
784 /*--------------------------------------------------------------------------------------*/
785 /* Given the abstraction above the public API functions */
788 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
790 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
791 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
792 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
798 if (PerlIOBase(top)->tab == &PerlIO_crlf)
801 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
804 top = PerlIONext(top);
807 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
812 PerlIO__close(PerlIO *f)
814 return (*PerlIOBase(f)->tab->Close)(f);
817 #undef PerlIO_fdupopen
819 PerlIO_fdupopen(pTHX_ PerlIO *f)
822 int fd = PerlLIO_dup(PerlIO_fileno(f));
823 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
826 Off_t posn = PerlIO_tell(f);
827 PerlIO_seek(new,posn,SEEK_SET);
834 PerlIO_close(PerlIO *f)
840 code = (*PerlIOBase(f)->tab->Close)(f);
851 PerlIO_fileno(PerlIO *f)
853 return (*PerlIOBase(f)->tab->Fileno)(f);
857 PerlIO_context_layers(pTHX_ const char *mode)
859 const char *type = NULL;
860 /* Need to supply default layer info from open.pm */
863 SV *layers = PL_curcop->cop_io;
867 type = SvPV(layers,len);
868 if (type && mode[0] != 'r')
870 /* Skip to write part */
871 const char *s = strchr(type,0);
872 if (s && (s-type) < len)
883 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
885 AV *def = PerlIO_default_layers(aTHX);
888 PerlIO_stdstreams(aTHX);
893 if (sv_isobject(*args))
895 SV *handler = PerlIO_find_layer(aTHX_ "object",6);
899 av_push(def,handler);
900 av_push(def,&PL_sv_undef);
906 if (SvTYPE(SvRV(*args)) < SVt_PVAV)
908 SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
912 av_push(def,handler);
913 av_push(def,&PL_sv_undef);
919 Perl_croak(aTHX_ "Unsupported reference arg to open()");
925 layers = PerlIO_context_layers(aTHX_ mode);
926 if (layers && *layers)
931 IV n = av_len(def)+1;
935 SV **svp = av_fetch(def,n,0);
936 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
943 PerlIO_parse_layers(aTHX_ av,layers);
955 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
957 if (!f && narg == 1 && *args == &PL_sv_undef)
959 if ((f = PerlIO_tmpfile()))
962 layers = PerlIO_context_layers(aTHX_ mode);
963 if (layers && *layers)
964 PerlIO_apply_layers(aTHX_ f,mode,layers);
974 /* This is "reopen" - it is not tested as perl does not use it yet */
979 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
980 av_unshift(layera,2);
981 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
982 av_store(layera,1,arg);
988 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
990 n = av_len(layera)-1;
993 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1003 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1004 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1005 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1008 if (n+2 < av_len(layera)+1)
1010 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1017 SvREFCNT_dec(layera);
1023 #undef PerlIO_fdopen
1025 PerlIO_fdopen(int fd, const char *mode)
1028 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1033 PerlIO_open(const char *path, const char *mode)
1036 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1037 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1040 #undef PerlIO_reopen
1042 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1045 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1046 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1051 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1053 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1056 #undef PerlIO_unread
1058 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1060 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1065 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1067 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1072 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1074 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1079 PerlIO_tell(PerlIO *f)
1081 return (*PerlIOBase(f)->tab->Tell)(f);
1086 PerlIO_flush(PerlIO *f)
1090 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1091 if (tab && tab->Flush)
1093 return (*tab->Flush)(f);
1097 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1104 PerlIO **table = &_perlio;
1106 while ((f = *table))
1109 table = (PerlIO **)(f++);
1110 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1112 if (*f && PerlIO_flush(f) != 0)
1123 PerlIO_fill(PerlIO *f)
1125 return (*PerlIOBase(f)->tab->Fill)(f);
1128 #undef PerlIO_isutf8
1130 PerlIO_isutf8(PerlIO *f)
1132 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1137 PerlIO_eof(PerlIO *f)
1139 return (*PerlIOBase(f)->tab->Eof)(f);
1144 PerlIO_error(PerlIO *f)
1146 return (*PerlIOBase(f)->tab->Error)(f);
1149 #undef PerlIO_clearerr
1151 PerlIO_clearerr(PerlIO *f)
1154 (*PerlIOBase(f)->tab->Clearerr)(f);
1157 #undef PerlIO_setlinebuf
1159 PerlIO_setlinebuf(PerlIO *f)
1161 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1164 #undef PerlIO_has_base
1166 PerlIO_has_base(PerlIO *f)
1170 return (PerlIOBase(f)->tab->Get_base != NULL);
1175 #undef PerlIO_fast_gets
1177 PerlIO_fast_gets(PerlIO *f)
1179 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1181 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1182 return (tab->Set_ptrcnt != NULL);
1187 #undef PerlIO_has_cntptr
1189 PerlIO_has_cntptr(PerlIO *f)
1193 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1194 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1199 #undef PerlIO_canset_cnt
1201 PerlIO_canset_cnt(PerlIO *f)
1205 PerlIOl *l = PerlIOBase(f);
1206 return (l->tab->Set_ptrcnt != NULL);
1211 #undef PerlIO_get_base
1213 PerlIO_get_base(PerlIO *f)
1215 return (*PerlIOBase(f)->tab->Get_base)(f);
1218 #undef PerlIO_get_bufsiz
1220 PerlIO_get_bufsiz(PerlIO *f)
1222 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1225 #undef PerlIO_get_ptr
1227 PerlIO_get_ptr(PerlIO *f)
1229 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1230 if (tab->Get_ptr == NULL)
1232 return (*tab->Get_ptr)(f);
1235 #undef PerlIO_get_cnt
1237 PerlIO_get_cnt(PerlIO *f)
1239 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1240 if (tab->Get_cnt == NULL)
1242 return (*tab->Get_cnt)(f);
1245 #undef PerlIO_set_cnt
1247 PerlIO_set_cnt(PerlIO *f,int cnt)
1249 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1252 #undef PerlIO_set_ptrcnt
1254 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1256 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1257 if (tab->Set_ptrcnt == NULL)
1260 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1262 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1265 /*--------------------------------------------------------------------------------------*/
1266 /* utf8 and raw dummy layers */
1269 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1274 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1275 PerlIO_pop(aTHX_ f);
1276 if (tab->kind & PERLIO_K_UTF8)
1277 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1279 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1285 PerlIO_funcs PerlIO_utf8 = {
1288 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1306 NULL, /* get_base */
1307 NULL, /* get_bufsiz */
1310 NULL, /* set_ptrcnt */
1313 PerlIO_funcs PerlIO_byte = {
1334 NULL, /* get_base */
1335 NULL, /* get_bufsiz */
1338 NULL, /* set_ptrcnt */
1342 PerlIORaw_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1344 PerlIO_funcs *tab = PerlIO_default_btm();
1345 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1348 PerlIO_funcs PerlIO_raw = {
1369 NULL, /* get_base */
1370 NULL, /* get_bufsiz */
1373 NULL, /* set_ptrcnt */
1375 /*--------------------------------------------------------------------------------------*/
1376 /*--------------------------------------------------------------------------------------*/
1377 /* "Methods" of the "base class" */
1380 PerlIOBase_fileno(PerlIO *f)
1382 return PerlIO_fileno(PerlIONext(f));
1386 PerlIO_modestr(PerlIO *f,char *buf)
1389 IV flags = PerlIOBase(f)->flags;
1390 if (flags & PERLIO_F_APPEND)
1393 if (flags & PERLIO_F_CANREAD)
1398 else if (flags & PERLIO_F_CANREAD)
1401 if (flags & PERLIO_F_CANWRITE)
1404 else if (flags & PERLIO_F_CANWRITE)
1407 if (flags & PERLIO_F_CANREAD)
1412 #if O_TEXT != O_BINARY
1413 if (!(flags & PERLIO_F_CRLF))
1421 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1423 PerlIOl *l = PerlIOBase(f);
1424 const char *omode = mode;
1426 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1427 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1428 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1429 if (tab->Set_ptrcnt != NULL)
1430 l->flags |= PERLIO_F_FASTGETS;
1436 l->flags |= PERLIO_F_CANREAD;
1439 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1442 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1453 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1456 l->flags &= ~PERLIO_F_CRLF;
1459 l->flags |= PERLIO_F_CRLF;
1471 l->flags |= l->next->flags &
1472 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1476 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1477 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1478 l->flags,PerlIO_modestr(f,temp));
1484 PerlIOBase_popped(PerlIO *f)
1490 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1493 Off_t old = PerlIO_tell(f);
1495 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1496 done = PerlIOBuf_unread(f,vbuf,count);
1497 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1502 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1504 STDCHAR *buf = (STDCHAR *) vbuf;
1507 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1511 SSize_t avail = PerlIO_get_cnt(f);
1512 SSize_t take = (count < avail) ? count : avail;
1515 STDCHAR *ptr = PerlIO_get_ptr(f);
1516 Copy(ptr,buf,take,STDCHAR);
1517 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1521 if (count > 0 && avail <= 0)
1523 if (PerlIO_fill(f) != 0)
1527 return (buf - (STDCHAR *) vbuf);
1533 PerlIOBase_noop_ok(PerlIO *f)
1539 PerlIOBase_noop_fail(PerlIO *f)
1545 PerlIOBase_close(PerlIO *f)
1548 PerlIO *n = PerlIONext(f);
1549 if (PerlIO_flush(f) != 0)
1551 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1553 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1558 PerlIOBase_eof(PerlIO *f)
1562 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1568 PerlIOBase_error(PerlIO *f)
1572 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1578 PerlIOBase_clearerr(PerlIO *f)
1582 PerlIO *n = PerlIONext(f);
1583 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1590 PerlIOBase_setlinebuf(PerlIO *f)
1594 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1598 /*--------------------------------------------------------------------------------------*/
1599 /* Bottom-most level for UNIX-like case */
1603 struct _PerlIO base; /* The generic part */
1604 int fd; /* UNIX like file descriptor */
1605 int oflags; /* open/fcntl flags */
1609 PerlIOUnix_oflags(const char *mode)
1624 oflags = O_CREAT|O_TRUNC;
1635 oflags = O_CREAT|O_APPEND;
1651 else if (*mode == 't')
1654 oflags &= ~O_BINARY;
1657 /* Always open in binary mode */
1659 if (*mode || oflags == -1)
1668 PerlIOUnix_fileno(PerlIO *f)
1670 return PerlIOSelf(f,PerlIOUnix)->fd;
1674 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1676 IV code = PerlIOBase_pushed(f,mode,arg);
1679 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1680 s->fd = PerlIO_fileno(PerlIONext(f));
1681 s->oflags = PerlIOUnix_oflags(mode);
1683 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1688 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1692 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1693 (*PerlIOBase(f)->tab->Close)(f);
1697 char *path = SvPV_nolen(*args);
1702 imode = PerlIOUnix_oflags(mode);
1707 fd = PerlLIO_open3(path,imode,perm);
1717 f = PerlIO_allocate(aTHX);
1718 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1721 s = PerlIOSelf(f,PerlIOUnix);
1724 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1731 /* FIXME: pop layers ??? */
1738 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1741 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1742 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1746 SSize_t len = PerlLIO_read(fd,vbuf,count);
1747 if (len >= 0 || errno != EINTR)
1750 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1751 else if (len == 0 && count != 0)
1752 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1760 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1763 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1766 SSize_t len = PerlLIO_write(fd,vbuf,count);
1767 if (len >= 0 || errno != EINTR)
1770 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1778 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1781 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1782 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1783 return (new == (Off_t) -1) ? -1 : 0;
1787 PerlIOUnix_tell(PerlIO *f)
1790 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1791 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1795 PerlIOUnix_close(PerlIO *f)
1798 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1800 while (PerlLIO_close(fd) != 0)
1811 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1816 PerlIO_funcs PerlIO_unix = {
1831 PerlIOBase_noop_ok, /* flush */
1832 PerlIOBase_noop_fail, /* fill */
1835 PerlIOBase_clearerr,
1836 PerlIOBase_setlinebuf,
1837 NULL, /* get_base */
1838 NULL, /* get_bufsiz */
1841 NULL, /* set_ptrcnt */
1844 /*--------------------------------------------------------------------------------------*/
1845 /* stdio as a layer */
1849 struct _PerlIO base;
1850 FILE * stdio; /* The stream */
1854 PerlIOStdio_fileno(PerlIO *f)
1857 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1861 PerlIOStdio_mode(const char *mode,char *tmode)
1868 if (O_BINARY != O_TEXT)
1876 /* This isn't used yet ... */
1878 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1883 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1885 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1891 return PerlIOBase_pushed(f,mode,arg);
1894 #undef PerlIO_importFILE
1896 PerlIO_importFILE(FILE *stdio, int fl)
1902 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1909 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1914 char *path = SvPV_nolen(*args);
1915 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1916 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1926 char *path = SvPV_nolen(*args);
1930 fd = PerlLIO_open3(path,imode,perm);
1934 FILE *stdio = PerlSIO_fopen(path,mode);
1937 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1938 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
1959 stdio = PerlSIO_stdin;
1962 stdio = PerlSIO_stdout;
1965 stdio = PerlSIO_stderr;
1971 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1975 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
1985 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1988 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1992 STDCHAR *buf = (STDCHAR *) vbuf;
1993 /* Perl is expecting PerlIO_getc() to fill the buffer
1994 * Linux's stdio does not do that for fread()
1996 int ch = PerlSIO_fgetc(s);
2004 got = PerlSIO_fread(vbuf,1,count,s);
2009 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2012 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2013 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2017 int ch = *buf-- & 0xff;
2018 if (PerlSIO_ungetc(ch,s) != ch)
2027 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2030 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2034 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2037 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2038 return PerlSIO_fseek(stdio,offset,whence);
2042 PerlIOStdio_tell(PerlIO *f)
2045 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2046 return PerlSIO_ftell(stdio);
2050 PerlIOStdio_close(PerlIO *f)
2053 #ifdef HAS_SOCKS5_INIT
2054 int optval, optlen = sizeof(int);
2056 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2058 #ifdef HAS_SOCKS5_INIT
2059 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2060 PerlSIO_fclose(stdio) :
2061 close(PerlIO_fileno(f))
2063 PerlSIO_fclose(stdio)
2070 PerlIOStdio_flush(PerlIO *f)
2073 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2074 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2076 return PerlSIO_fflush(stdio);
2081 /* FIXME: This discards ungetc() and pre-read stuff which is
2082 not right if this is just a "sync" from a layer above
2083 Suspect right design is to do _this_ but not have layer above
2084 flush this layer read-to-read
2086 /* Not writeable - sync by attempting a seek */
2088 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2096 PerlIOStdio_fill(PerlIO *f)
2099 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2101 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2102 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2104 if (PerlSIO_fflush(stdio) != 0)
2107 c = PerlSIO_fgetc(stdio);
2108 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2114 PerlIOStdio_eof(PerlIO *f)
2117 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2121 PerlIOStdio_error(PerlIO *f)
2124 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2128 PerlIOStdio_clearerr(PerlIO *f)
2131 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2135 PerlIOStdio_setlinebuf(PerlIO *f)
2138 #ifdef HAS_SETLINEBUF
2139 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2141 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2147 PerlIOStdio_get_base(PerlIO *f)
2150 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2151 return PerlSIO_get_base(stdio);
2155 PerlIOStdio_get_bufsiz(PerlIO *f)
2158 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2159 return PerlSIO_get_bufsiz(stdio);
2163 #ifdef USE_STDIO_PTR
2165 PerlIOStdio_get_ptr(PerlIO *f)
2168 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2169 return PerlSIO_get_ptr(stdio);
2173 PerlIOStdio_get_cnt(PerlIO *f)
2176 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2177 return PerlSIO_get_cnt(stdio);
2181 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2184 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2187 #ifdef STDIO_PTR_LVALUE
2188 PerlSIO_set_ptr(stdio,ptr);
2189 #ifdef STDIO_PTR_LVAL_SETS_CNT
2190 if (PerlSIO_get_cnt(stdio) != (cnt))
2193 assert(PerlSIO_get_cnt(stdio) == (cnt));
2196 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2197 /* Setting ptr _does_ change cnt - we are done */
2200 #else /* STDIO_PTR_LVALUE */
2202 #endif /* STDIO_PTR_LVALUE */
2204 /* Now (or only) set cnt */
2205 #ifdef STDIO_CNT_LVALUE
2206 PerlSIO_set_cnt(stdio,cnt);
2207 #else /* STDIO_CNT_LVALUE */
2208 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2209 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2210 #else /* STDIO_PTR_LVAL_SETS_CNT */
2212 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2213 #endif /* STDIO_CNT_LVALUE */
2218 PerlIO_funcs PerlIO_stdio = {
2220 sizeof(PerlIOStdio),
2237 PerlIOStdio_clearerr,
2238 PerlIOStdio_setlinebuf,
2240 PerlIOStdio_get_base,
2241 PerlIOStdio_get_bufsiz,
2246 #ifdef USE_STDIO_PTR
2247 PerlIOStdio_get_ptr,
2248 PerlIOStdio_get_cnt,
2249 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2250 PerlIOStdio_set_ptrcnt
2251 #else /* STDIO_PTR_LVALUE */
2253 #endif /* STDIO_PTR_LVALUE */
2254 #else /* USE_STDIO_PTR */
2258 #endif /* USE_STDIO_PTR */
2261 #undef PerlIO_exportFILE
2263 PerlIO_exportFILE(PerlIO *f, int fl)
2267 stdio = fdopen(PerlIO_fileno(f),"r+");
2271 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2277 #undef PerlIO_findFILE
2279 PerlIO_findFILE(PerlIO *f)
2284 if (l->tab == &PerlIO_stdio)
2286 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2289 l = *PerlIONext(&l);
2291 return PerlIO_exportFILE(f,0);
2294 #undef PerlIO_releaseFILE
2296 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2300 /*--------------------------------------------------------------------------------------*/
2301 /* perlio buffer layer */
2304 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2306 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2307 int fd = PerlIO_fileno(f);
2310 if (fd >= 0 && PerlLIO_isatty(fd))
2312 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2314 posn = PerlIO_tell(PerlIONext(f));
2315 if (posn != (Off_t) -1)
2319 return PerlIOBase_pushed(f,mode,arg);
2323 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2327 PerlIO *next = PerlIONext(f);
2328 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2329 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2330 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2337 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2344 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2347 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2348 fd = PerlIO_fileno(f);
2349 #if O_BINARY != O_TEXT
2350 /* do something about failing setmode()? --jhi */
2351 PerlLIO_setmode(fd , O_BINARY);
2353 if (init && fd == 2)
2355 /* Initial stderr is unbuffered */
2356 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2363 /* This "flush" is akin to sfio's sync in that it handles files in either
2367 PerlIOBuf_flush(PerlIO *f)
2369 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2371 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2373 /* write() the buffer */
2374 STDCHAR *buf = b->buf;
2376 PerlIO *n = PerlIONext(f);
2379 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2384 else if (count < 0 || PerlIO_error(n))
2386 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2391 b->posn += (p - buf);
2393 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2395 STDCHAR *buf = PerlIO_get_base(f);
2396 /* Note position change */
2397 b->posn += (b->ptr - buf);
2398 if (b->ptr < b->end)
2400 /* We did not consume all of it */
2401 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2403 b->posn = PerlIO_tell(PerlIONext(f));
2407 b->ptr = b->end = b->buf;
2408 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2409 /* FIXME: Is this right for read case ? */
2410 if (PerlIO_flush(PerlIONext(f)) != 0)
2416 PerlIOBuf_fill(PerlIO *f)
2418 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2419 PerlIO *n = PerlIONext(f);
2421 /* FIXME: doing the down-stream flush is a bad idea if it causes
2422 pre-read data in stdio buffer to be discarded
2423 but this is too simplistic - as it skips _our_ hosekeeping
2424 and breaks tell tests.
2425 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2429 if (PerlIO_flush(f) != 0)
2433 PerlIO_get_base(f); /* allocate via vtable */
2435 b->ptr = b->end = b->buf;
2436 if (PerlIO_fast_gets(n))
2438 /* Layer below is also buffered
2439 * We do _NOT_ want to call its ->Read() because that will loop
2440 * till it gets what we asked for which may hang on a pipe etc.
2441 * Instead take anything it has to hand, or ask it to fill _once_.
2443 avail = PerlIO_get_cnt(n);
2446 avail = PerlIO_fill(n);
2448 avail = PerlIO_get_cnt(n);
2451 if (!PerlIO_error(n) && PerlIO_eof(n))
2457 STDCHAR *ptr = PerlIO_get_ptr(n);
2458 SSize_t cnt = avail;
2459 if (avail > b->bufsiz)
2461 Copy(ptr,b->buf,avail,STDCHAR);
2462 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2467 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2472 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2474 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2477 b->end = b->buf+avail;
2478 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2483 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2485 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2490 return PerlIOBase_read(f,vbuf,count);
2496 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2498 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2499 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2502 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2508 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2510 avail = (b->ptr - b->buf);
2515 b->end = b->buf + avail;
2517 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2518 b->posn -= b->bufsiz;
2520 if (avail > (SSize_t) count)
2528 Copy(buf,b->ptr,avail,STDCHAR);
2532 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2539 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2541 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2542 const STDCHAR *buf = (const STDCHAR *) vbuf;
2546 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2550 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2551 if ((SSize_t) count < avail)
2553 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2554 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2574 Copy(buf,b->ptr,avail,STDCHAR);
2581 if (b->ptr >= (b->buf + b->bufsiz))
2584 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2590 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2593 if ((code = PerlIO_flush(f)) == 0)
2595 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2596 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2597 code = PerlIO_seek(PerlIONext(f),offset,whence);
2600 b->posn = PerlIO_tell(PerlIONext(f));
2607 PerlIOBuf_tell(PerlIO *f)
2609 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2610 Off_t posn = b->posn;
2612 posn += (b->ptr - b->buf);
2617 PerlIOBuf_close(PerlIO *f)
2620 IV code = PerlIOBase_close(f);
2621 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2622 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2624 PerlMemShared_free(b->buf);
2627 b->ptr = b->end = b->buf;
2628 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2633 PerlIOBuf_get_ptr(PerlIO *f)
2635 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2642 PerlIOBuf_get_cnt(PerlIO *f)
2644 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2647 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2648 return (b->end - b->ptr);
2653 PerlIOBuf_get_base(PerlIO *f)
2655 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2661 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2664 b->buf = (STDCHAR *)&b->oneword;
2665 b->bufsiz = sizeof(b->oneword);
2674 PerlIOBuf_bufsiz(PerlIO *f)
2676 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2679 return (b->end - b->buf);
2683 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2685 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2689 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2692 assert(PerlIO_get_cnt(f) == cnt);
2693 assert(b->ptr >= b->buf);
2695 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2698 PerlIO_funcs PerlIO_perlio = {
2717 PerlIOBase_clearerr,
2718 PerlIOBase_setlinebuf,
2723 PerlIOBuf_set_ptrcnt,
2726 /*--------------------------------------------------------------------------------------*/
2727 /* Temp layer to hold unread chars when cannot do it any other way */
2730 PerlIOPending_fill(PerlIO *f)
2732 /* Should never happen */
2738 PerlIOPending_close(PerlIO *f)
2740 /* A tad tricky - flush pops us, then we close new top */
2742 return PerlIO_close(f);
2746 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2748 /* A tad tricky - flush pops us, then we seek new top */
2750 return PerlIO_seek(f,offset,whence);
2755 PerlIOPending_flush(PerlIO *f)
2758 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2759 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2761 PerlMemShared_free(b->buf);
2764 PerlIO_pop(aTHX_ f);
2769 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2777 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2782 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2784 IV code = PerlIOBase_pushed(f,mode,arg);
2785 PerlIOl *l = PerlIOBase(f);
2786 /* Our PerlIO_fast_gets must match what we are pushed on,
2787 or sv_gets() etc. get muddled when it changes mid-string
2790 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2791 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2796 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2798 SSize_t avail = PerlIO_get_cnt(f);
2803 got = PerlIOBuf_read(f,vbuf,avail);
2804 if (got >= 0 && got < count)
2806 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2807 if (more >= 0 || got == 0)
2813 PerlIO_funcs PerlIO_pending = {
2817 PerlIOPending_pushed,
2827 PerlIOPending_close,
2828 PerlIOPending_flush,
2832 PerlIOBase_clearerr,
2833 PerlIOBase_setlinebuf,
2838 PerlIOPending_set_ptrcnt,
2843 /*--------------------------------------------------------------------------------------*/
2844 /* crlf - translation
2845 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2846 to hand back a line at a time and keeping a record of which nl we "lied" about.
2847 On write translate "\n" to CR,LF
2852 PerlIOBuf base; /* PerlIOBuf stuff */
2853 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2857 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2860 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2861 code = PerlIOBuf_pushed(f,mode,arg);
2863 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2864 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2865 PerlIOBase(f)->flags);
2872 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2874 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2880 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2881 return PerlIOBuf_unread(f,vbuf,count);
2884 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2885 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2887 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2893 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2895 b->end = b->ptr = b->buf + b->bufsiz;
2896 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2897 b->posn -= b->bufsiz;
2899 while (count > 0 && b->ptr > b->buf)
2904 if (b->ptr - 2 >= b->buf)
2930 PerlIOCrlf_get_cnt(PerlIO *f)
2932 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2935 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2937 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2938 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2940 STDCHAR *nl = b->ptr;
2942 while (nl < b->end && *nl != 0xd)
2944 if (nl < b->end && *nl == 0xd)
2956 /* Not CR,LF but just CR */
2963 /* Blast - found CR as last char in buffer */
2966 /* They may not care, defer work as long as possible */
2967 return (nl - b->ptr);
2973 b->ptr++; /* say we have read it as far as flush() is concerned */
2974 b->buf++; /* Leave space an front of buffer */
2975 b->bufsiz--; /* Buffer is thus smaller */
2976 code = PerlIO_fill(f); /* Fetch some more */
2977 b->bufsiz++; /* Restore size for next time */
2978 b->buf--; /* Point at space */
2979 b->ptr = nl = b->buf; /* Which is what we hand off */
2980 b->posn--; /* Buffer starts here */
2981 *nl = 0xd; /* Fill in the CR */
2983 goto test; /* fill() call worked */
2984 /* CR at EOF - just fall through */
2989 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2995 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2997 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2998 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2999 IV flags = PerlIOBase(f)->flags;
3009 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3016 /* Test code - delete when it works ... */
3023 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3031 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3032 ptr, chk, flags, c->nl, b->end, cnt);
3039 /* They have taken what we lied about */
3046 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3050 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3052 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3053 return PerlIOBuf_write(f,vbuf,count);
3056 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3057 const STDCHAR *buf = (const STDCHAR *) vbuf;
3058 const STDCHAR *ebuf = buf+count;
3061 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3065 STDCHAR *eptr = b->buf+b->bufsiz;
3066 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3067 while (buf < ebuf && b->ptr < eptr)
3071 if ((b->ptr + 2) > eptr)
3073 /* Not room for both */
3079 *(b->ptr)++ = 0xd; /* CR */
3080 *(b->ptr)++ = 0xa; /* LF */
3082 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3101 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3103 return (buf - (STDCHAR *) vbuf);
3108 PerlIOCrlf_flush(PerlIO *f)
3110 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3116 return PerlIOBuf_flush(f);
3119 PerlIO_funcs PerlIO_crlf = {
3122 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3124 PerlIOBase_noop_ok, /* popped */
3128 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3129 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3130 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3138 PerlIOBase_clearerr,
3139 PerlIOBase_setlinebuf,
3144 PerlIOCrlf_set_ptrcnt,
3148 /*--------------------------------------------------------------------------------------*/
3149 /* mmap as "buffer" layer */
3153 PerlIOBuf base; /* PerlIOBuf stuff */
3154 Mmap_t mptr; /* Mapped address */
3155 Size_t len; /* mapped length */
3156 STDCHAR *bbuf; /* malloced buffer if map fails */
3159 static size_t page_size = 0;
3162 PerlIOMmap_map(PerlIO *f)
3165 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3166 PerlIOBuf *b = &m->base;
3167 IV flags = PerlIOBase(f)->flags;
3171 if (flags & PERLIO_F_CANREAD)
3173 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3174 int fd = PerlIO_fileno(f);
3176 code = fstat(fd,&st);
3177 if (code == 0 && S_ISREG(st.st_mode))
3179 SSize_t len = st.st_size - b->posn;
3184 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3186 SETERRNO(0,SS$_NORMAL);
3187 # ifdef _SC_PAGESIZE
3188 page_size = sysconf(_SC_PAGESIZE);
3190 page_size = sysconf(_SC_PAGE_SIZE);
3192 if ((long)page_size < 0) {
3197 (void)SvUPGRADE(error, SVt_PV);
3198 msg = SvPVx(error, n_a);
3199 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3202 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3206 # ifdef HAS_GETPAGESIZE
3207 page_size = getpagesize();
3209 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3210 page_size = PAGESIZE; /* compiletime, bad */
3214 if ((IV)page_size <= 0)
3215 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3219 /* This is a hack - should never happen - open should have set it ! */
3220 b->posn = PerlIO_tell(PerlIONext(f));
3222 posn = (b->posn / page_size) * page_size;
3223 len = st.st_size - posn;
3224 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3225 if (m->mptr && m->mptr != (Mmap_t) -1)
3227 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3228 madvise(m->mptr, len, MADV_SEQUENTIAL);
3230 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3231 madvise(m->mptr, len, MADV_WILLNEED);
3233 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3234 b->end = ((STDCHAR *)m->mptr) + len;
3235 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3246 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3248 b->ptr = b->end = b->ptr;
3257 PerlIOMmap_unmap(PerlIO *f)
3259 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3260 PerlIOBuf *b = &m->base;
3266 code = munmap(m->mptr, m->len);
3270 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3273 b->ptr = b->end = b->buf;
3274 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3280 PerlIOMmap_get_base(PerlIO *f)
3282 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3283 PerlIOBuf *b = &m->base;
3284 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3286 /* Already have a readbuffer in progress */
3291 /* We have a write buffer or flushed PerlIOBuf read buffer */
3292 m->bbuf = b->buf; /* save it in case we need it again */
3293 b->buf = NULL; /* Clear to trigger below */
3297 PerlIOMmap_map(f); /* Try and map it */
3300 /* Map did not work - recover PerlIOBuf buffer if we have one */
3304 b->ptr = b->end = b->buf;
3307 return PerlIOBuf_get_base(f);
3311 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3313 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3314 PerlIOBuf *b = &m->base;
3315 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3317 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3320 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3325 /* Loose the unwritable mapped buffer */
3327 /* If flush took the "buffer" see if we have one from before */
3328 if (!b->buf && m->bbuf)
3332 PerlIOBuf_get_base(f);
3336 return PerlIOBuf_unread(f,vbuf,count);
3340 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3342 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3343 PerlIOBuf *b = &m->base;
3344 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3346 /* No, or wrong sort of, buffer */
3349 if (PerlIOMmap_unmap(f) != 0)
3352 /* If unmap took the "buffer" see if we have one from before */
3353 if (!b->buf && m->bbuf)
3357 PerlIOBuf_get_base(f);
3361 return PerlIOBuf_write(f,vbuf,count);
3365 PerlIOMmap_flush(PerlIO *f)
3367 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3368 PerlIOBuf *b = &m->base;
3369 IV code = PerlIOBuf_flush(f);
3370 /* Now we are "synced" at PerlIOBuf level */
3375 /* Unmap the buffer */
3376 if (PerlIOMmap_unmap(f) != 0)
3381 /* We seem to have a PerlIOBuf buffer which was not mapped
3382 * remember it in case we need one later
3391 PerlIOMmap_fill(PerlIO *f)
3393 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3394 IV code = PerlIO_flush(f);
3395 if (code == 0 && !b->buf)
3397 code = PerlIOMmap_map(f);
3399 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3401 code = PerlIOBuf_fill(f);
3407 PerlIOMmap_close(PerlIO *f)
3409 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3410 PerlIOBuf *b = &m->base;
3411 IV code = PerlIO_flush(f);
3416 b->ptr = b->end = b->buf;
3418 if (PerlIOBuf_close(f) != 0)
3424 PerlIO_funcs PerlIO_mmap = {
3443 PerlIOBase_clearerr,
3444 PerlIOBase_setlinebuf,
3445 PerlIOMmap_get_base,
3449 PerlIOBuf_set_ptrcnt,
3452 #endif /* HAS_MMAP */
3460 atexit(&PerlIO_cleanup);
3472 PerlIO_stdstreams(aTHX);
3477 #undef PerlIO_stdout
3484 PerlIO_stdstreams(aTHX);
3489 #undef PerlIO_stderr
3496 PerlIO_stdstreams(aTHX);
3501 /*--------------------------------------------------------------------------------------*/
3503 #undef PerlIO_getname
3505 PerlIO_getname(PerlIO *f, char *buf)
3508 Perl_croak(aTHX_ "Don't know how to get file name");
3513 /*--------------------------------------------------------------------------------------*/
3514 /* Functions which can be called on any kind of PerlIO implemented
3520 PerlIO_getc(PerlIO *f)
3523 SSize_t count = PerlIO_read(f,buf,1);
3526 return (unsigned char) buf[0];
3531 #undef PerlIO_ungetc
3533 PerlIO_ungetc(PerlIO *f, int ch)
3538 if (PerlIO_unread(f,&buf,1) == 1)
3546 PerlIO_putc(PerlIO *f, int ch)
3549 return PerlIO_write(f,&buf,1);
3554 PerlIO_puts(PerlIO *f, const char *s)
3556 STRLEN len = strlen(s);
3557 return PerlIO_write(f,s,len);
3560 #undef PerlIO_rewind
3562 PerlIO_rewind(PerlIO *f)
3564 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3568 #undef PerlIO_vprintf
3570 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3573 SV *sv = newSVpvn("",0);
3579 Perl_va_copy(ap, apc);
3580 sv_vcatpvf(sv, fmt, &apc);
3582 sv_vcatpvf(sv, fmt, &ap);
3585 wrote = PerlIO_write(f,s,len);
3590 #undef PerlIO_printf
3592 PerlIO_printf(PerlIO *f,const char *fmt,...)
3597 result = PerlIO_vprintf(f,fmt,ap);
3602 #undef PerlIO_stdoutf
3604 PerlIO_stdoutf(const char *fmt,...)
3609 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3614 #undef PerlIO_tmpfile
3616 PerlIO_tmpfile(void)
3618 /* I have no idea how portable mkstemp() is ... */
3619 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3622 FILE *stdio = PerlSIO_tmpfile();
3625 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3631 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3632 int fd = mkstemp(SvPVX(sv));
3636 f = PerlIO_fdopen(fd,"w+");
3639 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3641 PerlLIO_unlink(SvPVX(sv));
3651 #endif /* USE_SFIO */
3652 #endif /* PERLIO_IS_STDIO */
3654 /*======================================================================================*/
3655 /* Now some functions in terms of above which may be needed even if
3656 we are not in true PerlIO mode
3660 #undef PerlIO_setpos
3662 PerlIO_setpos(PerlIO *f, SV *pos)
3668 Off_t *posn = (Off_t *) SvPV(pos,len);
3669 if (f && len == sizeof(Off_t))
3670 return PerlIO_seek(f,*posn,SEEK_SET);
3676 #undef PerlIO_setpos
3678 PerlIO_setpos(PerlIO *f, SV *pos)
3684 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3685 if (f && len == sizeof(Fpos_t))
3687 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3688 return fsetpos64(f, fpos);
3690 return fsetpos(f, fpos);
3700 #undef PerlIO_getpos
3702 PerlIO_getpos(PerlIO *f, SV *pos)
3705 Off_t posn = PerlIO_tell(f);
3706 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3707 return (posn == (Off_t)-1) ? -1 : 0;
3710 #undef PerlIO_getpos
3712 PerlIO_getpos(PerlIO *f, SV *pos)
3717 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3718 code = fgetpos64(f, &fpos);
3720 code = fgetpos(f, &fpos);
3722 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3727 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3730 vprintf(char *pat, char *args)
3732 _doprnt(pat, args, stdout);
3733 return 0; /* wrong, but perl doesn't use the return value */
3737 vfprintf(FILE *fd, char *pat, char *args)
3739 _doprnt(pat, args, fd);
3740 return 0; /* wrong, but perl doesn't use the return value */
3745 #ifndef PerlIO_vsprintf
3747 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3749 int val = vsprintf(s, fmt, ap);
3752 if (strlen(s) >= (STRLEN)n)
3755 (void)PerlIO_puts(Perl_error_log,
3756 "panic: sprintf overflow - memory corrupted!\n");
3764 #ifndef PerlIO_sprintf
3766 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3771 result = PerlIO_vsprintf(s, n, fmt, ap);