3 * Copyright (c) 1996-2001, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
37 perlsio_binmode(FILE *fp, int iotype, int mode)
39 /* This used to be contents of do_binmode in doio.c */
41 # if defined(atarist) || defined(__MINT__)
44 ((FILE*)fp)->_flag |= _IOBIN;
46 ((FILE*)fp)->_flag &= ~ _IOBIN;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
53 # if defined(WIN32) && defined(__BORLANDC__)
54 /* The translation mode of the stream is maintained independent
55 * of the translation mode of the fd in the Borland RTL (heavy
56 * digging through their runtime sources reveal). User has to
57 * set the mode explicitly for the stream (though they don't
58 * document this anywhere). GSAR 97-5-24
64 fp->flags &= ~ _F_BIN;
72 # if defined(USEMYBINMODE)
73 if (my_binmode(fp, iotype, mode) != FALSE)
85 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
87 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
91 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
102 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
105 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
109 char *name = SvPV_nolen(*args);
112 fd = PerlLIO_open3(name,imode,perm);
114 return PerlIO_fdopen(fd,mode+1);
118 return PerlIO_reopen(name,mode,old);
122 return PerlIO_open(name,mode);
127 return PerlIO_fdopen(fd,mode);
135 #ifdef PERLIO_IS_STDIO
140 /* Does nothing (yet) except force this file to be included
141 in perl binary. That allows this file to force inclusion
142 of other functions that may be required by loadable
143 extensions e.g. for FileHandle::tmpfile
147 #undef PerlIO_tmpfile
154 #else /* PERLIO_IS_STDIO */
161 /* This section is just to make sure these functions
162 get pulled in from libsfio.a
165 #undef PerlIO_tmpfile
175 /* Force this file to be included in perl binary. Which allows
176 * this file to force inclusion of other functions that may be
177 * required by loadable extensions e.g. for FileHandle::tmpfile
181 * sfio does its own 'autoflush' on stdout in common cases.
182 * Flush results in a lot of lseek()s to regular files and
183 * lot of small writes to pipes.
185 sfset(sfstdout,SF_SHARE,0);
189 /*======================================================================================*/
190 /* Implement all the PerlIO interface ourselves.
195 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
200 #include <sys/mman.h>
205 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
208 PerlIO_debug(const char *fmt,...)
216 char *s = PerlEnv_getenv("PERLIO_DEBUG");
218 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
225 SV *sv = newSVpvn("",0);
228 s = CopFILE(PL_curcop);
231 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
232 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
235 PerlLIO_write(dbg,s,len);
241 /*--------------------------------------------------------------------------------------*/
243 /* Inner level routines */
245 /* Table of pointers to the PerlIO structs (malloc'ed) */
246 PerlIO *_perlio = NULL;
247 #define PERLIO_TABLE_SIZE 64
250 PerlIO_allocate(pTHX)
252 /* Find a free slot in the table, allocating new table as necessary */
259 last = (PerlIO **)(f);
260 for (i=1; i < PERLIO_TABLE_SIZE; i++)
268 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
278 PerlIO_cleantable(pTHX_ PerlIO **tablep)
280 PerlIO *table = *tablep;
284 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
285 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
293 PerlMemShared_free(table);
305 PerlIO_cleantable(aTHX_ &_perlio);
309 PerlIO_pop(pTHX_ PerlIO *f)
314 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
316 (*l->tab->Popped)(f);
318 PerlMemShared_free(l);
322 /*--------------------------------------------------------------------------------------*/
323 /* XS Interface for perl code */
329 char *s = GvNAME(gv);
330 STRLEN l = GvNAMELEN(gv);
331 PerlIO_debug("%.*s\n",(int) l,s);
335 XS(XS_perlio_unimport)
339 char *s = GvNAME(gv);
340 STRLEN l = GvNAMELEN(gv);
341 PerlIO_debug("%.*s\n",(int) l,s);
346 PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
350 if ((SSize_t) len <= 0)
352 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
353 if (svp && (sv = *svp) && SvROK(sv))
360 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
364 IO *io = GvIOn((GV *)SvRV(sv));
365 PerlIO *ifp = IoIFP(io);
366 PerlIO *ofp = IoOFP(io);
367 AV *av = (AV *) mg->mg_obj;
368 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
374 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
378 IO *io = GvIOn((GV *)SvRV(sv));
379 PerlIO *ifp = IoIFP(io);
380 PerlIO *ofp = IoOFP(io);
381 AV *av = (AV *) mg->mg_obj;
382 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
388 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
390 Perl_warn(aTHX_ "clear %"SVf,sv);
395 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
397 Perl_warn(aTHX_ "free %"SVf,sv);
401 MGVTBL perlio_vtab = {
409 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
412 SV *sv = SvRV(ST(1));
417 sv_magic(sv, (SV *)av, '~', NULL, 0);
419 mg = mg_find(sv,'~');
420 mg->mg_virtual = &perlio_vtab;
422 Perl_warn(aTHX_ "attrib %"SVf,sv);
423 for (i=2; i < items; i++)
426 const char *name = SvPV(ST(i),len);
427 SV *layer = PerlIO_find_layer(aTHX_ name,len);
430 av_push(av,SvREFCNT_inc(layer));
443 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
445 HV *stash = gv_stashpv("perlio::Layer", TRUE);
446 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
447 if (!PerlIO_layer_hv)
449 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
451 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
452 PerlIO_debug("define %s %p\n",tab->name,tab);
456 PerlIO_default_buffer(pTHX)
458 PerlIO_funcs *tab = &PerlIO_perlio;
459 if (O_BINARY != O_TEXT)
465 if (PerlIO_stdio.Set_ptrcnt)
470 PerlIO_debug("Pushing %s\n",tab->name);
471 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
477 PerlIO_default_layer(pTHX_ I32 n)
481 PerlIO_funcs *tab = &PerlIO_stdio;
483 if (!PerlIO_layer_av)
485 const char *s = PerlEnv_getenv("PERLIO");
486 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
487 newXS("perlio::import",XS_perlio_import,__FILE__);
488 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
490 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
492 PerlIO_define_layer(aTHX_ &PerlIO_raw);
493 PerlIO_define_layer(aTHX_ &PerlIO_unix);
494 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
495 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
496 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
498 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
500 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
501 PerlIO_define_layer(aTHX_ &PerlIO_byte);
502 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
508 while (*s && isSPACE((unsigned char)*s))
514 while (*e && !isSPACE((unsigned char)*e))
518 layer = PerlIO_find_layer(aTHX_ s,e-s);
521 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
522 if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED))
525 PerlIO_default_buffer(aTHX);
527 PerlIO_debug("Pushing %.*s\n",(e-s),s);
528 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
529 buffered |= (tab->kind & PERLIO_K_BUFFERED);
532 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
538 len = av_len(PerlIO_layer_av);
541 PerlIO_default_buffer(aTHX);
542 len = av_len(PerlIO_layer_av);
546 svp = av_fetch(PerlIO_layer_av,n,0);
547 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
549 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
551 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
555 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
556 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
564 PerlIO_allocate(aTHX);
565 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
566 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
567 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
572 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
575 l = PerlMemShared_calloc(tab->size,sizeof(char));
578 Zero(l,tab->size,char);
582 PerlIO_debug("PerlIO_push f=%p %s %s '%.*s'\n",
583 f,tab->name,(mode) ? mode : "(Null)",(int) len,arg);
584 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
594 PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
608 PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
610 /* Remove the dummy layer */
613 /* Pop back to bottom layer */
618 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
626 /* Nothing bellow - push unix on top then remove it */
627 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg,len))
629 PerlIO_pop(aTHX_ PerlIONext(f));
634 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
641 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
645 const char *s = names;
648 while (isSPACE(*s) || *s == ':')
654 const char *as = Nullch;
658 /* Message is consistent with how attribute lists are passed.
659 Even though this means "foo : : bar" is seen as an invalid separator
661 char q = ((*s == '\'') ? '"' : '\'');
662 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
668 } while (isALNUM(*e));
686 /* It's a nul terminated string, not allowed to \ the terminating null.
687 Anything other character is passed over. */
695 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
705 SV *layer = PerlIO_find_layer(aTHX_ s,llen);
708 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
711 if (!PerlIO_push(aTHX_ f,tab,mode,as,alen))
716 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
729 /*--------------------------------------------------------------------------------------*/
730 /* Given the abstraction above the public API functions */
733 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
735 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
736 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
737 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
743 if (PerlIOBase(top)->tab == &PerlIO_crlf)
746 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
749 top = PerlIONext(top);
752 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
757 PerlIO__close(PerlIO *f)
759 return (*PerlIOBase(f)->tab->Close)(f);
762 #undef PerlIO_fdupopen
764 PerlIO_fdupopen(pTHX_ PerlIO *f)
767 int fd = PerlLIO_dup(PerlIO_fileno(f));
768 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
771 Off_t posn = PerlIO_tell(f);
772 PerlIO_seek(new,posn,SEEK_SET);
779 PerlIO_close(PerlIO *f)
782 int code = (*PerlIOBase(f)->tab->Close)(f);
792 PerlIO_fileno(PerlIO *f)
794 return (*PerlIOBase(f)->tab->Fileno)(f);
798 PerlIO_top_layer(pTHX_ const char *layers)
801 return PerlIO_default_top();
805 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
807 PerlIO_funcs *tab = (f && *f) ? PerlIOBase(f)->tab : PerlIO_top_layer(aTHX_ layers);
810 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
811 tab->name,layers,mode,fd,imode,perm,f,narg,args);
812 f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,f,narg,args);
815 if (layers && *layers)
816 PerlIO_apply_layers(aTHX_ f,mode,layers);
824 PerlIO_fdopen(int fd, const char *mode)
827 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
832 PerlIO_open(const char *path, const char *mode)
835 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
836 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
841 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
844 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
845 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
850 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
852 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
857 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
859 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
864 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
866 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
871 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
873 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
878 PerlIO_tell(PerlIO *f)
880 return (*PerlIOBase(f)->tab->Tell)(f);
885 PerlIO_flush(PerlIO *f)
889 PerlIO_funcs *tab = PerlIOBase(f)->tab;
890 if (tab && tab->Flush)
892 return (*tab->Flush)(f);
896 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
903 PerlIO **table = &_perlio;
908 table = (PerlIO **)(f++);
909 for (i=1; i < PERLIO_TABLE_SIZE; i++)
911 if (*f && PerlIO_flush(f) != 0)
922 PerlIO_fill(PerlIO *f)
924 return (*PerlIOBase(f)->tab->Fill)(f);
929 PerlIO_isutf8(PerlIO *f)
931 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
936 PerlIO_eof(PerlIO *f)
938 return (*PerlIOBase(f)->tab->Eof)(f);
943 PerlIO_error(PerlIO *f)
945 return (*PerlIOBase(f)->tab->Error)(f);
948 #undef PerlIO_clearerr
950 PerlIO_clearerr(PerlIO *f)
953 (*PerlIOBase(f)->tab->Clearerr)(f);
956 #undef PerlIO_setlinebuf
958 PerlIO_setlinebuf(PerlIO *f)
960 (*PerlIOBase(f)->tab->Setlinebuf)(f);
963 #undef PerlIO_has_base
965 PerlIO_has_base(PerlIO *f)
969 return (PerlIOBase(f)->tab->Get_base != NULL);
974 #undef PerlIO_fast_gets
976 PerlIO_fast_gets(PerlIO *f)
978 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
980 PerlIO_funcs *tab = PerlIOBase(f)->tab;
981 return (tab->Set_ptrcnt != NULL);
986 #undef PerlIO_has_cntptr
988 PerlIO_has_cntptr(PerlIO *f)
992 PerlIO_funcs *tab = PerlIOBase(f)->tab;
993 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
998 #undef PerlIO_canset_cnt
1000 PerlIO_canset_cnt(PerlIO *f)
1004 PerlIOl *l = PerlIOBase(f);
1005 return (l->tab->Set_ptrcnt != NULL);
1010 #undef PerlIO_get_base
1012 PerlIO_get_base(PerlIO *f)
1014 return (*PerlIOBase(f)->tab->Get_base)(f);
1017 #undef PerlIO_get_bufsiz
1019 PerlIO_get_bufsiz(PerlIO *f)
1021 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1024 #undef PerlIO_get_ptr
1026 PerlIO_get_ptr(PerlIO *f)
1028 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1029 if (tab->Get_ptr == NULL)
1031 return (*tab->Get_ptr)(f);
1034 #undef PerlIO_get_cnt
1036 PerlIO_get_cnt(PerlIO *f)
1038 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1039 if (tab->Get_cnt == NULL)
1041 return (*tab->Get_cnt)(f);
1044 #undef PerlIO_set_cnt
1046 PerlIO_set_cnt(PerlIO *f,int cnt)
1048 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1051 #undef PerlIO_set_ptrcnt
1053 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1055 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1056 if (tab->Set_ptrcnt == NULL)
1059 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1061 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1064 /*--------------------------------------------------------------------------------------*/
1065 /* utf8 and raw dummy layers */
1068 PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1073 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1074 PerlIO_pop(aTHX_ f);
1075 if (tab->kind & PERLIO_K_UTF8)
1076 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1078 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1085 PerlIOUtf8_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1087 PerlIO_funcs *tab = PerlIO_default_layer(aTHX_ -2);
1088 PerlIO *f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args);
1091 PerlIOl *l = PerlIOBase(f);
1092 if (tab->kind & PERLIO_K_UTF8)
1093 l->flags |= PERLIO_F_UTF8;
1095 l->flags &= ~PERLIO_F_UTF8;
1100 PerlIO_funcs PerlIO_utf8 = {
1103 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1120 NULL, /* get_base */
1121 NULL, /* get_bufsiz */
1124 NULL, /* set_ptrcnt */
1127 PerlIO_funcs PerlIO_byte = {
1147 NULL, /* get_base */
1148 NULL, /* get_bufsiz */
1151 NULL, /* set_ptrcnt */
1155 PerlIORaw_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1157 PerlIO_funcs *tab = PerlIO_default_btm();
1158 return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args);
1161 PerlIO_funcs PerlIO_raw = {
1181 NULL, /* get_base */
1182 NULL, /* get_bufsiz */
1185 NULL, /* set_ptrcnt */
1187 /*--------------------------------------------------------------------------------------*/
1188 /*--------------------------------------------------------------------------------------*/
1189 /* "Methods" of the "base class" */
1192 PerlIOBase_fileno(PerlIO *f)
1194 return PerlIO_fileno(PerlIONext(f));
1198 PerlIO_modestr(PerlIO *f,char *buf)
1201 IV flags = PerlIOBase(f)->flags;
1202 if (flags & PERLIO_F_APPEND)
1205 if (flags & PERLIO_F_CANREAD)
1210 else if (flags & PERLIO_F_CANREAD)
1213 if (flags & PERLIO_F_CANWRITE)
1216 else if (flags & PERLIO_F_CANWRITE)
1219 if (flags & PERLIO_F_CANREAD)
1224 #if O_TEXT != O_BINARY
1225 if (!(flags & PERLIO_F_CRLF))
1233 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1235 PerlIOl *l = PerlIOBase(f);
1236 const char *omode = mode;
1238 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1239 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1240 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1241 if (tab->Set_ptrcnt != NULL)
1242 l->flags |= PERLIO_F_FASTGETS;
1248 l->flags |= PERLIO_F_CANREAD;
1251 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1254 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1265 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1268 l->flags &= ~PERLIO_F_CRLF;
1271 l->flags |= PERLIO_F_CRLF;
1283 l->flags |= l->next->flags &
1284 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1288 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1289 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1290 l->flags,PerlIO_modestr(f,temp));
1296 PerlIOBase_popped(PerlIO *f)
1302 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1305 Off_t old = PerlIO_tell(f);
1307 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullch,0);
1308 done = PerlIOBuf_unread(f,vbuf,count);
1309 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1314 PerlIOBase_noop_ok(PerlIO *f)
1320 PerlIOBase_noop_fail(PerlIO *f)
1326 PerlIOBase_close(PerlIO *f)
1329 PerlIO *n = PerlIONext(f);
1330 if (PerlIO_flush(f) != 0)
1332 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1334 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1339 PerlIOBase_eof(PerlIO *f)
1343 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1349 PerlIOBase_error(PerlIO *f)
1353 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1359 PerlIOBase_clearerr(PerlIO *f)
1363 PerlIO *n = PerlIONext(f);
1364 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1371 PerlIOBase_setlinebuf(PerlIO *f)
1376 /*--------------------------------------------------------------------------------------*/
1377 /* Bottom-most level for UNIX-like case */
1381 struct _PerlIO base; /* The generic part */
1382 int fd; /* UNIX like file descriptor */
1383 int oflags; /* open/fcntl flags */
1387 PerlIOUnix_oflags(const char *mode)
1402 oflags = O_CREAT|O_TRUNC;
1413 oflags = O_CREAT|O_APPEND;
1429 else if (*mode == 't')
1432 oflags &= ~O_BINARY;
1435 /* Always open in binary mode */
1437 if (*mode || oflags == -1)
1446 PerlIOUnix_fileno(PerlIO *f)
1448 return PerlIOSelf(f,PerlIOUnix)->fd;
1452 PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1454 IV code = PerlIOBase_pushed(f,mode,arg,len);
1457 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1458 s->fd = PerlIO_fileno(PerlIONext(f));
1459 s->oflags = PerlIOUnix_oflags(mode);
1461 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1466 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1474 int oflags = PerlIOUnix_oflags(mode);
1477 PerlIOUnix *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,Nullch,0),PerlIOUnix);
1486 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1490 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1491 (*PerlIOBase(f)->tab->Close)(f);
1495 char *path = SvPV_nolen(*args);
1500 imode = PerlIOUnix_oflags(mode);
1505 fd = PerlLIO_open3(path,imode,perm);
1515 f = PerlIO_allocate(aTHX);
1516 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,Nullch,0),PerlIOUnix);
1519 s = PerlIOSelf(f,PerlIOUnix);
1522 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1529 /* FIXME: pop layers ??? */
1536 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1539 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1540 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1544 SSize_t len = PerlLIO_read(fd,vbuf,count);
1545 if (len >= 0 || errno != EINTR)
1548 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1549 else if (len == 0 && count != 0)
1550 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1558 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1561 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1564 SSize_t len = PerlLIO_write(fd,vbuf,count);
1565 if (len >= 0 || errno != EINTR)
1568 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1576 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1579 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1580 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1581 return (new == (Off_t) -1) ? -1 : 0;
1585 PerlIOUnix_tell(PerlIO *f)
1588 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1589 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1593 PerlIOUnix_close(PerlIO *f)
1596 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1598 while (PerlLIO_close(fd) != 0)
1609 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1614 PerlIO_funcs PerlIO_unix = {
1628 PerlIOBase_noop_ok, /* flush */
1629 PerlIOBase_noop_fail, /* fill */
1632 PerlIOBase_clearerr,
1633 PerlIOBase_setlinebuf,
1634 NULL, /* get_base */
1635 NULL, /* get_bufsiz */
1638 NULL, /* set_ptrcnt */
1641 /*--------------------------------------------------------------------------------------*/
1642 /* stdio as a layer */
1646 struct _PerlIO base;
1647 FILE * stdio; /* The stream */
1651 PerlIOStdio_fileno(PerlIO *f)
1654 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1658 PerlIOStdio_mode(const char *mode,char *tmode)
1665 if (O_BINARY != O_TEXT)
1674 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1682 /* This isn't used yet ... */
1684 PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1689 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1691 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1697 return PerlIOBase_pushed(f,mode,arg,len);
1700 #undef PerlIO_importFILE
1702 PerlIO_importFILE(FILE *stdio, int fl)
1708 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1715 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1720 char *path = SvPV_nolen(*args);
1721 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1722 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1732 char *path = SvPV_nolen(*args);
1736 fd = PerlLIO_open3(path,imode,perm);
1740 FILE *stdio = PerlSIO_fopen(path,mode);
1743 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1744 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1765 stdio = PerlSIO_stdin;
1768 stdio = PerlSIO_stdout;
1771 stdio = PerlSIO_stderr;
1777 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1781 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,Nullch,0),PerlIOStdio);
1791 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1794 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1798 STDCHAR *buf = (STDCHAR *) vbuf;
1799 /* Perl is expecting PerlIO_getc() to fill the buffer
1800 * Linux's stdio does not do that for fread()
1802 int ch = PerlSIO_fgetc(s);
1810 got = PerlSIO_fread(vbuf,1,count,s);
1815 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1818 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1819 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1823 int ch = *buf-- & 0xff;
1824 if (PerlSIO_ungetc(ch,s) != ch)
1833 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1836 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1840 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1843 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1844 return PerlSIO_fseek(stdio,offset,whence);
1848 PerlIOStdio_tell(PerlIO *f)
1851 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1852 return PerlSIO_ftell(stdio);
1856 PerlIOStdio_close(PerlIO *f)
1859 #ifdef HAS_SOCKS5_INIT
1860 int optval, optlen = sizeof(int);
1862 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1864 #ifdef HAS_SOCKS5_INIT
1865 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1866 PerlSIO_fclose(stdio) :
1867 close(PerlIO_fileno(f))
1869 PerlSIO_fclose(stdio)
1876 PerlIOStdio_flush(PerlIO *f)
1879 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1880 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1882 return PerlSIO_fflush(stdio);
1887 /* FIXME: This discards ungetc() and pre-read stuff which is
1888 not right if this is just a "sync" from a layer above
1889 Suspect right design is to do _this_ but not have layer above
1890 flush this layer read-to-read
1892 /* Not writeable - sync by attempting a seek */
1894 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1902 PerlIOStdio_fill(PerlIO *f)
1905 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1907 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1908 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1910 if (PerlSIO_fflush(stdio) != 0)
1913 c = PerlSIO_fgetc(stdio);
1914 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1920 PerlIOStdio_eof(PerlIO *f)
1923 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1927 PerlIOStdio_error(PerlIO *f)
1930 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1934 PerlIOStdio_clearerr(PerlIO *f)
1937 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1941 PerlIOStdio_setlinebuf(PerlIO *f)
1944 #ifdef HAS_SETLINEBUF
1945 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1947 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1953 PerlIOStdio_get_base(PerlIO *f)
1956 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1957 return PerlSIO_get_base(stdio);
1961 PerlIOStdio_get_bufsiz(PerlIO *f)
1964 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1965 return PerlSIO_get_bufsiz(stdio);
1969 #ifdef USE_STDIO_PTR
1971 PerlIOStdio_get_ptr(PerlIO *f)
1974 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1975 return PerlSIO_get_ptr(stdio);
1979 PerlIOStdio_get_cnt(PerlIO *f)
1982 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1983 return PerlSIO_get_cnt(stdio);
1987 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1990 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1993 #ifdef STDIO_PTR_LVALUE
1994 PerlSIO_set_ptr(stdio,ptr);
1995 #ifdef STDIO_PTR_LVAL_SETS_CNT
1996 if (PerlSIO_get_cnt(stdio) != (cnt))
1999 assert(PerlSIO_get_cnt(stdio) == (cnt));
2002 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2003 /* Setting ptr _does_ change cnt - we are done */
2006 #else /* STDIO_PTR_LVALUE */
2008 #endif /* STDIO_PTR_LVALUE */
2010 /* Now (or only) set cnt */
2011 #ifdef STDIO_CNT_LVALUE
2012 PerlSIO_set_cnt(stdio,cnt);
2013 #else /* STDIO_CNT_LVALUE */
2014 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2015 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2016 #else /* STDIO_PTR_LVAL_SETS_CNT */
2018 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2019 #endif /* STDIO_CNT_LVALUE */
2024 PerlIO_funcs PerlIO_stdio = {
2026 sizeof(PerlIOStdio),
2042 PerlIOStdio_clearerr,
2043 PerlIOStdio_setlinebuf,
2045 PerlIOStdio_get_base,
2046 PerlIOStdio_get_bufsiz,
2051 #ifdef USE_STDIO_PTR
2052 PerlIOStdio_get_ptr,
2053 PerlIOStdio_get_cnt,
2054 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2055 PerlIOStdio_set_ptrcnt
2056 #else /* STDIO_PTR_LVALUE */
2058 #endif /* STDIO_PTR_LVALUE */
2059 #else /* USE_STDIO_PTR */
2063 #endif /* USE_STDIO_PTR */
2066 #undef PerlIO_exportFILE
2068 PerlIO_exportFILE(PerlIO *f, int fl)
2072 stdio = fdopen(PerlIO_fileno(f),"r+");
2076 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
2082 #undef PerlIO_findFILE
2084 PerlIO_findFILE(PerlIO *f)
2089 if (l->tab == &PerlIO_stdio)
2091 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2094 l = *PerlIONext(&l);
2096 return PerlIO_exportFILE(f,0);
2099 #undef PerlIO_releaseFILE
2101 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2105 /*--------------------------------------------------------------------------------------*/
2106 /* perlio buffer layer */
2109 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
2111 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2112 int fd = PerlIO_fileno(f);
2114 if (fd >= 0 && PerlLIO_isatty(fd))
2116 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2118 posn = PerlIO_tell(PerlIONext(f));
2119 if (posn != (Off_t) -1)
2123 return PerlIOBase_pushed(f,mode,arg,len);
2127 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2131 PerlIO *next = PerlIONext(f);
2132 PerlIO_funcs *tab = PerlIOBase(next)->tab;
2133 next = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,next,narg,args);
2134 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) != 0)
2141 PerlIO_funcs *tab = PerlIO_default_btm();
2148 f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,NULL,narg,args);
2151 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,Nullch,0),PerlIOBuf);
2152 fd = PerlIO_fileno(f);
2153 #if O_BINARY != O_TEXT
2154 /* do something about failing setmode()? --jhi */
2155 PerlLIO_setmode(fd , O_BINARY);
2157 if (init && fd == 2)
2159 /* Initial stderr is unbuffered */
2160 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2167 /* This "flush" is akin to sfio's sync in that it handles files in either
2171 PerlIOBuf_flush(PerlIO *f)
2173 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2175 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2177 /* write() the buffer */
2178 STDCHAR *buf = b->buf;
2180 PerlIO *n = PerlIONext(f);
2183 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2188 else if (count < 0 || PerlIO_error(n))
2190 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2195 b->posn += (p - buf);
2197 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2199 STDCHAR *buf = PerlIO_get_base(f);
2200 /* Note position change */
2201 b->posn += (b->ptr - buf);
2202 if (b->ptr < b->end)
2204 /* We did not consume all of it */
2205 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2207 b->posn = PerlIO_tell(PerlIONext(f));
2211 b->ptr = b->end = b->buf;
2212 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2213 /* FIXME: Is this right for read case ? */
2214 if (PerlIO_flush(PerlIONext(f)) != 0)
2220 PerlIOBuf_fill(PerlIO *f)
2222 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2223 PerlIO *n = PerlIONext(f);
2225 /* FIXME: doing the down-stream flush is a bad idea if it causes
2226 pre-read data in stdio buffer to be discarded
2227 but this is too simplistic - as it skips _our_ hosekeeping
2228 and breaks tell tests.
2229 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2233 if (PerlIO_flush(f) != 0)
2237 PerlIO_get_base(f); /* allocate via vtable */
2239 b->ptr = b->end = b->buf;
2240 if (PerlIO_fast_gets(n))
2242 /* Layer below is also buffered
2243 * We do _NOT_ want to call its ->Read() because that will loop
2244 * till it gets what we asked for which may hang on a pipe etc.
2245 * Instead take anything it has to hand, or ask it to fill _once_.
2247 avail = PerlIO_get_cnt(n);
2250 avail = PerlIO_fill(n);
2252 avail = PerlIO_get_cnt(n);
2255 if (!PerlIO_error(n) && PerlIO_eof(n))
2261 STDCHAR *ptr = PerlIO_get_ptr(n);
2262 SSize_t cnt = avail;
2263 if (avail > b->bufsiz)
2265 Copy(ptr,b->buf,avail,STDCHAR);
2266 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2271 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2276 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2278 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2281 b->end = b->buf+avail;
2282 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2287 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2289 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2290 STDCHAR *buf = (STDCHAR *) vbuf;
2295 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2299 SSize_t avail = PerlIO_get_cnt(f);
2300 SSize_t take = (count < avail) ? count : avail;
2303 STDCHAR *ptr = PerlIO_get_ptr(f);
2304 Copy(ptr,buf,take,STDCHAR);
2305 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2309 if (count > 0 && avail <= 0)
2311 if (PerlIO_fill(f) != 0)
2315 return (buf - (STDCHAR *) vbuf);
2321 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2323 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2324 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2327 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2333 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2335 avail = (b->ptr - b->buf);
2340 b->end = b->buf + avail;
2342 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2343 b->posn -= b->bufsiz;
2345 if (avail > (SSize_t) count)
2353 Copy(buf,b->ptr,avail,STDCHAR);
2357 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2364 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2366 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2367 const STDCHAR *buf = (const STDCHAR *) vbuf;
2371 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2375 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2376 if ((SSize_t) count < avail)
2378 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2379 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2399 Copy(buf,b->ptr,avail,STDCHAR);
2406 if (b->ptr >= (b->buf + b->bufsiz))
2409 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2415 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2418 if ((code = PerlIO_flush(f)) == 0)
2420 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2421 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2422 code = PerlIO_seek(PerlIONext(f),offset,whence);
2425 b->posn = PerlIO_tell(PerlIONext(f));
2432 PerlIOBuf_tell(PerlIO *f)
2434 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2435 Off_t posn = b->posn;
2437 posn += (b->ptr - b->buf);
2442 PerlIOBuf_close(PerlIO *f)
2445 IV code = PerlIOBase_close(f);
2446 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2447 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2449 PerlMemShared_free(b->buf);
2452 b->ptr = b->end = b->buf;
2453 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2458 PerlIOBuf_setlinebuf(PerlIO *f)
2462 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2467 PerlIOBuf_get_ptr(PerlIO *f)
2469 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2476 PerlIOBuf_get_cnt(PerlIO *f)
2478 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2481 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2482 return (b->end - b->ptr);
2487 PerlIOBuf_get_base(PerlIO *f)
2489 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2495 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2498 b->buf = (STDCHAR *)&b->oneword;
2499 b->bufsiz = sizeof(b->oneword);
2508 PerlIOBuf_bufsiz(PerlIO *f)
2510 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2513 return (b->end - b->buf);
2517 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2519 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2523 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2526 assert(PerlIO_get_cnt(f) == cnt);
2527 assert(b->ptr >= b->buf);
2529 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2532 PerlIO_funcs PerlIO_perlio = {
2550 PerlIOBase_clearerr,
2551 PerlIOBuf_setlinebuf,
2556 PerlIOBuf_set_ptrcnt,
2559 /*--------------------------------------------------------------------------------------*/
2560 /* Temp layer to hold unread chars when cannot do it any other way */
2563 PerlIOPending_fill(PerlIO *f)
2565 /* Should never happen */
2571 PerlIOPending_close(PerlIO *f)
2573 /* A tad tricky - flush pops us, then we close new top */
2575 return PerlIO_close(f);
2579 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2581 /* A tad tricky - flush pops us, then we seek new top */
2583 return PerlIO_seek(f,offset,whence);
2588 PerlIOPending_flush(PerlIO *f)
2591 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2592 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2594 PerlMemShared_free(b->buf);
2597 PerlIO_pop(aTHX_ f);
2602 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2610 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2615 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2617 IV code = PerlIOBase_pushed(f,mode,arg,len);
2618 PerlIOl *l = PerlIOBase(f);
2619 /* Our PerlIO_fast_gets must match what we are pushed on,
2620 or sv_gets() etc. get muddled when it changes mid-string
2623 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2624 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2629 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2631 SSize_t avail = PerlIO_get_cnt(f);
2636 got = PerlIOBuf_read(f,vbuf,avail);
2637 if (got >= 0 && got < count)
2639 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2640 if (more >= 0 || got == 0)
2647 PerlIO_funcs PerlIO_pending = {
2653 PerlIOPending_pushed,
2660 PerlIOPending_close,
2661 PerlIOPending_flush,
2665 PerlIOBase_clearerr,
2666 PerlIOBuf_setlinebuf,
2671 PerlIOPending_set_ptrcnt,
2676 /*--------------------------------------------------------------------------------------*/
2677 /* crlf - translation
2678 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2679 to hand back a line at a time and keeping a record of which nl we "lied" about.
2680 On write translate "\n" to CR,LF
2685 PerlIOBuf base; /* PerlIOBuf stuff */
2686 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2690 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2693 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2694 code = PerlIOBuf_pushed(f,mode,arg,len);
2696 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2697 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2698 PerlIOBase(f)->flags);
2705 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2707 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2713 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2714 return PerlIOBuf_unread(f,vbuf,count);
2717 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2718 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2720 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2726 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2728 b->end = b->ptr = b->buf + b->bufsiz;
2729 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2730 b->posn -= b->bufsiz;
2732 while (count > 0 && b->ptr > b->buf)
2737 if (b->ptr - 2 >= b->buf)
2763 PerlIOCrlf_get_cnt(PerlIO *f)
2765 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2768 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2770 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2771 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2773 STDCHAR *nl = b->ptr;
2775 while (nl < b->end && *nl != 0xd)
2777 if (nl < b->end && *nl == 0xd)
2789 /* Not CR,LF but just CR */
2796 /* Blast - found CR as last char in buffer */
2799 /* They may not care, defer work as long as possible */
2800 return (nl - b->ptr);
2806 b->ptr++; /* say we have read it as far as flush() is concerned */
2807 b->buf++; /* Leave space an front of buffer */
2808 b->bufsiz--; /* Buffer is thus smaller */
2809 code = PerlIO_fill(f); /* Fetch some more */
2810 b->bufsiz++; /* Restore size for next time */
2811 b->buf--; /* Point at space */
2812 b->ptr = nl = b->buf; /* Which is what we hand off */
2813 b->posn--; /* Buffer starts here */
2814 *nl = 0xd; /* Fill in the CR */
2816 goto test; /* fill() call worked */
2817 /* CR at EOF - just fall through */
2822 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2828 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2830 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2831 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2832 IV flags = PerlIOBase(f)->flags;
2842 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2849 /* Test code - delete when it works ... */
2856 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2864 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2865 ptr, chk, flags, c->nl, b->end, cnt);
2872 /* They have taken what we lied about */
2879 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2883 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2885 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2886 return PerlIOBuf_write(f,vbuf,count);
2889 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2890 const STDCHAR *buf = (const STDCHAR *) vbuf;
2891 const STDCHAR *ebuf = buf+count;
2894 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2898 STDCHAR *eptr = b->buf+b->bufsiz;
2899 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2900 while (buf < ebuf && b->ptr < eptr)
2904 if ((b->ptr + 2) > eptr)
2906 /* Not room for both */
2912 *(b->ptr)++ = 0xd; /* CR */
2913 *(b->ptr)++ = 0xa; /* LF */
2915 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2934 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2936 return (buf - (STDCHAR *) vbuf);
2941 PerlIOCrlf_flush(PerlIO *f)
2943 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2949 return PerlIOBuf_flush(f);
2952 PerlIO_funcs PerlIO_crlf = {
2955 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2959 PerlIOBase_noop_ok, /* popped */
2960 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2961 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2962 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2970 PerlIOBase_clearerr,
2971 PerlIOBuf_setlinebuf,
2976 PerlIOCrlf_set_ptrcnt,
2980 /*--------------------------------------------------------------------------------------*/
2981 /* mmap as "buffer" layer */
2985 PerlIOBuf base; /* PerlIOBuf stuff */
2986 Mmap_t mptr; /* Mapped address */
2987 Size_t len; /* mapped length */
2988 STDCHAR *bbuf; /* malloced buffer if map fails */
2991 static size_t page_size = 0;
2994 PerlIOMmap_map(PerlIO *f)
2997 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2998 PerlIOBuf *b = &m->base;
2999 IV flags = PerlIOBase(f)->flags;
3003 if (flags & PERLIO_F_CANREAD)
3005 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3006 int fd = PerlIO_fileno(f);
3008 code = fstat(fd,&st);
3009 if (code == 0 && S_ISREG(st.st_mode))
3011 SSize_t len = st.st_size - b->posn;
3016 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3018 SETERRNO(0,SS$_NORMAL);
3019 # ifdef _SC_PAGESIZE
3020 page_size = sysconf(_SC_PAGESIZE);
3022 page_size = sysconf(_SC_PAGE_SIZE);
3024 if ((long)page_size < 0) {
3029 (void)SvUPGRADE(error, SVt_PV);
3030 msg = SvPVx(error, n_a);
3031 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3034 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3038 # ifdef HAS_GETPAGESIZE
3039 page_size = getpagesize();
3041 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3042 page_size = PAGESIZE; /* compiletime, bad */
3046 if ((IV)page_size <= 0)
3047 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3051 /* This is a hack - should never happen - open should have set it ! */
3052 b->posn = PerlIO_tell(PerlIONext(f));
3054 posn = (b->posn / page_size) * page_size;
3055 len = st.st_size - posn;
3056 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3057 if (m->mptr && m->mptr != (Mmap_t) -1)
3059 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3060 madvise(m->mptr, len, MADV_SEQUENTIAL);
3062 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3063 madvise(m->mptr, len, MADV_WILLNEED);
3065 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3066 b->end = ((STDCHAR *)m->mptr) + len;
3067 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3078 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3080 b->ptr = b->end = b->ptr;
3089 PerlIOMmap_unmap(PerlIO *f)
3091 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3092 PerlIOBuf *b = &m->base;
3098 code = munmap(m->mptr, m->len);
3102 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3105 b->ptr = b->end = b->buf;
3106 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3112 PerlIOMmap_get_base(PerlIO *f)
3114 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3115 PerlIOBuf *b = &m->base;
3116 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3118 /* Already have a readbuffer in progress */
3123 /* We have a write buffer or flushed PerlIOBuf read buffer */
3124 m->bbuf = b->buf; /* save it in case we need it again */
3125 b->buf = NULL; /* Clear to trigger below */
3129 PerlIOMmap_map(f); /* Try and map it */
3132 /* Map did not work - recover PerlIOBuf buffer if we have one */
3136 b->ptr = b->end = b->buf;
3139 return PerlIOBuf_get_base(f);
3143 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3145 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3146 PerlIOBuf *b = &m->base;
3147 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3149 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3152 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3157 /* Loose the unwritable mapped buffer */
3159 /* If flush took the "buffer" see if we have one from before */
3160 if (!b->buf && m->bbuf)
3164 PerlIOBuf_get_base(f);
3168 return PerlIOBuf_unread(f,vbuf,count);
3172 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3174 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3175 PerlIOBuf *b = &m->base;
3176 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3178 /* No, or wrong sort of, buffer */
3181 if (PerlIOMmap_unmap(f) != 0)
3184 /* If unmap took the "buffer" see if we have one from before */
3185 if (!b->buf && m->bbuf)
3189 PerlIOBuf_get_base(f);
3193 return PerlIOBuf_write(f,vbuf,count);
3197 PerlIOMmap_flush(PerlIO *f)
3199 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3200 PerlIOBuf *b = &m->base;
3201 IV code = PerlIOBuf_flush(f);
3202 /* Now we are "synced" at PerlIOBuf level */
3207 /* Unmap the buffer */
3208 if (PerlIOMmap_unmap(f) != 0)
3213 /* We seem to have a PerlIOBuf buffer which was not mapped
3214 * remember it in case we need one later
3223 PerlIOMmap_fill(PerlIO *f)
3225 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3226 IV code = PerlIO_flush(f);
3227 if (code == 0 && !b->buf)
3229 code = PerlIOMmap_map(f);
3231 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3233 code = PerlIOBuf_fill(f);
3239 PerlIOMmap_close(PerlIO *f)
3241 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3242 PerlIOBuf *b = &m->base;
3243 IV code = PerlIO_flush(f);
3248 b->ptr = b->end = b->buf;
3250 if (PerlIOBuf_close(f) != 0)
3256 PerlIO_funcs PerlIO_mmap = {
3274 PerlIOBase_clearerr,
3275 PerlIOBuf_setlinebuf,
3276 PerlIOMmap_get_base,
3280 PerlIOBuf_set_ptrcnt,
3283 #endif /* HAS_MMAP */
3291 atexit(&PerlIO_cleanup);
3303 PerlIO_stdstreams();
3307 #undef PerlIO_stdout
3312 PerlIO_stdstreams();
3316 #undef PerlIO_stderr
3321 PerlIO_stdstreams();
3325 /*--------------------------------------------------------------------------------------*/
3327 #undef PerlIO_getname
3329 PerlIO_getname(PerlIO *f, char *buf)
3332 Perl_croak(aTHX_ "Don't know how to get file name");
3337 /*--------------------------------------------------------------------------------------*/
3338 /* Functions which can be called on any kind of PerlIO implemented
3344 PerlIO_getc(PerlIO *f)
3347 SSize_t count = PerlIO_read(f,buf,1);
3350 return (unsigned char) buf[0];
3355 #undef PerlIO_ungetc
3357 PerlIO_ungetc(PerlIO *f, int ch)
3362 if (PerlIO_unread(f,&buf,1) == 1)
3370 PerlIO_putc(PerlIO *f, int ch)
3373 return PerlIO_write(f,&buf,1);
3378 PerlIO_puts(PerlIO *f, const char *s)
3380 STRLEN len = strlen(s);
3381 return PerlIO_write(f,s,len);
3384 #undef PerlIO_rewind
3386 PerlIO_rewind(PerlIO *f)
3388 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3392 #undef PerlIO_vprintf
3394 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3397 SV *sv = newSVpvn("",0);
3403 Perl_va_copy(ap, apc);
3404 sv_vcatpvf(sv, fmt, &apc);
3406 sv_vcatpvf(sv, fmt, &ap);
3409 wrote = PerlIO_write(f,s,len);
3414 #undef PerlIO_printf
3416 PerlIO_printf(PerlIO *f,const char *fmt,...)
3421 result = PerlIO_vprintf(f,fmt,ap);
3426 #undef PerlIO_stdoutf
3428 PerlIO_stdoutf(const char *fmt,...)
3433 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3438 #undef PerlIO_tmpfile
3440 PerlIO_tmpfile(void)
3442 /* I have no idea how portable mkstemp() is ... */
3443 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3446 FILE *stdio = PerlSIO_tmpfile();
3449 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3455 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3456 int fd = mkstemp(SvPVX(sv));
3460 f = PerlIO_fdopen(fd,"w+");
3463 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3465 PerlLIO_unlink(SvPVX(sv));
3475 #endif /* USE_SFIO */
3476 #endif /* PERLIO_IS_STDIO */
3478 /*======================================================================================*/
3479 /* Now some functions in terms of above which may be needed even if
3480 we are not in true PerlIO mode
3484 #undef PerlIO_setpos
3486 PerlIO_setpos(PerlIO *f, SV *pos)
3492 Off_t *posn = (Off_t *) SvPV(pos,len);
3493 if (f && len == sizeof(Off_t))
3494 return PerlIO_seek(f,*posn,SEEK_SET);
3500 #undef PerlIO_setpos
3502 PerlIO_setpos(PerlIO *f, SV *pos)
3508 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3509 if (f && len == sizeof(Fpos_t))
3511 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3512 return fsetpos64(f, fpos);
3514 return fsetpos(f, fpos);
3524 #undef PerlIO_getpos
3526 PerlIO_getpos(PerlIO *f, SV *pos)
3529 Off_t posn = PerlIO_tell(f);
3530 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3531 return (posn == (Off_t)-1) ? -1 : 0;
3534 #undef PerlIO_getpos
3536 PerlIO_getpos(PerlIO *f, SV *pos)
3541 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3542 code = fgetpos64(f, &fpos);
3544 code = fgetpos(f, &fpos);
3546 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3551 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3554 vprintf(char *pat, char *args)
3556 _doprnt(pat, args, stdout);
3557 return 0; /* wrong, but perl doesn't use the return value */
3561 vfprintf(FILE *fd, char *pat, char *args)
3563 _doprnt(pat, args, fd);
3564 return 0; /* wrong, but perl doesn't use the return value */
3569 #ifndef PerlIO_vsprintf
3571 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3573 int val = vsprintf(s, fmt, ap);
3576 if (strlen(s) >= (STRLEN)n)
3579 (void)PerlIO_puts(Perl_error_log,
3580 "panic: sprintf overflow - memory corrupted!\n");
3588 #ifndef PerlIO_sprintf
3590 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3595 result = PerlIO_vsprintf(s, n, fmt, ap);