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 */
369 PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
373 if ((SSize_t) len <= 0)
375 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
376 if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
378 SV *pkgsv = newSVpvn("PerlIO",6);
379 SV *layer = newSVpvn(name,len);
381 /* The two SVs are magically freed by load_module */
382 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
384 /* Say this is lvalue so we get an 'undef' if still not there */
385 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
387 if (svp && (sv = *svp))
397 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
401 IO *io = GvIOn((GV *)SvRV(sv));
402 PerlIO *ifp = IoIFP(io);
403 PerlIO *ofp = IoOFP(io);
404 AV *av = (AV *) mg->mg_obj;
405 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
411 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
415 IO *io = GvIOn((GV *)SvRV(sv));
416 PerlIO *ifp = IoIFP(io);
417 PerlIO *ofp = IoOFP(io);
418 AV *av = (AV *) mg->mg_obj;
419 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
425 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
427 Perl_warn(aTHX_ "clear %"SVf,sv);
432 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
434 Perl_warn(aTHX_ "free %"SVf,sv);
438 MGVTBL perlio_vtab = {
446 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
449 SV *sv = SvRV(ST(1));
454 sv_magic(sv, (SV *)av, '~', NULL, 0);
456 mg = mg_find(sv,'~');
457 mg->mg_virtual = &perlio_vtab;
459 Perl_warn(aTHX_ "attrib %"SVf,sv);
460 for (i=2; i < items; i++)
463 const char *name = SvPV(ST(i),len);
464 SV *layer = PerlIO_find_layer(aTHX_ name,len);
467 av_push(av,SvREFCNT_inc(layer));
480 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
482 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
483 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
488 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
490 if (!PerlIO_layer_hv)
492 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
494 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
495 PerlIO_debug("define %s %p\n",tab->name,tab);
499 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
503 const char *s = names;
506 while (isSPACE(*s) || *s == ':')
512 const char *as = Nullch;
516 /* Message is consistent with how attribute lists are passed.
517 Even though this means "foo : : bar" is seen as an invalid separator
519 char q = ((*s == '\'') ? '"' : '\'');
520 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
526 } while (isALNUM(*e));
544 /* It's a nul terminated string, not allowed to \ the terminating null.
545 Anything other character is passed over. */
553 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
563 SV *layer = PerlIO_find_layer(aTHX_ s,llen);
566 av_push(av,SvREFCNT_inc(layer));
567 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
570 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
582 PerlIO_default_buffer(pTHX_ AV *av)
584 PerlIO_funcs *tab = &PerlIO_perlio;
585 if (O_BINARY != O_TEXT)
591 if (PerlIO_stdio.Set_ptrcnt)
596 PerlIO_debug("Pushing %s\n",tab->name);
597 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
598 av_push(av,&PL_sv_undef);
602 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
604 SV **svp = av_fetch(av,n,FALSE);
605 return (svp) ? *svp : Nullsv;
609 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
611 SV **svp = av_fetch(av,n,FALSE);
613 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
615 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
616 return INT2PTR(PerlIO_funcs *, SvIV(layer));
619 Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
624 PerlIO_default_layers(pTHX)
627 if (!PerlIO_layer_av)
629 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
630 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
632 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
634 PerlIO_define_layer(aTHX_ &PerlIO_raw);
635 PerlIO_define_layer(aTHX_ &PerlIO_unix);
636 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
637 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
638 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
640 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
642 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
643 PerlIO_define_layer(aTHX_ &PerlIO_byte);
644 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
645 av_push(PerlIO_layer_av,&PL_sv_undef);
648 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
652 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
655 len = av_len(PerlIO_layer_av)+1;
658 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
659 len = av_len(PerlIO_layer_av);
661 return PerlIO_layer_av;
666 PerlIO_default_layer(pTHX_ I32 n)
668 AV *av = PerlIO_default_layers(aTHX);
671 n += av_len(PerlIO_layer_av)+1;
672 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
675 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
676 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
679 PerlIO_stdstreams(pTHX)
683 PerlIO_allocate(aTHX);
684 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
685 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
686 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
691 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
694 l = PerlMemShared_calloc(tab->size,sizeof(char));
697 Zero(l,tab->size,char);
701 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
702 (mode) ? mode : "(Null)",arg);
703 if ((*l->tab->Pushed)(f,mode,arg) != 0)
713 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
727 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
729 /* Remove the dummy layer */
732 /* Pop back to bottom layer */
737 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
745 /* Nothing bellow - push unix on top then remove it */
746 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
748 PerlIO_pop(aTHX_ PerlIONext(f));
753 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
760 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
762 IV max = av_len(layers)+1;
766 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
769 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
781 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
786 AV *layers = newAV();
787 code = PerlIO_parse_layers(aTHX_ layers,names);
790 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
792 SvREFCNT_dec((SV *) layers);
798 /*--------------------------------------------------------------------------------------*/
799 /* Given the abstraction above the public API functions */
802 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
804 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
805 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
806 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
812 if (PerlIOBase(top)->tab == &PerlIO_crlf)
815 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
818 top = PerlIONext(top);
821 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
826 PerlIO__close(PerlIO *f)
828 return (*PerlIOBase(f)->tab->Close)(f);
831 #undef PerlIO_fdupopen
833 PerlIO_fdupopen(pTHX_ PerlIO *f)
836 int fd = PerlLIO_dup(PerlIO_fileno(f));
837 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
840 Off_t posn = PerlIO_tell(f);
841 PerlIO_seek(new,posn,SEEK_SET);
848 PerlIO_close(PerlIO *f)
854 code = (*PerlIOBase(f)->tab->Close)(f);
865 PerlIO_fileno(PerlIO *f)
867 return (*PerlIOBase(f)->tab->Fileno)(f);
871 PerlIO_context_layers(pTHX_ const char *mode)
873 const char *type = NULL;
874 /* Need to supply default layer info from open.pm */
877 SV *layers = PL_curcop->cop_io;
881 type = SvPV(layers,len);
882 if (type && mode[0] != 'r')
884 /* Skip to write part */
885 const char *s = strchr(type,0);
886 if (s && (s-type) < len)
897 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
899 AV *def = PerlIO_default_layers(aTHX);
902 PerlIO_stdstreams(aTHX);
905 if (SvROK(*args) && !sv_isobject(*args))
907 if (SvTYPE(SvRV(*args)) < SVt_PVAV)
909 SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
913 av_push(def,SvREFCNT_inc(handler));
914 av_push(def,&PL_sv_undef);
920 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)
1122 PerlIOBase_flush_linebuf()
1124 PerlIO **table = &_perlio;
1126 while ((f = *table))
1129 table = (PerlIO **)(f++);
1130 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1132 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1133 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1142 PerlIO_fill(PerlIO *f)
1144 return (*PerlIOBase(f)->tab->Fill)(f);
1147 #undef PerlIO_isutf8
1149 PerlIO_isutf8(PerlIO *f)
1151 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1156 PerlIO_eof(PerlIO *f)
1158 return (*PerlIOBase(f)->tab->Eof)(f);
1163 PerlIO_error(PerlIO *f)
1165 return (*PerlIOBase(f)->tab->Error)(f);
1168 #undef PerlIO_clearerr
1170 PerlIO_clearerr(PerlIO *f)
1173 (*PerlIOBase(f)->tab->Clearerr)(f);
1176 #undef PerlIO_setlinebuf
1178 PerlIO_setlinebuf(PerlIO *f)
1180 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1183 #undef PerlIO_has_base
1185 PerlIO_has_base(PerlIO *f)
1189 return (PerlIOBase(f)->tab->Get_base != NULL);
1194 #undef PerlIO_fast_gets
1196 PerlIO_fast_gets(PerlIO *f)
1198 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1200 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1201 return (tab->Set_ptrcnt != NULL);
1206 #undef PerlIO_has_cntptr
1208 PerlIO_has_cntptr(PerlIO *f)
1212 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1213 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1218 #undef PerlIO_canset_cnt
1220 PerlIO_canset_cnt(PerlIO *f)
1224 PerlIOl *l = PerlIOBase(f);
1225 return (l->tab->Set_ptrcnt != NULL);
1230 #undef PerlIO_get_base
1232 PerlIO_get_base(PerlIO *f)
1234 return (*PerlIOBase(f)->tab->Get_base)(f);
1237 #undef PerlIO_get_bufsiz
1239 PerlIO_get_bufsiz(PerlIO *f)
1241 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1244 #undef PerlIO_get_ptr
1246 PerlIO_get_ptr(PerlIO *f)
1248 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1249 if (tab->Get_ptr == NULL)
1251 return (*tab->Get_ptr)(f);
1254 #undef PerlIO_get_cnt
1256 PerlIO_get_cnt(PerlIO *f)
1258 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1259 if (tab->Get_cnt == NULL)
1261 return (*tab->Get_cnt)(f);
1264 #undef PerlIO_set_cnt
1266 PerlIO_set_cnt(PerlIO *f,int cnt)
1268 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1271 #undef PerlIO_set_ptrcnt
1273 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1275 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1276 if (tab->Set_ptrcnt == NULL)
1279 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1281 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1284 /*--------------------------------------------------------------------------------------*/
1285 /* utf8 and raw dummy layers */
1288 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1293 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1294 PerlIO_pop(aTHX_ f);
1295 if (tab->kind & PERLIO_K_UTF8)
1296 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1298 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1304 PerlIO_funcs PerlIO_utf8 = {
1307 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1325 NULL, /* get_base */
1326 NULL, /* get_bufsiz */
1329 NULL, /* set_ptrcnt */
1332 PerlIO_funcs PerlIO_byte = {
1353 NULL, /* get_base */
1354 NULL, /* get_bufsiz */
1357 NULL, /* set_ptrcnt */
1361 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)
1363 PerlIO_funcs *tab = PerlIO_default_btm();
1364 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1367 PerlIO_funcs PerlIO_raw = {
1388 NULL, /* get_base */
1389 NULL, /* get_bufsiz */
1392 NULL, /* set_ptrcnt */
1394 /*--------------------------------------------------------------------------------------*/
1395 /*--------------------------------------------------------------------------------------*/
1396 /* "Methods" of the "base class" */
1399 PerlIOBase_fileno(PerlIO *f)
1401 return PerlIO_fileno(PerlIONext(f));
1405 PerlIO_modestr(PerlIO *f,char *buf)
1408 IV flags = PerlIOBase(f)->flags;
1409 if (flags & PERLIO_F_APPEND)
1412 if (flags & PERLIO_F_CANREAD)
1417 else if (flags & PERLIO_F_CANREAD)
1420 if (flags & PERLIO_F_CANWRITE)
1423 else if (flags & PERLIO_F_CANWRITE)
1426 if (flags & PERLIO_F_CANREAD)
1431 #if O_TEXT != O_BINARY
1432 if (!(flags & PERLIO_F_CRLF))
1440 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1442 PerlIOl *l = PerlIOBase(f);
1443 const char *omode = mode;
1445 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1446 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1447 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1448 if (tab->Set_ptrcnt != NULL)
1449 l->flags |= PERLIO_F_FASTGETS;
1455 l->flags |= PERLIO_F_CANREAD;
1458 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1461 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1472 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1475 l->flags &= ~PERLIO_F_CRLF;
1478 l->flags |= PERLIO_F_CRLF;
1490 l->flags |= l->next->flags &
1491 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1495 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1496 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1497 l->flags,PerlIO_modestr(f,temp));
1503 PerlIOBase_popped(PerlIO *f)
1509 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1512 Off_t old = PerlIO_tell(f);
1514 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1515 done = PerlIOBuf_unread(f,vbuf,count);
1516 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1521 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1523 STDCHAR *buf = (STDCHAR *) vbuf;
1526 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1530 SSize_t avail = PerlIO_get_cnt(f);
1531 SSize_t take = (count < avail) ? count : avail;
1534 STDCHAR *ptr = PerlIO_get_ptr(f);
1535 Copy(ptr,buf,take,STDCHAR);
1536 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1540 if (count > 0 && avail <= 0)
1542 if (PerlIO_fill(f) != 0)
1546 return (buf - (STDCHAR *) vbuf);
1552 PerlIOBase_noop_ok(PerlIO *f)
1558 PerlIOBase_noop_fail(PerlIO *f)
1564 PerlIOBase_close(PerlIO *f)
1567 PerlIO *n = PerlIONext(f);
1568 if (PerlIO_flush(f) != 0)
1570 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1572 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1577 PerlIOBase_eof(PerlIO *f)
1581 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1587 PerlIOBase_error(PerlIO *f)
1591 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1597 PerlIOBase_clearerr(PerlIO *f)
1601 PerlIO *n = PerlIONext(f);
1602 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1609 PerlIOBase_setlinebuf(PerlIO *f)
1613 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1617 /*--------------------------------------------------------------------------------------*/
1618 /* Bottom-most level for UNIX-like case */
1622 struct _PerlIO base; /* The generic part */
1623 int fd; /* UNIX like file descriptor */
1624 int oflags; /* open/fcntl flags */
1628 PerlIOUnix_oflags(const char *mode)
1643 oflags = O_CREAT|O_TRUNC;
1654 oflags = O_CREAT|O_APPEND;
1670 else if (*mode == 't')
1673 oflags &= ~O_BINARY;
1676 /* Always open in binary mode */
1678 if (*mode || oflags == -1)
1687 PerlIOUnix_fileno(PerlIO *f)
1689 return PerlIOSelf(f,PerlIOUnix)->fd;
1693 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1695 IV code = PerlIOBase_pushed(f,mode,arg);
1698 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1699 s->fd = PerlIO_fileno(PerlIONext(f));
1700 s->oflags = PerlIOUnix_oflags(mode);
1702 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1707 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)
1711 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1712 (*PerlIOBase(f)->tab->Close)(f);
1716 char *path = SvPV_nolen(*args);
1721 imode = PerlIOUnix_oflags(mode);
1726 fd = PerlLIO_open3(path,imode,perm);
1736 f = PerlIO_allocate(aTHX);
1737 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1740 s = PerlIOSelf(f,PerlIOUnix);
1743 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1750 /* FIXME: pop layers ??? */
1757 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1760 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1761 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1765 SSize_t len = PerlLIO_read(fd,vbuf,count);
1766 if (len >= 0 || errno != EINTR)
1769 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1770 else if (len == 0 && count != 0)
1771 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1779 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1782 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1785 SSize_t len = PerlLIO_write(fd,vbuf,count);
1786 if (len >= 0 || errno != EINTR)
1789 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1797 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1800 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1801 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1802 return (new == (Off_t) -1) ? -1 : 0;
1806 PerlIOUnix_tell(PerlIO *f)
1809 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1810 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1814 PerlIOUnix_close(PerlIO *f)
1817 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1819 while (PerlLIO_close(fd) != 0)
1830 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1835 PerlIO_funcs PerlIO_unix = {
1850 PerlIOBase_noop_ok, /* flush */
1851 PerlIOBase_noop_fail, /* fill */
1854 PerlIOBase_clearerr,
1855 PerlIOBase_setlinebuf,
1856 NULL, /* get_base */
1857 NULL, /* get_bufsiz */
1860 NULL, /* set_ptrcnt */
1863 /*--------------------------------------------------------------------------------------*/
1864 /* stdio as a layer */
1868 struct _PerlIO base;
1869 FILE * stdio; /* The stream */
1873 PerlIOStdio_fileno(PerlIO *f)
1876 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1880 PerlIOStdio_mode(const char *mode,char *tmode)
1887 if (O_BINARY != O_TEXT)
1895 /* This isn't used yet ... */
1897 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1902 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1904 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1910 return PerlIOBase_pushed(f,mode,arg);
1913 #undef PerlIO_importFILE
1915 PerlIO_importFILE(FILE *stdio, int fl)
1921 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1928 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)
1933 char *path = SvPV_nolen(*args);
1934 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1935 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1945 char *path = SvPV_nolen(*args);
1949 fd = PerlLIO_open3(path,imode,perm);
1953 FILE *stdio = PerlSIO_fopen(path,mode);
1956 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1957 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
1978 stdio = PerlSIO_stdin;
1981 stdio = PerlSIO_stdout;
1984 stdio = PerlSIO_stderr;
1990 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1994 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2004 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2007 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2011 STDCHAR *buf = (STDCHAR *) vbuf;
2012 /* Perl is expecting PerlIO_getc() to fill the buffer
2013 * Linux's stdio does not do that for fread()
2015 int ch = PerlSIO_fgetc(s);
2023 got = PerlSIO_fread(vbuf,1,count,s);
2028 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2031 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2032 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2036 int ch = *buf-- & 0xff;
2037 if (PerlSIO_ungetc(ch,s) != ch)
2046 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2049 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2053 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2056 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2057 return PerlSIO_fseek(stdio,offset,whence);
2061 PerlIOStdio_tell(PerlIO *f)
2064 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2065 return PerlSIO_ftell(stdio);
2069 PerlIOStdio_close(PerlIO *f)
2072 #ifdef HAS_SOCKS5_INIT
2073 int optval, optlen = sizeof(int);
2075 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2077 #ifdef HAS_SOCKS5_INIT
2078 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2079 PerlSIO_fclose(stdio) :
2080 close(PerlIO_fileno(f))
2082 PerlSIO_fclose(stdio)
2089 PerlIOStdio_flush(PerlIO *f)
2092 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2093 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2095 return PerlSIO_fflush(stdio);
2100 /* FIXME: This discards ungetc() and pre-read stuff which is
2101 not right if this is just a "sync" from a layer above
2102 Suspect right design is to do _this_ but not have layer above
2103 flush this layer read-to-read
2105 /* Not writeable - sync by attempting a seek */
2107 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2115 PerlIOStdio_fill(PerlIO *f)
2118 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2120 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2121 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2123 if (PerlSIO_fflush(stdio) != 0)
2126 c = PerlSIO_fgetc(stdio);
2127 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2133 PerlIOStdio_eof(PerlIO *f)
2136 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2140 PerlIOStdio_error(PerlIO *f)
2143 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2147 PerlIOStdio_clearerr(PerlIO *f)
2150 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2154 PerlIOStdio_setlinebuf(PerlIO *f)
2157 #ifdef HAS_SETLINEBUF
2158 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2160 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2166 PerlIOStdio_get_base(PerlIO *f)
2169 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2170 return PerlSIO_get_base(stdio);
2174 PerlIOStdio_get_bufsiz(PerlIO *f)
2177 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2178 return PerlSIO_get_bufsiz(stdio);
2182 #ifdef USE_STDIO_PTR
2184 PerlIOStdio_get_ptr(PerlIO *f)
2187 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2188 return PerlSIO_get_ptr(stdio);
2192 PerlIOStdio_get_cnt(PerlIO *f)
2195 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2196 return PerlSIO_get_cnt(stdio);
2200 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2203 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2206 #ifdef STDIO_PTR_LVALUE
2207 PerlSIO_set_ptr(stdio,ptr);
2208 #ifdef STDIO_PTR_LVAL_SETS_CNT
2209 if (PerlSIO_get_cnt(stdio) != (cnt))
2212 assert(PerlSIO_get_cnt(stdio) == (cnt));
2215 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2216 /* Setting ptr _does_ change cnt - we are done */
2219 #else /* STDIO_PTR_LVALUE */
2221 #endif /* STDIO_PTR_LVALUE */
2223 /* Now (or only) set cnt */
2224 #ifdef STDIO_CNT_LVALUE
2225 PerlSIO_set_cnt(stdio,cnt);
2226 #else /* STDIO_CNT_LVALUE */
2227 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2228 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2229 #else /* STDIO_PTR_LVAL_SETS_CNT */
2231 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2232 #endif /* STDIO_CNT_LVALUE */
2237 PerlIO_funcs PerlIO_stdio = {
2239 sizeof(PerlIOStdio),
2256 PerlIOStdio_clearerr,
2257 PerlIOStdio_setlinebuf,
2259 PerlIOStdio_get_base,
2260 PerlIOStdio_get_bufsiz,
2265 #ifdef USE_STDIO_PTR
2266 PerlIOStdio_get_ptr,
2267 PerlIOStdio_get_cnt,
2268 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2269 PerlIOStdio_set_ptrcnt
2270 #else /* STDIO_PTR_LVALUE */
2272 #endif /* STDIO_PTR_LVALUE */
2273 #else /* USE_STDIO_PTR */
2277 #endif /* USE_STDIO_PTR */
2280 #undef PerlIO_exportFILE
2282 PerlIO_exportFILE(PerlIO *f, int fl)
2286 stdio = fdopen(PerlIO_fileno(f),"r+");
2290 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2296 #undef PerlIO_findFILE
2298 PerlIO_findFILE(PerlIO *f)
2303 if (l->tab == &PerlIO_stdio)
2305 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2308 l = *PerlIONext(&l);
2310 return PerlIO_exportFILE(f,0);
2313 #undef PerlIO_releaseFILE
2315 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2319 /*--------------------------------------------------------------------------------------*/
2320 /* perlio buffer layer */
2323 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2325 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2326 int fd = PerlIO_fileno(f);
2329 if (fd >= 0 && PerlLIO_isatty(fd))
2331 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2333 posn = PerlIO_tell(PerlIONext(f));
2334 if (posn != (Off_t) -1)
2338 return PerlIOBase_pushed(f,mode,arg);
2342 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)
2346 PerlIO *next = PerlIONext(f);
2347 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2348 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2349 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2356 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2363 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2366 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2367 fd = PerlIO_fileno(f);
2368 #if O_BINARY != O_TEXT
2369 /* do something about failing setmode()? --jhi */
2370 PerlLIO_setmode(fd , O_BINARY);
2372 if (init && fd == 2)
2374 /* Initial stderr is unbuffered */
2375 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2382 /* This "flush" is akin to sfio's sync in that it handles files in either
2386 PerlIOBuf_flush(PerlIO *f)
2388 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2390 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2392 /* write() the buffer */
2393 STDCHAR *buf = b->buf;
2395 PerlIO *n = PerlIONext(f);
2398 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2403 else if (count < 0 || PerlIO_error(n))
2405 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2410 b->posn += (p - buf);
2412 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2414 STDCHAR *buf = PerlIO_get_base(f);
2415 /* Note position change */
2416 b->posn += (b->ptr - buf);
2417 if (b->ptr < b->end)
2419 /* We did not consume all of it */
2420 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2422 b->posn = PerlIO_tell(PerlIONext(f));
2426 b->ptr = b->end = b->buf;
2427 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2428 /* FIXME: Is this right for read case ? */
2429 if (PerlIO_flush(PerlIONext(f)) != 0)
2435 PerlIOBuf_fill(PerlIO *f)
2437 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2438 PerlIO *n = PerlIONext(f);
2440 /* FIXME: doing the down-stream flush is a bad idea if it causes
2441 pre-read data in stdio buffer to be discarded
2442 but this is too simplistic - as it skips _our_ hosekeeping
2443 and breaks tell tests.
2444 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2448 if (PerlIO_flush(f) != 0)
2450 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2451 PerlIOBase_flush_linebuf();
2454 PerlIO_get_base(f); /* allocate via vtable */
2456 b->ptr = b->end = b->buf;
2457 if (PerlIO_fast_gets(n))
2459 /* Layer below is also buffered
2460 * We do _NOT_ want to call its ->Read() because that will loop
2461 * till it gets what we asked for which may hang on a pipe etc.
2462 * Instead take anything it has to hand, or ask it to fill _once_.
2464 avail = PerlIO_get_cnt(n);
2467 avail = PerlIO_fill(n);
2469 avail = PerlIO_get_cnt(n);
2472 if (!PerlIO_error(n) && PerlIO_eof(n))
2478 STDCHAR *ptr = PerlIO_get_ptr(n);
2479 SSize_t cnt = avail;
2480 if (avail > b->bufsiz)
2482 Copy(ptr,b->buf,avail,STDCHAR);
2483 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2488 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2493 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2495 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2498 b->end = b->buf+avail;
2499 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2504 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2506 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2511 return PerlIOBase_read(f,vbuf,count);
2517 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2519 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2520 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2523 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2529 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2531 avail = (b->ptr - b->buf);
2536 b->end = b->buf + avail;
2538 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2539 b->posn -= b->bufsiz;
2541 if (avail > (SSize_t) count)
2549 Copy(buf,b->ptr,avail,STDCHAR);
2553 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2560 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2562 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2563 const STDCHAR *buf = (const STDCHAR *) vbuf;
2567 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2571 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2572 if ((SSize_t) count < avail)
2574 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2575 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2595 Copy(buf,b->ptr,avail,STDCHAR);
2602 if (b->ptr >= (b->buf + b->bufsiz))
2605 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2611 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2614 if ((code = PerlIO_flush(f)) == 0)
2616 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2617 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2618 code = PerlIO_seek(PerlIONext(f),offset,whence);
2621 b->posn = PerlIO_tell(PerlIONext(f));
2628 PerlIOBuf_tell(PerlIO *f)
2630 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2631 Off_t posn = b->posn;
2633 posn += (b->ptr - b->buf);
2638 PerlIOBuf_close(PerlIO *f)
2641 IV code = PerlIOBase_close(f);
2642 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2643 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2645 PerlMemShared_free(b->buf);
2648 b->ptr = b->end = b->buf;
2649 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2654 PerlIOBuf_get_ptr(PerlIO *f)
2656 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2663 PerlIOBuf_get_cnt(PerlIO *f)
2665 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2668 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2669 return (b->end - b->ptr);
2674 PerlIOBuf_get_base(PerlIO *f)
2676 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2682 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2685 b->buf = (STDCHAR *)&b->oneword;
2686 b->bufsiz = sizeof(b->oneword);
2695 PerlIOBuf_bufsiz(PerlIO *f)
2697 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2700 return (b->end - b->buf);
2704 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2706 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2710 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2713 assert(PerlIO_get_cnt(f) == cnt);
2714 assert(b->ptr >= b->buf);
2716 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2719 PerlIO_funcs PerlIO_perlio = {
2738 PerlIOBase_clearerr,
2739 PerlIOBase_setlinebuf,
2744 PerlIOBuf_set_ptrcnt,
2747 /*--------------------------------------------------------------------------------------*/
2748 /* Temp layer to hold unread chars when cannot do it any other way */
2751 PerlIOPending_fill(PerlIO *f)
2753 /* Should never happen */
2759 PerlIOPending_close(PerlIO *f)
2761 /* A tad tricky - flush pops us, then we close new top */
2763 return PerlIO_close(f);
2767 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2769 /* A tad tricky - flush pops us, then we seek new top */
2771 return PerlIO_seek(f,offset,whence);
2776 PerlIOPending_flush(PerlIO *f)
2779 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2780 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2782 PerlMemShared_free(b->buf);
2785 PerlIO_pop(aTHX_ f);
2790 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2798 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2803 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2805 IV code = PerlIOBase_pushed(f,mode,arg);
2806 PerlIOl *l = PerlIOBase(f);
2807 /* Our PerlIO_fast_gets must match what we are pushed on,
2808 or sv_gets() etc. get muddled when it changes mid-string
2811 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2812 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2817 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2819 SSize_t avail = PerlIO_get_cnt(f);
2824 got = PerlIOBuf_read(f,vbuf,avail);
2825 if (got >= 0 && got < count)
2827 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2828 if (more >= 0 || got == 0)
2834 PerlIO_funcs PerlIO_pending = {
2838 PerlIOPending_pushed,
2848 PerlIOPending_close,
2849 PerlIOPending_flush,
2853 PerlIOBase_clearerr,
2854 PerlIOBase_setlinebuf,
2859 PerlIOPending_set_ptrcnt,
2864 /*--------------------------------------------------------------------------------------*/
2865 /* crlf - translation
2866 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2867 to hand back a line at a time and keeping a record of which nl we "lied" about.
2868 On write translate "\n" to CR,LF
2873 PerlIOBuf base; /* PerlIOBuf stuff */
2874 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2878 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2881 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2882 code = PerlIOBuf_pushed(f,mode,arg);
2884 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2885 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2886 PerlIOBase(f)->flags);
2893 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2895 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2901 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2902 return PerlIOBuf_unread(f,vbuf,count);
2905 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2906 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2908 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2914 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2916 b->end = b->ptr = b->buf + b->bufsiz;
2917 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2918 b->posn -= b->bufsiz;
2920 while (count > 0 && b->ptr > b->buf)
2925 if (b->ptr - 2 >= b->buf)
2951 PerlIOCrlf_get_cnt(PerlIO *f)
2953 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2956 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2958 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2959 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2961 STDCHAR *nl = b->ptr;
2963 while (nl < b->end && *nl != 0xd)
2965 if (nl < b->end && *nl == 0xd)
2977 /* Not CR,LF but just CR */
2984 /* Blast - found CR as last char in buffer */
2987 /* They may not care, defer work as long as possible */
2988 return (nl - b->ptr);
2994 b->ptr++; /* say we have read it as far as flush() is concerned */
2995 b->buf++; /* Leave space an front of buffer */
2996 b->bufsiz--; /* Buffer is thus smaller */
2997 code = PerlIO_fill(f); /* Fetch some more */
2998 b->bufsiz++; /* Restore size for next time */
2999 b->buf--; /* Point at space */
3000 b->ptr = nl = b->buf; /* Which is what we hand off */
3001 b->posn--; /* Buffer starts here */
3002 *nl = 0xd; /* Fill in the CR */
3004 goto test; /* fill() call worked */
3005 /* CR at EOF - just fall through */
3010 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3016 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3018 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3019 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3020 IV flags = PerlIOBase(f)->flags;
3030 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3037 /* Test code - delete when it works ... */
3044 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3052 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3053 ptr, chk, flags, c->nl, b->end, cnt);
3060 /* They have taken what we lied about */
3067 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3071 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3073 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3074 return PerlIOBuf_write(f,vbuf,count);
3077 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3078 const STDCHAR *buf = (const STDCHAR *) vbuf;
3079 const STDCHAR *ebuf = buf+count;
3082 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3086 STDCHAR *eptr = b->buf+b->bufsiz;
3087 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3088 while (buf < ebuf && b->ptr < eptr)
3092 if ((b->ptr + 2) > eptr)
3094 /* Not room for both */
3100 *(b->ptr)++ = 0xd; /* CR */
3101 *(b->ptr)++ = 0xa; /* LF */
3103 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3122 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3124 return (buf - (STDCHAR *) vbuf);
3129 PerlIOCrlf_flush(PerlIO *f)
3131 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3137 return PerlIOBuf_flush(f);
3140 PerlIO_funcs PerlIO_crlf = {
3143 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3145 PerlIOBase_noop_ok, /* popped */
3149 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3150 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3151 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3159 PerlIOBase_clearerr,
3160 PerlIOBase_setlinebuf,
3165 PerlIOCrlf_set_ptrcnt,
3169 /*--------------------------------------------------------------------------------------*/
3170 /* mmap as "buffer" layer */
3174 PerlIOBuf base; /* PerlIOBuf stuff */
3175 Mmap_t mptr; /* Mapped address */
3176 Size_t len; /* mapped length */
3177 STDCHAR *bbuf; /* malloced buffer if map fails */
3180 static size_t page_size = 0;
3183 PerlIOMmap_map(PerlIO *f)
3186 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3187 PerlIOBuf *b = &m->base;
3188 IV flags = PerlIOBase(f)->flags;
3192 if (flags & PERLIO_F_CANREAD)
3194 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3195 int fd = PerlIO_fileno(f);
3197 code = fstat(fd,&st);
3198 if (code == 0 && S_ISREG(st.st_mode))
3200 SSize_t len = st.st_size - b->posn;
3205 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3207 SETERRNO(0,SS$_NORMAL);
3208 # ifdef _SC_PAGESIZE
3209 page_size = sysconf(_SC_PAGESIZE);
3211 page_size = sysconf(_SC_PAGE_SIZE);
3213 if ((long)page_size < 0) {
3218 (void)SvUPGRADE(error, SVt_PV);
3219 msg = SvPVx(error, n_a);
3220 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3223 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3227 # ifdef HAS_GETPAGESIZE
3228 page_size = getpagesize();
3230 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3231 page_size = PAGESIZE; /* compiletime, bad */
3235 if ((IV)page_size <= 0)
3236 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3240 /* This is a hack - should never happen - open should have set it ! */
3241 b->posn = PerlIO_tell(PerlIONext(f));
3243 posn = (b->posn / page_size) * page_size;
3244 len = st.st_size - posn;
3245 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3246 if (m->mptr && m->mptr != (Mmap_t) -1)
3248 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3249 madvise(m->mptr, len, MADV_SEQUENTIAL);
3251 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3252 madvise(m->mptr, len, MADV_WILLNEED);
3254 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3255 b->end = ((STDCHAR *)m->mptr) + len;
3256 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3267 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3269 b->ptr = b->end = b->ptr;
3278 PerlIOMmap_unmap(PerlIO *f)
3280 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3281 PerlIOBuf *b = &m->base;
3287 code = munmap(m->mptr, m->len);
3291 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3294 b->ptr = b->end = b->buf;
3295 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3301 PerlIOMmap_get_base(PerlIO *f)
3303 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3304 PerlIOBuf *b = &m->base;
3305 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3307 /* Already have a readbuffer in progress */
3312 /* We have a write buffer or flushed PerlIOBuf read buffer */
3313 m->bbuf = b->buf; /* save it in case we need it again */
3314 b->buf = NULL; /* Clear to trigger below */
3318 PerlIOMmap_map(f); /* Try and map it */
3321 /* Map did not work - recover PerlIOBuf buffer if we have one */
3325 b->ptr = b->end = b->buf;
3328 return PerlIOBuf_get_base(f);
3332 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3334 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3335 PerlIOBuf *b = &m->base;
3336 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3338 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3341 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3346 /* Loose the unwritable mapped buffer */
3348 /* If flush took the "buffer" see if we have one from before */
3349 if (!b->buf && m->bbuf)
3353 PerlIOBuf_get_base(f);
3357 return PerlIOBuf_unread(f,vbuf,count);
3361 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3363 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3364 PerlIOBuf *b = &m->base;
3365 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3367 /* No, or wrong sort of, buffer */
3370 if (PerlIOMmap_unmap(f) != 0)
3373 /* If unmap took the "buffer" see if we have one from before */
3374 if (!b->buf && m->bbuf)
3378 PerlIOBuf_get_base(f);
3382 return PerlIOBuf_write(f,vbuf,count);
3386 PerlIOMmap_flush(PerlIO *f)
3388 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3389 PerlIOBuf *b = &m->base;
3390 IV code = PerlIOBuf_flush(f);
3391 /* Now we are "synced" at PerlIOBuf level */
3396 /* Unmap the buffer */
3397 if (PerlIOMmap_unmap(f) != 0)
3402 /* We seem to have a PerlIOBuf buffer which was not mapped
3403 * remember it in case we need one later
3412 PerlIOMmap_fill(PerlIO *f)
3414 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3415 IV code = PerlIO_flush(f);
3416 if (code == 0 && !b->buf)
3418 code = PerlIOMmap_map(f);
3420 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3422 code = PerlIOBuf_fill(f);
3428 PerlIOMmap_close(PerlIO *f)
3430 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3431 PerlIOBuf *b = &m->base;
3432 IV code = PerlIO_flush(f);
3437 b->ptr = b->end = b->buf;
3439 if (PerlIOBuf_close(f) != 0)
3445 PerlIO_funcs PerlIO_mmap = {
3464 PerlIOBase_clearerr,
3465 PerlIOBase_setlinebuf,
3466 PerlIOMmap_get_base,
3470 PerlIOBuf_set_ptrcnt,
3473 #endif /* HAS_MMAP */
3481 atexit(&PerlIO_cleanup);
3493 PerlIO_stdstreams(aTHX);
3498 #undef PerlIO_stdout
3505 PerlIO_stdstreams(aTHX);
3510 #undef PerlIO_stderr
3517 PerlIO_stdstreams(aTHX);
3522 /*--------------------------------------------------------------------------------------*/
3524 #undef PerlIO_getname
3526 PerlIO_getname(PerlIO *f, char *buf)
3529 Perl_croak(aTHX_ "Don't know how to get file name");
3534 /*--------------------------------------------------------------------------------------*/
3535 /* Functions which can be called on any kind of PerlIO implemented
3541 PerlIO_getc(PerlIO *f)
3544 SSize_t count = PerlIO_read(f,buf,1);
3547 return (unsigned char) buf[0];
3552 #undef PerlIO_ungetc
3554 PerlIO_ungetc(PerlIO *f, int ch)
3559 if (PerlIO_unread(f,&buf,1) == 1)
3567 PerlIO_putc(PerlIO *f, int ch)
3570 return PerlIO_write(f,&buf,1);
3575 PerlIO_puts(PerlIO *f, const char *s)
3577 STRLEN len = strlen(s);
3578 return PerlIO_write(f,s,len);
3581 #undef PerlIO_rewind
3583 PerlIO_rewind(PerlIO *f)
3585 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3589 #undef PerlIO_vprintf
3591 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3594 SV *sv = newSVpvn("",0);
3600 Perl_va_copy(ap, apc);
3601 sv_vcatpvf(sv, fmt, &apc);
3603 sv_vcatpvf(sv, fmt, &ap);
3606 wrote = PerlIO_write(f,s,len);
3611 #undef PerlIO_printf
3613 PerlIO_printf(PerlIO *f,const char *fmt,...)
3618 result = PerlIO_vprintf(f,fmt,ap);
3623 #undef PerlIO_stdoutf
3625 PerlIO_stdoutf(const char *fmt,...)
3630 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3635 #undef PerlIO_tmpfile
3637 PerlIO_tmpfile(void)
3639 /* I have no idea how portable mkstemp() is ... */
3640 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3643 FILE *stdio = PerlSIO_tmpfile();
3646 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3652 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3653 int fd = mkstemp(SvPVX(sv));
3657 f = PerlIO_fdopen(fd,"w+");
3660 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3662 PerlLIO_unlink(SvPVX(sv));
3672 #endif /* USE_SFIO */
3673 #endif /* PERLIO_IS_STDIO */
3675 /*======================================================================================*/
3676 /* Now some functions in terms of above which may be needed even if
3677 we are not in true PerlIO mode
3681 #undef PerlIO_setpos
3683 PerlIO_setpos(PerlIO *f, SV *pos)
3689 Off_t *posn = (Off_t *) SvPV(pos,len);
3690 if (f && len == sizeof(Off_t))
3691 return PerlIO_seek(f,*posn,SEEK_SET);
3697 #undef PerlIO_setpos
3699 PerlIO_setpos(PerlIO *f, SV *pos)
3705 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3706 if (f && len == sizeof(Fpos_t))
3708 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3709 return fsetpos64(f, fpos);
3711 return fsetpos(f, fpos);
3721 #undef PerlIO_getpos
3723 PerlIO_getpos(PerlIO *f, SV *pos)
3726 Off_t posn = PerlIO_tell(f);
3727 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3728 return (posn == (Off_t)-1) ? -1 : 0;
3731 #undef PerlIO_getpos
3733 PerlIO_getpos(PerlIO *f, SV *pos)
3738 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3739 code = fgetpos64(f, &fpos);
3741 code = fgetpos(f, &fpos);
3743 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3748 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3751 vprintf(char *pat, char *args)
3753 _doprnt(pat, args, stdout);
3754 return 0; /* wrong, but perl doesn't use the return value */
3758 vfprintf(FILE *fd, char *pat, char *args)
3760 _doprnt(pat, args, fd);
3761 return 0; /* wrong, but perl doesn't use the return value */
3766 #ifndef PerlIO_vsprintf
3768 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3770 int val = vsprintf(s, fmt, ap);
3773 if (strlen(s) >= (STRLEN)n)
3776 (void)PerlIO_puts(Perl_error_log,
3777 "panic: sprintf overflow - memory corrupted!\n");
3785 #ifndef PerlIO_sprintf
3787 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3792 result = PerlIO_vsprintf(s, n, fmt, ap);