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);
102 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
104 return perlsio_binmode(fp,iotype,mode);
107 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
110 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
114 if (*args == &PL_sv_undef)
115 return PerlIO_tmpfile();
118 char *name = SvPV_nolen(*args);
121 fd = PerlLIO_open3(name,imode,perm);
123 return PerlIO_fdopen(fd,mode+1);
127 return PerlIO_reopen(name,mode,old);
131 return PerlIO_open(name,mode);
137 return PerlIO_fdopen(fd,mode);
145 #ifdef PERLIO_IS_STDIO
150 /* Does nothing (yet) except force this file to be included
151 in perl binary. That allows this file to force inclusion
152 of other functions that may be required by loadable
153 extensions e.g. for FileHandle::tmpfile
157 #undef PerlIO_tmpfile
164 #else /* PERLIO_IS_STDIO */
171 /* This section is just to make sure these functions
172 get pulled in from libsfio.a
175 #undef PerlIO_tmpfile
185 /* Force this file to be included in perl binary. Which allows
186 * this file to force inclusion of other functions that may be
187 * required by loadable extensions e.g. for FileHandle::tmpfile
191 * sfio does its own 'autoflush' on stdout in common cases.
192 * Flush results in a lot of lseek()s to regular files and
193 * lot of small writes to pipes.
195 sfset(sfstdout,SF_SHARE,0);
199 /*======================================================================================*/
200 /* Implement all the PerlIO interface ourselves.
205 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
210 #include <sys/mman.h>
215 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
218 PerlIO_debug(const char *fmt,...)
226 char *s = PerlEnv_getenv("PERLIO_DEBUG");
228 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
235 SV *sv = newSVpvn("",0);
238 s = CopFILE(PL_curcop);
241 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
242 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
245 PerlLIO_write(dbg,s,len);
251 /*--------------------------------------------------------------------------------------*/
253 /* Inner level routines */
255 /* Table of pointers to the PerlIO structs (malloc'ed) */
256 PerlIO *_perlio = NULL;
257 #define PERLIO_TABLE_SIZE 64
262 PerlIO_allocate(pTHX)
264 /* Find a free slot in the table, allocating new table as necessary */
271 last = (PerlIO **)(f);
272 for (i=1; i < PERLIO_TABLE_SIZE; i++)
280 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
290 PerlIO_cleantable(pTHX_ PerlIO **tablep)
292 PerlIO *table = *tablep;
296 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
297 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
305 PerlMemShared_free(table);
317 PerlIO_cleantable(aTHX_ &_perlio);
321 PerlIO_destruct(pTHX)
323 PerlIO **table = &_perlio;
328 table = (PerlIO **)(f++);
329 for (i=1; i < PERLIO_TABLE_SIZE; i++)
335 if (l->tab->kind & PERLIO_K_DESTRUCT)
337 PerlIO_debug("Destruct popping %s\n",l->tab->name);
352 PerlIO_pop(pTHX_ PerlIO *f)
357 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
359 (*l->tab->Popped)(f);
361 PerlMemShared_free(l);
365 /*--------------------------------------------------------------------------------------*/
366 /* XS Interface for perl code */
372 char *s = GvNAME(gv);
373 STRLEN l = GvNAMELEN(gv);
374 PerlIO_debug("%.*s\n",(int) l,s);
378 XS(XS_perlio_unimport)
382 char *s = GvNAME(gv);
383 STRLEN l = GvNAMELEN(gv);
384 PerlIO_debug("%.*s\n",(int) l,s);
389 PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
393 if ((SSize_t) len <= 0)
395 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
396 if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
398 SV *pkgsv = newSVpvn("PerlIO",6);
399 SV *layer = newSVpvn(name,len);
401 /* The two SVs are magically freed by load_module */
402 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
404 /* Say this is lvalue so we get an 'undef' if still not there */
405 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
407 if (svp && (sv = *svp))
417 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
421 IO *io = GvIOn((GV *)SvRV(sv));
422 PerlIO *ifp = IoIFP(io);
423 PerlIO *ofp = IoOFP(io);
424 AV *av = (AV *) mg->mg_obj;
425 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
431 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
435 IO *io = GvIOn((GV *)SvRV(sv));
436 PerlIO *ifp = IoIFP(io);
437 PerlIO *ofp = IoOFP(io);
438 AV *av = (AV *) mg->mg_obj;
439 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
445 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
447 Perl_warn(aTHX_ "clear %"SVf,sv);
452 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
454 Perl_warn(aTHX_ "free %"SVf,sv);
458 MGVTBL perlio_vtab = {
466 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
469 SV *sv = SvRV(ST(1));
474 sv_magic(sv, (SV *)av, '~', NULL, 0);
476 mg = mg_find(sv,'~');
477 mg->mg_virtual = &perlio_vtab;
479 Perl_warn(aTHX_ "attrib %"SVf,sv);
480 for (i=2; i < items; i++)
483 const char *name = SvPV(ST(i),len);
484 SV *layer = PerlIO_find_layer(aTHX_ name,len);
487 av_push(av,SvREFCNT_inc(layer));
500 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
502 HV *stash = gv_stashpv("perlio::Layer", TRUE);
503 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
508 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
510 if (!PerlIO_layer_hv)
512 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
514 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
515 PerlIO_debug("define %s %p\n",tab->name,tab);
519 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
523 const char *s = names;
526 while (isSPACE(*s) || *s == ':')
532 const char *as = Nullch;
536 /* Message is consistent with how attribute lists are passed.
537 Even though this means "foo : : bar" is seen as an invalid separator
539 char q = ((*s == '\'') ? '"' : '\'');
540 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
546 } while (isALNUM(*e));
564 /* It's a nul terminated string, not allowed to \ the terminating null.
565 Anything other character is passed over. */
573 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
583 SV *layer = PerlIO_find_layer(aTHX_ s,llen);
586 av_push(av,SvREFCNT_inc(layer));
587 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
590 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
602 PerlIO_default_buffer(pTHX_ AV *av)
604 PerlIO_funcs *tab = &PerlIO_perlio;
605 if (O_BINARY != O_TEXT)
611 if (PerlIO_stdio.Set_ptrcnt)
616 PerlIO_debug("Pushing %s\n",tab->name);
617 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
618 av_push(av,&PL_sv_undef);
622 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
624 SV **svp = av_fetch(av,n,FALSE);
625 return (svp) ? *svp : Nullsv;
629 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
631 SV **svp = av_fetch(av,n,FALSE);
633 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
635 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
636 return INT2PTR(PerlIO_funcs *, SvIV(layer));
639 Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
644 PerlIO_default_layers(pTHX)
647 if (!PerlIO_layer_av)
649 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
650 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
651 newXS("perlio::import",XS_perlio_import,__FILE__);
652 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
654 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
656 PerlIO_define_layer(aTHX_ &PerlIO_raw);
657 PerlIO_define_layer(aTHX_ &PerlIO_unix);
658 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
659 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
660 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
662 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
664 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
665 PerlIO_define_layer(aTHX_ &PerlIO_byte);
666 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
667 av_push(PerlIO_layer_av,&PL_sv_undef);
670 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
674 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
677 len = av_len(PerlIO_layer_av)+1;
680 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
681 len = av_len(PerlIO_layer_av);
683 return PerlIO_layer_av;
688 PerlIO_default_layer(pTHX_ I32 n)
690 AV *av = PerlIO_default_layers(aTHX);
693 n += av_len(PerlIO_layer_av)+1;
694 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
697 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
698 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
701 PerlIO_stdstreams(pTHX)
705 PerlIO_allocate(aTHX);
706 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
707 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
708 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
713 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
716 l = PerlMemShared_calloc(tab->size,sizeof(char));
719 Zero(l,tab->size,char);
723 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
724 (mode) ? mode : "(Null)",arg);
725 if ((*l->tab->Pushed)(f,mode,arg) != 0)
735 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
749 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
751 /* Remove the dummy layer */
754 /* Pop back to bottom layer */
759 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
767 /* Nothing bellow - push unix on top then remove it */
768 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
770 PerlIO_pop(aTHX_ PerlIONext(f));
775 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
782 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
784 IV max = av_len(layers)+1;
788 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
791 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
803 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
808 AV *layers = newAV();
809 code = PerlIO_parse_layers(aTHX_ layers,names);
812 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
814 SvREFCNT_dec((SV *) layers);
820 /*--------------------------------------------------------------------------------------*/
821 /* Given the abstraction above the public API functions */
824 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
826 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
827 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
828 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
834 if (PerlIOBase(top)->tab == &PerlIO_crlf)
837 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
840 top = PerlIONext(top);
843 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
848 PerlIO__close(PerlIO *f)
850 return (*PerlIOBase(f)->tab->Close)(f);
853 #undef PerlIO_fdupopen
855 PerlIO_fdupopen(pTHX_ PerlIO *f)
858 int fd = PerlLIO_dup(PerlIO_fileno(f));
859 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
862 Off_t posn = PerlIO_tell(f);
863 PerlIO_seek(new,posn,SEEK_SET);
870 PerlIO_close(PerlIO *f)
876 code = (*PerlIOBase(f)->tab->Close)(f);
887 PerlIO_fileno(PerlIO *f)
889 return (*PerlIOBase(f)->tab->Fileno)(f);
893 PerlIO_context_layers(pTHX_ const char *mode)
895 const char *type = NULL;
896 /* Need to supply default layer info from open.pm */
899 SV *layers = PL_curcop->cop_io;
903 type = SvPV(layers,len);
904 if (type && mode[0] != 'r')
906 /* Skip to write part */
907 const char *s = strchr(type,0);
908 if (s && (s-type) < len)
919 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
921 AV *def = PerlIO_default_layers(aTHX);
924 PerlIO_stdstreams(aTHX);
927 if (SvROK(*args) && !sv_isobject(*args))
929 if (SvTYPE(SvRV(*args)) < SVt_PVAV)
931 SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
935 av_push(def,handler);
936 av_push(def,&PL_sv_undef);
942 Perl_croak(aTHX_ "Unsupported reference arg to open()");
947 layers = PerlIO_context_layers(aTHX_ mode);
948 if (layers && *layers)
953 IV n = av_len(def)+1;
957 SV **svp = av_fetch(def,n,0);
958 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
965 PerlIO_parse_layers(aTHX_ av,layers);
977 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
979 if (!f && narg == 1 && *args == &PL_sv_undef)
981 if ((f = PerlIO_tmpfile()))
984 layers = PerlIO_context_layers(aTHX_ mode);
985 if (layers && *layers)
986 PerlIO_apply_layers(aTHX_ f,mode,layers);
996 /* This is "reopen" - it is not tested as perl does not use it yet */
1001 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1002 av_unshift(layera,2);
1003 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1004 av_store(layera,1,arg);
1005 l = *PerlIONext(&l);
1010 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1012 n = av_len(layera)-1;
1015 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1025 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1026 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1027 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1030 if (n+2 < av_len(layera)+1)
1032 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1039 SvREFCNT_dec(layera);
1045 #undef PerlIO_fdopen
1047 PerlIO_fdopen(int fd, const char *mode)
1050 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1055 PerlIO_open(const char *path, const char *mode)
1058 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1059 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1062 #undef PerlIO_reopen
1064 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1067 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1068 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1073 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1075 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1078 #undef PerlIO_unread
1080 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1082 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1087 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1089 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1094 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1096 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1101 PerlIO_tell(PerlIO *f)
1103 return (*PerlIOBase(f)->tab->Tell)(f);
1108 PerlIO_flush(PerlIO *f)
1112 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1113 if (tab && tab->Flush)
1115 return (*tab->Flush)(f);
1119 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1126 PerlIO **table = &_perlio;
1128 while ((f = *table))
1131 table = (PerlIO **)(f++);
1132 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1134 if (*f && PerlIO_flush(f) != 0)
1145 PerlIO_fill(PerlIO *f)
1147 return (*PerlIOBase(f)->tab->Fill)(f);
1150 #undef PerlIO_isutf8
1152 PerlIO_isutf8(PerlIO *f)
1154 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1159 PerlIO_eof(PerlIO *f)
1161 return (*PerlIOBase(f)->tab->Eof)(f);
1166 PerlIO_error(PerlIO *f)
1168 return (*PerlIOBase(f)->tab->Error)(f);
1171 #undef PerlIO_clearerr
1173 PerlIO_clearerr(PerlIO *f)
1176 (*PerlIOBase(f)->tab->Clearerr)(f);
1179 #undef PerlIO_setlinebuf
1181 PerlIO_setlinebuf(PerlIO *f)
1183 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1186 #undef PerlIO_has_base
1188 PerlIO_has_base(PerlIO *f)
1192 return (PerlIOBase(f)->tab->Get_base != NULL);
1197 #undef PerlIO_fast_gets
1199 PerlIO_fast_gets(PerlIO *f)
1201 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1203 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1204 return (tab->Set_ptrcnt != NULL);
1209 #undef PerlIO_has_cntptr
1211 PerlIO_has_cntptr(PerlIO *f)
1215 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1216 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1221 #undef PerlIO_canset_cnt
1223 PerlIO_canset_cnt(PerlIO *f)
1227 PerlIOl *l = PerlIOBase(f);
1228 return (l->tab->Set_ptrcnt != NULL);
1233 #undef PerlIO_get_base
1235 PerlIO_get_base(PerlIO *f)
1237 return (*PerlIOBase(f)->tab->Get_base)(f);
1240 #undef PerlIO_get_bufsiz
1242 PerlIO_get_bufsiz(PerlIO *f)
1244 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1247 #undef PerlIO_get_ptr
1249 PerlIO_get_ptr(PerlIO *f)
1251 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1252 if (tab->Get_ptr == NULL)
1254 return (*tab->Get_ptr)(f);
1257 #undef PerlIO_get_cnt
1259 PerlIO_get_cnt(PerlIO *f)
1261 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1262 if (tab->Get_cnt == NULL)
1264 return (*tab->Get_cnt)(f);
1267 #undef PerlIO_set_cnt
1269 PerlIO_set_cnt(PerlIO *f,int cnt)
1271 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1274 #undef PerlIO_set_ptrcnt
1276 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1278 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1279 if (tab->Set_ptrcnt == NULL)
1282 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1284 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1287 /*--------------------------------------------------------------------------------------*/
1288 /* utf8 and raw dummy layers */
1291 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1296 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1297 PerlIO_pop(aTHX_ f);
1298 if (tab->kind & PERLIO_K_UTF8)
1299 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1301 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1307 PerlIO_funcs PerlIO_utf8 = {
1310 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1328 NULL, /* get_base */
1329 NULL, /* get_bufsiz */
1332 NULL, /* set_ptrcnt */
1335 PerlIO_funcs PerlIO_byte = {
1356 NULL, /* get_base */
1357 NULL, /* get_bufsiz */
1360 NULL, /* set_ptrcnt */
1364 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)
1366 PerlIO_funcs *tab = PerlIO_default_btm();
1367 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1370 PerlIO_funcs PerlIO_raw = {
1391 NULL, /* get_base */
1392 NULL, /* get_bufsiz */
1395 NULL, /* set_ptrcnt */
1397 /*--------------------------------------------------------------------------------------*/
1398 /*--------------------------------------------------------------------------------------*/
1399 /* "Methods" of the "base class" */
1402 PerlIOBase_fileno(PerlIO *f)
1404 return PerlIO_fileno(PerlIONext(f));
1408 PerlIO_modestr(PerlIO *f,char *buf)
1411 IV flags = PerlIOBase(f)->flags;
1412 if (flags & PERLIO_F_APPEND)
1415 if (flags & PERLIO_F_CANREAD)
1420 else if (flags & PERLIO_F_CANREAD)
1423 if (flags & PERLIO_F_CANWRITE)
1426 else if (flags & PERLIO_F_CANWRITE)
1429 if (flags & PERLIO_F_CANREAD)
1434 #if O_TEXT != O_BINARY
1435 if (!(flags & PERLIO_F_CRLF))
1443 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1445 PerlIOl *l = PerlIOBase(f);
1446 const char *omode = mode;
1448 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1449 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1450 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1451 if (tab->Set_ptrcnt != NULL)
1452 l->flags |= PERLIO_F_FASTGETS;
1458 l->flags |= PERLIO_F_CANREAD;
1461 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1464 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1475 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1478 l->flags &= ~PERLIO_F_CRLF;
1481 l->flags |= PERLIO_F_CRLF;
1493 l->flags |= l->next->flags &
1494 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1498 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1499 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1500 l->flags,PerlIO_modestr(f,temp));
1506 PerlIOBase_popped(PerlIO *f)
1512 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1515 Off_t old = PerlIO_tell(f);
1517 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1518 done = PerlIOBuf_unread(f,vbuf,count);
1519 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1524 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1526 STDCHAR *buf = (STDCHAR *) vbuf;
1529 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1533 SSize_t avail = PerlIO_get_cnt(f);
1534 SSize_t take = (count < avail) ? count : avail;
1537 STDCHAR *ptr = PerlIO_get_ptr(f);
1538 Copy(ptr,buf,take,STDCHAR);
1539 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1543 if (count > 0 && avail <= 0)
1545 if (PerlIO_fill(f) != 0)
1549 return (buf - (STDCHAR *) vbuf);
1555 PerlIOBase_noop_ok(PerlIO *f)
1561 PerlIOBase_noop_fail(PerlIO *f)
1567 PerlIOBase_close(PerlIO *f)
1570 PerlIO *n = PerlIONext(f);
1571 if (PerlIO_flush(f) != 0)
1573 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1575 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1580 PerlIOBase_eof(PerlIO *f)
1584 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1590 PerlIOBase_error(PerlIO *f)
1594 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1600 PerlIOBase_clearerr(PerlIO *f)
1604 PerlIO *n = PerlIONext(f);
1605 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1612 PerlIOBase_setlinebuf(PerlIO *f)
1616 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1620 /*--------------------------------------------------------------------------------------*/
1621 /* Bottom-most level for UNIX-like case */
1625 struct _PerlIO base; /* The generic part */
1626 int fd; /* UNIX like file descriptor */
1627 int oflags; /* open/fcntl flags */
1631 PerlIOUnix_oflags(const char *mode)
1646 oflags = O_CREAT|O_TRUNC;
1657 oflags = O_CREAT|O_APPEND;
1673 else if (*mode == 't')
1676 oflags &= ~O_BINARY;
1679 /* Always open in binary mode */
1681 if (*mode || oflags == -1)
1690 PerlIOUnix_fileno(PerlIO *f)
1692 return PerlIOSelf(f,PerlIOUnix)->fd;
1696 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1698 IV code = PerlIOBase_pushed(f,mode,arg);
1701 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1702 s->fd = PerlIO_fileno(PerlIONext(f));
1703 s->oflags = PerlIOUnix_oflags(mode);
1705 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1710 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)
1714 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1715 (*PerlIOBase(f)->tab->Close)(f);
1719 char *path = SvPV_nolen(*args);
1724 imode = PerlIOUnix_oflags(mode);
1729 fd = PerlLIO_open3(path,imode,perm);
1739 f = PerlIO_allocate(aTHX);
1740 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1743 s = PerlIOSelf(f,PerlIOUnix);
1746 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1753 /* FIXME: pop layers ??? */
1760 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1763 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1764 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1768 SSize_t len = PerlLIO_read(fd,vbuf,count);
1769 if (len >= 0 || errno != EINTR)
1772 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1773 else if (len == 0 && count != 0)
1774 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1782 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1785 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1788 SSize_t len = PerlLIO_write(fd,vbuf,count);
1789 if (len >= 0 || errno != EINTR)
1792 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1800 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1803 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1804 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1805 return (new == (Off_t) -1) ? -1 : 0;
1809 PerlIOUnix_tell(PerlIO *f)
1812 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1813 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1817 PerlIOUnix_close(PerlIO *f)
1820 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1822 while (PerlLIO_close(fd) != 0)
1833 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1838 PerlIO_funcs PerlIO_unix = {
1853 PerlIOBase_noop_ok, /* flush */
1854 PerlIOBase_noop_fail, /* fill */
1857 PerlIOBase_clearerr,
1858 PerlIOBase_setlinebuf,
1859 NULL, /* get_base */
1860 NULL, /* get_bufsiz */
1863 NULL, /* set_ptrcnt */
1866 /*--------------------------------------------------------------------------------------*/
1867 /* stdio as a layer */
1871 struct _PerlIO base;
1872 FILE * stdio; /* The stream */
1876 PerlIOStdio_fileno(PerlIO *f)
1879 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1883 PerlIOStdio_mode(const char *mode,char *tmode)
1890 if (O_BINARY != O_TEXT)
1898 /* This isn't used yet ... */
1900 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1905 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1907 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1913 return PerlIOBase_pushed(f,mode,arg);
1916 #undef PerlIO_importFILE
1918 PerlIO_importFILE(FILE *stdio, int fl)
1924 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1931 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)
1936 char *path = SvPV_nolen(*args);
1937 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1938 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1948 char *path = SvPV_nolen(*args);
1952 fd = PerlLIO_open3(path,imode,perm);
1956 FILE *stdio = PerlSIO_fopen(path,mode);
1959 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1960 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
1981 stdio = PerlSIO_stdin;
1984 stdio = PerlSIO_stdout;
1987 stdio = PerlSIO_stderr;
1993 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1997 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2007 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2010 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2014 STDCHAR *buf = (STDCHAR *) vbuf;
2015 /* Perl is expecting PerlIO_getc() to fill the buffer
2016 * Linux's stdio does not do that for fread()
2018 int ch = PerlSIO_fgetc(s);
2026 got = PerlSIO_fread(vbuf,1,count,s);
2031 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2034 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2035 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2039 int ch = *buf-- & 0xff;
2040 if (PerlSIO_ungetc(ch,s) != ch)
2049 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2052 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2056 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2059 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2060 return PerlSIO_fseek(stdio,offset,whence);
2064 PerlIOStdio_tell(PerlIO *f)
2067 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2068 return PerlSIO_ftell(stdio);
2072 PerlIOStdio_close(PerlIO *f)
2075 #ifdef HAS_SOCKS5_INIT
2076 int optval, optlen = sizeof(int);
2078 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2080 #ifdef HAS_SOCKS5_INIT
2081 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2082 PerlSIO_fclose(stdio) :
2083 close(PerlIO_fileno(f))
2085 PerlSIO_fclose(stdio)
2092 PerlIOStdio_flush(PerlIO *f)
2095 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2096 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2098 return PerlSIO_fflush(stdio);
2103 /* FIXME: This discards ungetc() and pre-read stuff which is
2104 not right if this is just a "sync" from a layer above
2105 Suspect right design is to do _this_ but not have layer above
2106 flush this layer read-to-read
2108 /* Not writeable - sync by attempting a seek */
2110 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2118 PerlIOStdio_fill(PerlIO *f)
2121 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2123 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2124 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2126 if (PerlSIO_fflush(stdio) != 0)
2129 c = PerlSIO_fgetc(stdio);
2130 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2136 PerlIOStdio_eof(PerlIO *f)
2139 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2143 PerlIOStdio_error(PerlIO *f)
2146 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2150 PerlIOStdio_clearerr(PerlIO *f)
2153 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2157 PerlIOStdio_setlinebuf(PerlIO *f)
2160 #ifdef HAS_SETLINEBUF
2161 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2163 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2169 PerlIOStdio_get_base(PerlIO *f)
2172 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2173 return PerlSIO_get_base(stdio);
2177 PerlIOStdio_get_bufsiz(PerlIO *f)
2180 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2181 return PerlSIO_get_bufsiz(stdio);
2185 #ifdef USE_STDIO_PTR
2187 PerlIOStdio_get_ptr(PerlIO *f)
2190 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2191 return PerlSIO_get_ptr(stdio);
2195 PerlIOStdio_get_cnt(PerlIO *f)
2198 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2199 return PerlSIO_get_cnt(stdio);
2203 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2206 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2209 #ifdef STDIO_PTR_LVALUE
2210 PerlSIO_set_ptr(stdio,ptr);
2211 #ifdef STDIO_PTR_LVAL_SETS_CNT
2212 if (PerlSIO_get_cnt(stdio) != (cnt))
2215 assert(PerlSIO_get_cnt(stdio) == (cnt));
2218 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2219 /* Setting ptr _does_ change cnt - we are done */
2222 #else /* STDIO_PTR_LVALUE */
2224 #endif /* STDIO_PTR_LVALUE */
2226 /* Now (or only) set cnt */
2227 #ifdef STDIO_CNT_LVALUE
2228 PerlSIO_set_cnt(stdio,cnt);
2229 #else /* STDIO_CNT_LVALUE */
2230 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2231 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2232 #else /* STDIO_PTR_LVAL_SETS_CNT */
2234 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2235 #endif /* STDIO_CNT_LVALUE */
2240 PerlIO_funcs PerlIO_stdio = {
2242 sizeof(PerlIOStdio),
2259 PerlIOStdio_clearerr,
2260 PerlIOStdio_setlinebuf,
2262 PerlIOStdio_get_base,
2263 PerlIOStdio_get_bufsiz,
2268 #ifdef USE_STDIO_PTR
2269 PerlIOStdio_get_ptr,
2270 PerlIOStdio_get_cnt,
2271 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2272 PerlIOStdio_set_ptrcnt
2273 #else /* STDIO_PTR_LVALUE */
2275 #endif /* STDIO_PTR_LVALUE */
2276 #else /* USE_STDIO_PTR */
2280 #endif /* USE_STDIO_PTR */
2283 #undef PerlIO_exportFILE
2285 PerlIO_exportFILE(PerlIO *f, int fl)
2289 stdio = fdopen(PerlIO_fileno(f),"r+");
2293 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2299 #undef PerlIO_findFILE
2301 PerlIO_findFILE(PerlIO *f)
2306 if (l->tab == &PerlIO_stdio)
2308 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2311 l = *PerlIONext(&l);
2313 return PerlIO_exportFILE(f,0);
2316 #undef PerlIO_releaseFILE
2318 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2322 /*--------------------------------------------------------------------------------------*/
2323 /* perlio buffer layer */
2326 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2328 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2329 int fd = PerlIO_fileno(f);
2332 if (fd >= 0 && PerlLIO_isatty(fd))
2334 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2336 posn = PerlIO_tell(PerlIONext(f));
2337 if (posn != (Off_t) -1)
2341 return PerlIOBase_pushed(f,mode,arg);
2345 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)
2349 PerlIO *next = PerlIONext(f);
2350 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2351 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2352 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2359 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2366 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2369 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2370 fd = PerlIO_fileno(f);
2371 #if O_BINARY != O_TEXT
2372 /* do something about failing setmode()? --jhi */
2373 PerlLIO_setmode(fd , O_BINARY);
2375 if (init && fd == 2)
2377 /* Initial stderr is unbuffered */
2378 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2385 /* This "flush" is akin to sfio's sync in that it handles files in either
2389 PerlIOBuf_flush(PerlIO *f)
2391 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2393 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2395 /* write() the buffer */
2396 STDCHAR *buf = b->buf;
2398 PerlIO *n = PerlIONext(f);
2401 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2406 else if (count < 0 || PerlIO_error(n))
2408 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2413 b->posn += (p - buf);
2415 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2417 STDCHAR *buf = PerlIO_get_base(f);
2418 /* Note position change */
2419 b->posn += (b->ptr - buf);
2420 if (b->ptr < b->end)
2422 /* We did not consume all of it */
2423 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2425 b->posn = PerlIO_tell(PerlIONext(f));
2429 b->ptr = b->end = b->buf;
2430 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2431 /* FIXME: Is this right for read case ? */
2432 if (PerlIO_flush(PerlIONext(f)) != 0)
2438 PerlIOBuf_fill(PerlIO *f)
2440 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2441 PerlIO *n = PerlIONext(f);
2443 /* FIXME: doing the down-stream flush is a bad idea if it causes
2444 pre-read data in stdio buffer to be discarded
2445 but this is too simplistic - as it skips _our_ hosekeeping
2446 and breaks tell tests.
2447 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2451 if (PerlIO_flush(f) != 0)
2455 PerlIO_get_base(f); /* allocate via vtable */
2457 b->ptr = b->end = b->buf;
2458 if (PerlIO_fast_gets(n))
2460 /* Layer below is also buffered
2461 * We do _NOT_ want to call its ->Read() because that will loop
2462 * till it gets what we asked for which may hang on a pipe etc.
2463 * Instead take anything it has to hand, or ask it to fill _once_.
2465 avail = PerlIO_get_cnt(n);
2468 avail = PerlIO_fill(n);
2470 avail = PerlIO_get_cnt(n);
2473 if (!PerlIO_error(n) && PerlIO_eof(n))
2479 STDCHAR *ptr = PerlIO_get_ptr(n);
2480 SSize_t cnt = avail;
2481 if (avail > b->bufsiz)
2483 Copy(ptr,b->buf,avail,STDCHAR);
2484 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2489 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2494 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2496 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2499 b->end = b->buf+avail;
2500 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2505 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2507 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2512 return PerlIOBase_read(f,vbuf,count);
2518 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2520 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2521 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2524 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2530 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2532 avail = (b->ptr - b->buf);
2537 b->end = b->buf + avail;
2539 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2540 b->posn -= b->bufsiz;
2542 if (avail > (SSize_t) count)
2550 Copy(buf,b->ptr,avail,STDCHAR);
2554 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2561 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2563 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2564 const STDCHAR *buf = (const STDCHAR *) vbuf;
2568 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2572 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2573 if ((SSize_t) count < avail)
2575 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2576 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2596 Copy(buf,b->ptr,avail,STDCHAR);
2603 if (b->ptr >= (b->buf + b->bufsiz))
2606 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2612 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2615 if ((code = PerlIO_flush(f)) == 0)
2617 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2618 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2619 code = PerlIO_seek(PerlIONext(f),offset,whence);
2622 b->posn = PerlIO_tell(PerlIONext(f));
2629 PerlIOBuf_tell(PerlIO *f)
2631 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2632 Off_t posn = b->posn;
2634 posn += (b->ptr - b->buf);
2639 PerlIOBuf_close(PerlIO *f)
2642 IV code = PerlIOBase_close(f);
2643 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2644 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2646 PerlMemShared_free(b->buf);
2649 b->ptr = b->end = b->buf;
2650 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2655 PerlIOBuf_get_ptr(PerlIO *f)
2657 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2664 PerlIOBuf_get_cnt(PerlIO *f)
2666 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2669 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2670 return (b->end - b->ptr);
2675 PerlIOBuf_get_base(PerlIO *f)
2677 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2683 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2686 b->buf = (STDCHAR *)&b->oneword;
2687 b->bufsiz = sizeof(b->oneword);
2696 PerlIOBuf_bufsiz(PerlIO *f)
2698 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2701 return (b->end - b->buf);
2705 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2707 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2711 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2714 assert(PerlIO_get_cnt(f) == cnt);
2715 assert(b->ptr >= b->buf);
2717 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2720 PerlIO_funcs PerlIO_perlio = {
2739 PerlIOBase_clearerr,
2740 PerlIOBase_setlinebuf,
2745 PerlIOBuf_set_ptrcnt,
2748 /*--------------------------------------------------------------------------------------*/
2749 /* Temp layer to hold unread chars when cannot do it any other way */
2752 PerlIOPending_fill(PerlIO *f)
2754 /* Should never happen */
2760 PerlIOPending_close(PerlIO *f)
2762 /* A tad tricky - flush pops us, then we close new top */
2764 return PerlIO_close(f);
2768 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2770 /* A tad tricky - flush pops us, then we seek new top */
2772 return PerlIO_seek(f,offset,whence);
2777 PerlIOPending_flush(PerlIO *f)
2780 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2781 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2783 PerlMemShared_free(b->buf);
2786 PerlIO_pop(aTHX_ f);
2791 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2799 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2804 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2806 IV code = PerlIOBase_pushed(f,mode,arg);
2807 PerlIOl *l = PerlIOBase(f);
2808 /* Our PerlIO_fast_gets must match what we are pushed on,
2809 or sv_gets() etc. get muddled when it changes mid-string
2812 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2813 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2818 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2820 SSize_t avail = PerlIO_get_cnt(f);
2825 got = PerlIOBuf_read(f,vbuf,avail);
2826 if (got >= 0 && got < count)
2828 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2829 if (more >= 0 || got == 0)
2835 PerlIO_funcs PerlIO_pending = {
2839 PerlIOPending_pushed,
2849 PerlIOPending_close,
2850 PerlIOPending_flush,
2854 PerlIOBase_clearerr,
2855 PerlIOBase_setlinebuf,
2860 PerlIOPending_set_ptrcnt,
2865 /*--------------------------------------------------------------------------------------*/
2866 /* crlf - translation
2867 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2868 to hand back a line at a time and keeping a record of which nl we "lied" about.
2869 On write translate "\n" to CR,LF
2874 PerlIOBuf base; /* PerlIOBuf stuff */
2875 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2879 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2882 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2883 code = PerlIOBuf_pushed(f,mode,arg);
2885 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2886 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2887 PerlIOBase(f)->flags);
2894 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2896 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2902 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2903 return PerlIOBuf_unread(f,vbuf,count);
2906 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2907 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2909 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2915 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2917 b->end = b->ptr = b->buf + b->bufsiz;
2918 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2919 b->posn -= b->bufsiz;
2921 while (count > 0 && b->ptr > b->buf)
2926 if (b->ptr - 2 >= b->buf)
2952 PerlIOCrlf_get_cnt(PerlIO *f)
2954 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2957 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2959 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2960 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2962 STDCHAR *nl = b->ptr;
2964 while (nl < b->end && *nl != 0xd)
2966 if (nl < b->end && *nl == 0xd)
2978 /* Not CR,LF but just CR */
2985 /* Blast - found CR as last char in buffer */
2988 /* They may not care, defer work as long as possible */
2989 return (nl - b->ptr);
2995 b->ptr++; /* say we have read it as far as flush() is concerned */
2996 b->buf++; /* Leave space an front of buffer */
2997 b->bufsiz--; /* Buffer is thus smaller */
2998 code = PerlIO_fill(f); /* Fetch some more */
2999 b->bufsiz++; /* Restore size for next time */
3000 b->buf--; /* Point at space */
3001 b->ptr = nl = b->buf; /* Which is what we hand off */
3002 b->posn--; /* Buffer starts here */
3003 *nl = 0xd; /* Fill in the CR */
3005 goto test; /* fill() call worked */
3006 /* CR at EOF - just fall through */
3011 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3017 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3019 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3020 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3021 IV flags = PerlIOBase(f)->flags;
3031 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3038 /* Test code - delete when it works ... */
3045 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3053 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3054 ptr, chk, flags, c->nl, b->end, cnt);
3061 /* They have taken what we lied about */
3068 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3072 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3074 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3075 return PerlIOBuf_write(f,vbuf,count);
3078 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3079 const STDCHAR *buf = (const STDCHAR *) vbuf;
3080 const STDCHAR *ebuf = buf+count;
3083 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3087 STDCHAR *eptr = b->buf+b->bufsiz;
3088 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3089 while (buf < ebuf && b->ptr < eptr)
3093 if ((b->ptr + 2) > eptr)
3095 /* Not room for both */
3101 *(b->ptr)++ = 0xd; /* CR */
3102 *(b->ptr)++ = 0xa; /* LF */
3104 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3123 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3125 return (buf - (STDCHAR *) vbuf);
3130 PerlIOCrlf_flush(PerlIO *f)
3132 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3138 return PerlIOBuf_flush(f);
3141 PerlIO_funcs PerlIO_crlf = {
3144 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3146 PerlIOBase_noop_ok, /* popped */
3150 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3151 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3152 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3160 PerlIOBase_clearerr,
3161 PerlIOBase_setlinebuf,
3166 PerlIOCrlf_set_ptrcnt,
3170 /*--------------------------------------------------------------------------------------*/
3171 /* mmap as "buffer" layer */
3175 PerlIOBuf base; /* PerlIOBuf stuff */
3176 Mmap_t mptr; /* Mapped address */
3177 Size_t len; /* mapped length */
3178 STDCHAR *bbuf; /* malloced buffer if map fails */
3181 static size_t page_size = 0;
3184 PerlIOMmap_map(PerlIO *f)
3187 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3188 PerlIOBuf *b = &m->base;
3189 IV flags = PerlIOBase(f)->flags;
3193 if (flags & PERLIO_F_CANREAD)
3195 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3196 int fd = PerlIO_fileno(f);
3198 code = fstat(fd,&st);
3199 if (code == 0 && S_ISREG(st.st_mode))
3201 SSize_t len = st.st_size - b->posn;
3206 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3208 SETERRNO(0,SS$_NORMAL);
3209 # ifdef _SC_PAGESIZE
3210 page_size = sysconf(_SC_PAGESIZE);
3212 page_size = sysconf(_SC_PAGE_SIZE);
3214 if ((long)page_size < 0) {
3219 (void)SvUPGRADE(error, SVt_PV);
3220 msg = SvPVx(error, n_a);
3221 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3224 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3228 # ifdef HAS_GETPAGESIZE
3229 page_size = getpagesize();
3231 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3232 page_size = PAGESIZE; /* compiletime, bad */
3236 if ((IV)page_size <= 0)
3237 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3241 /* This is a hack - should never happen - open should have set it ! */
3242 b->posn = PerlIO_tell(PerlIONext(f));
3244 posn = (b->posn / page_size) * page_size;
3245 len = st.st_size - posn;
3246 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3247 if (m->mptr && m->mptr != (Mmap_t) -1)
3249 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3250 madvise(m->mptr, len, MADV_SEQUENTIAL);
3252 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3253 madvise(m->mptr, len, MADV_WILLNEED);
3255 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3256 b->end = ((STDCHAR *)m->mptr) + len;
3257 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3268 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3270 b->ptr = b->end = b->ptr;
3279 PerlIOMmap_unmap(PerlIO *f)
3281 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3282 PerlIOBuf *b = &m->base;
3288 code = munmap(m->mptr, m->len);
3292 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3295 b->ptr = b->end = b->buf;
3296 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3302 PerlIOMmap_get_base(PerlIO *f)
3304 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3305 PerlIOBuf *b = &m->base;
3306 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3308 /* Already have a readbuffer in progress */
3313 /* We have a write buffer or flushed PerlIOBuf read buffer */
3314 m->bbuf = b->buf; /* save it in case we need it again */
3315 b->buf = NULL; /* Clear to trigger below */
3319 PerlIOMmap_map(f); /* Try and map it */
3322 /* Map did not work - recover PerlIOBuf buffer if we have one */
3326 b->ptr = b->end = b->buf;
3329 return PerlIOBuf_get_base(f);
3333 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3335 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3336 PerlIOBuf *b = &m->base;
3337 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3339 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3342 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3347 /* Loose the unwritable mapped buffer */
3349 /* If flush took the "buffer" see if we have one from before */
3350 if (!b->buf && m->bbuf)
3354 PerlIOBuf_get_base(f);
3358 return PerlIOBuf_unread(f,vbuf,count);
3362 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3364 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3365 PerlIOBuf *b = &m->base;
3366 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3368 /* No, or wrong sort of, buffer */
3371 if (PerlIOMmap_unmap(f) != 0)
3374 /* If unmap took the "buffer" see if we have one from before */
3375 if (!b->buf && m->bbuf)
3379 PerlIOBuf_get_base(f);
3383 return PerlIOBuf_write(f,vbuf,count);
3387 PerlIOMmap_flush(PerlIO *f)
3389 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3390 PerlIOBuf *b = &m->base;
3391 IV code = PerlIOBuf_flush(f);
3392 /* Now we are "synced" at PerlIOBuf level */
3397 /* Unmap the buffer */
3398 if (PerlIOMmap_unmap(f) != 0)
3403 /* We seem to have a PerlIOBuf buffer which was not mapped
3404 * remember it in case we need one later
3413 PerlIOMmap_fill(PerlIO *f)
3415 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3416 IV code = PerlIO_flush(f);
3417 if (code == 0 && !b->buf)
3419 code = PerlIOMmap_map(f);
3421 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3423 code = PerlIOBuf_fill(f);
3429 PerlIOMmap_close(PerlIO *f)
3431 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3432 PerlIOBuf *b = &m->base;
3433 IV code = PerlIO_flush(f);
3438 b->ptr = b->end = b->buf;
3440 if (PerlIOBuf_close(f) != 0)
3446 PerlIO_funcs PerlIO_mmap = {
3465 PerlIOBase_clearerr,
3466 PerlIOBase_setlinebuf,
3467 PerlIOMmap_get_base,
3471 PerlIOBuf_set_ptrcnt,
3474 #endif /* HAS_MMAP */
3482 atexit(&PerlIO_cleanup);
3494 PerlIO_stdstreams(aTHX);
3499 #undef PerlIO_stdout
3506 PerlIO_stdstreams(aTHX);
3511 #undef PerlIO_stderr
3518 PerlIO_stdstreams(aTHX);
3523 /*--------------------------------------------------------------------------------------*/
3525 #undef PerlIO_getname
3527 PerlIO_getname(PerlIO *f, char *buf)
3530 Perl_croak(aTHX_ "Don't know how to get file name");
3535 /*--------------------------------------------------------------------------------------*/
3536 /* Functions which can be called on any kind of PerlIO implemented
3542 PerlIO_getc(PerlIO *f)
3545 SSize_t count = PerlIO_read(f,buf,1);
3548 return (unsigned char) buf[0];
3553 #undef PerlIO_ungetc
3555 PerlIO_ungetc(PerlIO *f, int ch)
3560 if (PerlIO_unread(f,&buf,1) == 1)
3568 PerlIO_putc(PerlIO *f, int ch)
3571 return PerlIO_write(f,&buf,1);
3576 PerlIO_puts(PerlIO *f, const char *s)
3578 STRLEN len = strlen(s);
3579 return PerlIO_write(f,s,len);
3582 #undef PerlIO_rewind
3584 PerlIO_rewind(PerlIO *f)
3586 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3590 #undef PerlIO_vprintf
3592 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3595 SV *sv = newSVpvn("",0);
3601 Perl_va_copy(ap, apc);
3602 sv_vcatpvf(sv, fmt, &apc);
3604 sv_vcatpvf(sv, fmt, &ap);
3607 wrote = PerlIO_write(f,s,len);
3612 #undef PerlIO_printf
3614 PerlIO_printf(PerlIO *f,const char *fmt,...)
3619 result = PerlIO_vprintf(f,fmt,ap);
3624 #undef PerlIO_stdoutf
3626 PerlIO_stdoutf(const char *fmt,...)
3631 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3636 #undef PerlIO_tmpfile
3638 PerlIO_tmpfile(void)
3640 /* I have no idea how portable mkstemp() is ... */
3641 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3644 FILE *stdio = PerlSIO_tmpfile();
3647 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3653 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3654 int fd = mkstemp(SvPVX(sv));
3658 f = PerlIO_fdopen(fd,"w+");
3661 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3663 PerlLIO_unlink(SvPVX(sv));
3673 #endif /* USE_SFIO */
3674 #endif /* PERLIO_IS_STDIO */
3676 /*======================================================================================*/
3677 /* Now some functions in terms of above which may be needed even if
3678 we are not in true PerlIO mode
3682 #undef PerlIO_setpos
3684 PerlIO_setpos(PerlIO *f, SV *pos)
3690 Off_t *posn = (Off_t *) SvPV(pos,len);
3691 if (f && len == sizeof(Off_t))
3692 return PerlIO_seek(f,*posn,SEEK_SET);
3698 #undef PerlIO_setpos
3700 PerlIO_setpos(PerlIO *f, SV *pos)
3706 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3707 if (f && len == sizeof(Fpos_t))
3709 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3710 return fsetpos64(f, fpos);
3712 return fsetpos(f, fpos);
3722 #undef PerlIO_getpos
3724 PerlIO_getpos(PerlIO *f, SV *pos)
3727 Off_t posn = PerlIO_tell(f);
3728 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3729 return (posn == (Off_t)-1) ? -1 : 0;
3732 #undef PerlIO_getpos
3734 PerlIO_getpos(PerlIO *f, SV *pos)
3739 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3740 code = fgetpos64(f, &fpos);
3742 code = fgetpos(f, &fpos);
3744 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3749 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3752 vprintf(char *pat, char *args)
3754 _doprnt(pat, args, stdout);
3755 return 0; /* wrong, but perl doesn't use the return value */
3759 vfprintf(FILE *fd, char *pat, char *args)
3761 _doprnt(pat, args, fd);
3762 return 0; /* wrong, but perl doesn't use the return value */
3767 #ifndef PerlIO_vsprintf
3769 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3771 int val = vsprintf(s, fmt, ap);
3774 if (strlen(s) >= (STRLEN)n)
3777 (void)PerlIO_puts(Perl_error_log,
3778 "panic: sprintf overflow - memory corrupted!\n");
3786 #ifndef PerlIO_sprintf
3788 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3793 result = PerlIO_vsprintf(s, n, fmt, ap);