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
252 PerlIO_allocate(pTHX)
254 /* Find a free slot in the table, allocating new table as necessary */
261 last = (PerlIO **)(f);
262 for (i=1; i < PERLIO_TABLE_SIZE; i++)
270 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
280 PerlIO_cleantable(pTHX_ PerlIO **tablep)
282 PerlIO *table = *tablep;
286 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
287 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
295 PerlMemShared_free(table);
307 PerlIO_cleantable(aTHX_ &_perlio);
311 PerlIO_pop(pTHX_ PerlIO *f)
316 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
318 (*l->tab->Popped)(f);
320 PerlMemShared_free(l);
324 /*--------------------------------------------------------------------------------------*/
325 /* XS Interface for perl code */
331 char *s = GvNAME(gv);
332 STRLEN l = GvNAMELEN(gv);
333 PerlIO_debug("%.*s\n",(int) l,s);
337 XS(XS_perlio_unimport)
341 char *s = GvNAME(gv);
342 STRLEN l = GvNAMELEN(gv);
343 PerlIO_debug("%.*s\n",(int) l,s);
348 PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
352 if ((SSize_t) len <= 0)
354 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
355 if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
357 SV *pkgsv = newSVpvn("PerlIO",6);
358 SV *layer = newSVpvn(name,len);
360 /* The two SVs are magically freed by load_module */
361 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
363 /* Say this is lvalue so we get an 'undef' if still not there */
364 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
366 if (svp && (sv = *svp))
376 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
380 IO *io = GvIOn((GV *)SvRV(sv));
381 PerlIO *ifp = IoIFP(io);
382 PerlIO *ofp = IoOFP(io);
383 AV *av = (AV *) mg->mg_obj;
384 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
390 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
394 IO *io = GvIOn((GV *)SvRV(sv));
395 PerlIO *ifp = IoIFP(io);
396 PerlIO *ofp = IoOFP(io);
397 AV *av = (AV *) mg->mg_obj;
398 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
404 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
406 Perl_warn(aTHX_ "clear %"SVf,sv);
411 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
413 Perl_warn(aTHX_ "free %"SVf,sv);
417 MGVTBL perlio_vtab = {
425 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
428 SV *sv = SvRV(ST(1));
433 sv_magic(sv, (SV *)av, '~', NULL, 0);
435 mg = mg_find(sv,'~');
436 mg->mg_virtual = &perlio_vtab;
438 Perl_warn(aTHX_ "attrib %"SVf,sv);
439 for (i=2; i < items; i++)
442 const char *name = SvPV(ST(i),len);
443 SV *layer = PerlIO_find_layer(aTHX_ name,len);
446 av_push(av,SvREFCNT_inc(layer));
459 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
461 HV *stash = gv_stashpv("perlio::Layer", TRUE);
462 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
467 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
469 if (!PerlIO_layer_hv)
471 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
473 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
474 PerlIO_debug("define %s %p\n",tab->name,tab);
478 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
482 const char *s = names;
485 while (isSPACE(*s) || *s == ':')
491 const char *as = Nullch;
495 /* Message is consistent with how attribute lists are passed.
496 Even though this means "foo : : bar" is seen as an invalid separator
498 char q = ((*s == '\'') ? '"' : '\'');
499 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
505 } while (isALNUM(*e));
523 /* It's a nul terminated string, not allowed to \ the terminating null.
524 Anything other character is passed over. */
532 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
542 SV *layer = PerlIO_find_layer(aTHX_ s,llen);
545 av_push(av,SvREFCNT_inc(layer));
546 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
549 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
561 PerlIO_default_buffer(pTHX_ AV *av)
563 PerlIO_funcs *tab = &PerlIO_perlio;
564 if (O_BINARY != O_TEXT)
570 if (PerlIO_stdio.Set_ptrcnt)
575 PerlIO_debug("Pushing %s\n",tab->name);
576 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
577 av_push(av,&PL_sv_undef);
581 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
583 SV **svp = av_fetch(av,n,FALSE);
584 return (svp) ? *svp : Nullsv;
587 #define MYARG PerlIO_arg_fetch(aTHX_ layers,n+1)
591 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
593 SV **svp = av_fetch(av,n,FALSE);
595 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
597 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
598 return INT2PTR(PerlIO_funcs *, SvIV(layer));
601 Perl_croak(aTHX_ "panic:layer array corrupt");
606 PerlIO_default_layers(pTHX)
609 if (!PerlIO_layer_av)
611 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
612 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
613 newXS("perlio::import",XS_perlio_import,__FILE__);
614 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
616 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
618 PerlIO_define_layer(aTHX_ &PerlIO_raw);
619 PerlIO_define_layer(aTHX_ &PerlIO_unix);
620 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
621 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
622 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
624 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
626 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
627 PerlIO_define_layer(aTHX_ &PerlIO_byte);
628 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
629 av_push(PerlIO_layer_av,&PL_sv_undef);
632 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
636 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
639 len = av_len(PerlIO_layer_av)+1;
642 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
643 len = av_len(PerlIO_layer_av);
645 return PerlIO_layer_av;
650 PerlIO_default_layer(pTHX_ I32 n)
652 AV *av = PerlIO_default_layers(aTHX);
655 n += av_len(PerlIO_layer_av)+1;
656 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
659 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
660 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
663 PerlIO_stdstreams(pTHX)
667 PerlIO_allocate(aTHX);
668 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
669 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
670 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
675 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
678 l = PerlMemShared_calloc(tab->size,sizeof(char));
681 Zero(l,tab->size,char);
685 PerlIO_debug("PerlIO_push f=%p %s %s '%s'\n",f,tab->name,
686 (mode) ? mode : "(Null)",(arg) ? SvPV_nolen(arg) : "(Null)");
687 if ((*l->tab->Pushed)(f,mode,arg) != 0)
697 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
711 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
713 /* Remove the dummy layer */
716 /* Pop back to bottom layer */
721 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
729 /* Nothing bellow - push unix on top then remove it */
730 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
732 PerlIO_pop(aTHX_ PerlIONext(f));
737 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
744 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
746 IV max = av_len(layers)+1;
750 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
753 if (!PerlIO_push(aTHX_ f,tab,mode,MYARG))
765 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
770 AV *layers = newAV();
771 code = PerlIO_parse_layers(aTHX_ layers,names);
774 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
776 SvREFCNT_dec((SV *) layers);
782 /*--------------------------------------------------------------------------------------*/
783 /* Given the abstraction above the public API functions */
786 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
788 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
789 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
790 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
796 if (PerlIOBase(top)->tab == &PerlIO_crlf)
799 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
802 top = PerlIONext(top);
805 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
810 PerlIO__close(PerlIO *f)
812 return (*PerlIOBase(f)->tab->Close)(f);
815 #undef PerlIO_fdupopen
817 PerlIO_fdupopen(pTHX_ PerlIO *f)
820 int fd = PerlLIO_dup(PerlIO_fileno(f));
821 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
824 Off_t posn = PerlIO_tell(f);
825 PerlIO_seek(new,posn,SEEK_SET);
832 PerlIO_close(PerlIO *f)
835 int code = (*PerlIOBase(f)->tab->Close)(f);
845 PerlIO_fileno(PerlIO *f)
847 return (*PerlIOBase(f)->tab->Fileno)(f);
851 PerlIO_context_layers(pTHX_ const char *mode)
853 const char *type = NULL;
854 /* Need to supply default layer info from open.pm */
857 SV *layers = PL_curcop->cop_io;
861 type = SvPV(layers,len);
862 if (type && mode[0] != 'r')
864 /* Skip to write part */
865 const char *s = strchr(type,0);
866 if (s && (s-type) < len)
877 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
879 AV *def = PerlIO_default_layers(aTHX);
881 PerlIO_stdstreams(aTHX);
884 layers = PerlIO_context_layers(aTHX_ mode);
885 if (layers && *layers)
888 IV n = av_len(def)+1;
891 SV **svp = av_fetch(def,n,0);
892 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
894 PerlIO_parse_layers(aTHX_ av,layers);
905 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
916 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
917 av_unshift(layera,2);
918 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
919 av_store(layera,1,arg);
925 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
927 n = av_len(layera)-1;
930 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
940 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
941 tab->name,layers,mode,fd,imode,perm,f,narg,args);
942 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
945 if (n+2 < av_len(layera)+1)
947 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
954 SvREFCNT_dec(layera);
961 PerlIO_fdopen(int fd, const char *mode)
964 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
969 PerlIO_open(const char *path, const char *mode)
972 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
973 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
978 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
981 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
982 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
987 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
989 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
994 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
996 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1001 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1003 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1008 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1010 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1015 PerlIO_tell(PerlIO *f)
1017 return (*PerlIOBase(f)->tab->Tell)(f);
1022 PerlIO_flush(PerlIO *f)
1026 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1027 if (tab && tab->Flush)
1029 return (*tab->Flush)(f);
1033 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1040 PerlIO **table = &_perlio;
1042 while ((f = *table))
1045 table = (PerlIO **)(f++);
1046 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1048 if (*f && PerlIO_flush(f) != 0)
1059 PerlIO_fill(PerlIO *f)
1061 return (*PerlIOBase(f)->tab->Fill)(f);
1064 #undef PerlIO_isutf8
1066 PerlIO_isutf8(PerlIO *f)
1068 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1073 PerlIO_eof(PerlIO *f)
1075 return (*PerlIOBase(f)->tab->Eof)(f);
1080 PerlIO_error(PerlIO *f)
1082 return (*PerlIOBase(f)->tab->Error)(f);
1085 #undef PerlIO_clearerr
1087 PerlIO_clearerr(PerlIO *f)
1090 (*PerlIOBase(f)->tab->Clearerr)(f);
1093 #undef PerlIO_setlinebuf
1095 PerlIO_setlinebuf(PerlIO *f)
1097 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1100 #undef PerlIO_has_base
1102 PerlIO_has_base(PerlIO *f)
1106 return (PerlIOBase(f)->tab->Get_base != NULL);
1111 #undef PerlIO_fast_gets
1113 PerlIO_fast_gets(PerlIO *f)
1115 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1117 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1118 return (tab->Set_ptrcnt != NULL);
1123 #undef PerlIO_has_cntptr
1125 PerlIO_has_cntptr(PerlIO *f)
1129 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1130 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1135 #undef PerlIO_canset_cnt
1137 PerlIO_canset_cnt(PerlIO *f)
1141 PerlIOl *l = PerlIOBase(f);
1142 return (l->tab->Set_ptrcnt != NULL);
1147 #undef PerlIO_get_base
1149 PerlIO_get_base(PerlIO *f)
1151 return (*PerlIOBase(f)->tab->Get_base)(f);
1154 #undef PerlIO_get_bufsiz
1156 PerlIO_get_bufsiz(PerlIO *f)
1158 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1161 #undef PerlIO_get_ptr
1163 PerlIO_get_ptr(PerlIO *f)
1165 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1166 if (tab->Get_ptr == NULL)
1168 return (*tab->Get_ptr)(f);
1171 #undef PerlIO_get_cnt
1173 PerlIO_get_cnt(PerlIO *f)
1175 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1176 if (tab->Get_cnt == NULL)
1178 return (*tab->Get_cnt)(f);
1181 #undef PerlIO_set_cnt
1183 PerlIO_set_cnt(PerlIO *f,int cnt)
1185 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1188 #undef PerlIO_set_ptrcnt
1190 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1192 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1193 if (tab->Set_ptrcnt == NULL)
1196 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1198 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1201 /*--------------------------------------------------------------------------------------*/
1202 /* utf8 and raw dummy layers */
1205 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1210 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1211 PerlIO_pop(aTHX_ f);
1212 if (tab->kind & PERLIO_K_UTF8)
1213 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1215 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1221 PerlIO_funcs PerlIO_utf8 = {
1224 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1242 NULL, /* get_base */
1243 NULL, /* get_bufsiz */
1246 NULL, /* set_ptrcnt */
1249 PerlIO_funcs PerlIO_byte = {
1270 NULL, /* get_base */
1271 NULL, /* get_bufsiz */
1274 NULL, /* set_ptrcnt */
1278 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)
1280 PerlIO_funcs *tab = PerlIO_default_btm();
1281 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1284 PerlIO_funcs PerlIO_raw = {
1305 NULL, /* get_base */
1306 NULL, /* get_bufsiz */
1309 NULL, /* set_ptrcnt */
1311 /*--------------------------------------------------------------------------------------*/
1312 /*--------------------------------------------------------------------------------------*/
1313 /* "Methods" of the "base class" */
1316 PerlIOBase_fileno(PerlIO *f)
1318 return PerlIO_fileno(PerlIONext(f));
1322 PerlIO_modestr(PerlIO *f,char *buf)
1325 IV flags = PerlIOBase(f)->flags;
1326 if (flags & PERLIO_F_APPEND)
1329 if (flags & PERLIO_F_CANREAD)
1334 else if (flags & PERLIO_F_CANREAD)
1337 if (flags & PERLIO_F_CANWRITE)
1340 else if (flags & PERLIO_F_CANWRITE)
1343 if (flags & PERLIO_F_CANREAD)
1348 #if O_TEXT != O_BINARY
1349 if (!(flags & PERLIO_F_CRLF))
1357 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1359 PerlIOl *l = PerlIOBase(f);
1360 const char *omode = mode;
1362 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1363 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1364 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1365 if (tab->Set_ptrcnt != NULL)
1366 l->flags |= PERLIO_F_FASTGETS;
1372 l->flags |= PERLIO_F_CANREAD;
1375 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1378 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1389 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1392 l->flags &= ~PERLIO_F_CRLF;
1395 l->flags |= PERLIO_F_CRLF;
1407 l->flags |= l->next->flags &
1408 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1412 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1413 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1414 l->flags,PerlIO_modestr(f,temp));
1420 PerlIOBase_popped(PerlIO *f)
1426 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1429 Off_t old = PerlIO_tell(f);
1431 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1432 done = PerlIOBuf_unread(f,vbuf,count);
1433 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1438 PerlIOBase_noop_ok(PerlIO *f)
1444 PerlIOBase_noop_fail(PerlIO *f)
1450 PerlIOBase_close(PerlIO *f)
1453 PerlIO *n = PerlIONext(f);
1454 if (PerlIO_flush(f) != 0)
1456 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1458 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1463 PerlIOBase_eof(PerlIO *f)
1467 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1473 PerlIOBase_error(PerlIO *f)
1477 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1483 PerlIOBase_clearerr(PerlIO *f)
1487 PerlIO *n = PerlIONext(f);
1488 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1495 PerlIOBase_setlinebuf(PerlIO *f)
1500 /*--------------------------------------------------------------------------------------*/
1501 /* Bottom-most level for UNIX-like case */
1505 struct _PerlIO base; /* The generic part */
1506 int fd; /* UNIX like file descriptor */
1507 int oflags; /* open/fcntl flags */
1511 PerlIOUnix_oflags(const char *mode)
1526 oflags = O_CREAT|O_TRUNC;
1537 oflags = O_CREAT|O_APPEND;
1553 else if (*mode == 't')
1556 oflags &= ~O_BINARY;
1559 /* Always open in binary mode */
1561 if (*mode || oflags == -1)
1570 PerlIOUnix_fileno(PerlIO *f)
1572 return PerlIOSelf(f,PerlIOUnix)->fd;
1576 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1578 IV code = PerlIOBase_pushed(f,mode,arg);
1581 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1582 s->fd = PerlIO_fileno(PerlIONext(f));
1583 s->oflags = PerlIOUnix_oflags(mode);
1585 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1590 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)
1594 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1595 (*PerlIOBase(f)->tab->Close)(f);
1599 char *path = SvPV_nolen(*args);
1604 imode = PerlIOUnix_oflags(mode);
1609 fd = PerlLIO_open3(path,imode,perm);
1619 f = PerlIO_allocate(aTHX);
1620 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,MYARG),PerlIOUnix);
1623 s = PerlIOSelf(f,PerlIOUnix);
1626 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1633 /* FIXME: pop layers ??? */
1640 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1643 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1644 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1648 SSize_t len = PerlLIO_read(fd,vbuf,count);
1649 if (len >= 0 || errno != EINTR)
1652 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1653 else if (len == 0 && count != 0)
1654 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1662 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1665 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1668 SSize_t len = PerlLIO_write(fd,vbuf,count);
1669 if (len >= 0 || errno != EINTR)
1672 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1680 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1683 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1684 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1685 return (new == (Off_t) -1) ? -1 : 0;
1689 PerlIOUnix_tell(PerlIO *f)
1692 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1693 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1697 PerlIOUnix_close(PerlIO *f)
1700 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1702 while (PerlLIO_close(fd) != 0)
1713 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1718 PerlIO_funcs PerlIO_unix = {
1733 PerlIOBase_noop_ok, /* flush */
1734 PerlIOBase_noop_fail, /* fill */
1737 PerlIOBase_clearerr,
1738 PerlIOBase_setlinebuf,
1739 NULL, /* get_base */
1740 NULL, /* get_bufsiz */
1743 NULL, /* set_ptrcnt */
1746 /*--------------------------------------------------------------------------------------*/
1747 /* stdio as a layer */
1751 struct _PerlIO base;
1752 FILE * stdio; /* The stream */
1756 PerlIOStdio_fileno(PerlIO *f)
1759 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1763 PerlIOStdio_mode(const char *mode,char *tmode)
1770 if (O_BINARY != O_TEXT)
1778 /* This isn't used yet ... */
1780 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1785 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1787 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1793 return PerlIOBase_pushed(f,mode,arg);
1796 #undef PerlIO_importFILE
1798 PerlIO_importFILE(FILE *stdio, int fl)
1804 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1811 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)
1816 char *path = SvPV_nolen(*args);
1817 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1818 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1828 char *path = SvPV_nolen(*args);
1832 fd = PerlLIO_open3(path,imode,perm);
1836 FILE *stdio = PerlSIO_fopen(path,mode);
1839 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1840 (mode = PerlIOStdio_mode(mode,tmode)),MYARG),
1861 stdio = PerlSIO_stdin;
1864 stdio = PerlSIO_stdout;
1867 stdio = PerlSIO_stderr;
1873 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1877 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,MYARG),PerlIOStdio);
1887 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1890 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1894 STDCHAR *buf = (STDCHAR *) vbuf;
1895 /* Perl is expecting PerlIO_getc() to fill the buffer
1896 * Linux's stdio does not do that for fread()
1898 int ch = PerlSIO_fgetc(s);
1906 got = PerlSIO_fread(vbuf,1,count,s);
1911 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1914 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1915 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1919 int ch = *buf-- & 0xff;
1920 if (PerlSIO_ungetc(ch,s) != ch)
1929 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1932 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1936 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1939 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1940 return PerlSIO_fseek(stdio,offset,whence);
1944 PerlIOStdio_tell(PerlIO *f)
1947 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1948 return PerlSIO_ftell(stdio);
1952 PerlIOStdio_close(PerlIO *f)
1955 #ifdef HAS_SOCKS5_INIT
1956 int optval, optlen = sizeof(int);
1958 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1960 #ifdef HAS_SOCKS5_INIT
1961 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1962 PerlSIO_fclose(stdio) :
1963 close(PerlIO_fileno(f))
1965 PerlSIO_fclose(stdio)
1972 PerlIOStdio_flush(PerlIO *f)
1975 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1976 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1978 return PerlSIO_fflush(stdio);
1983 /* FIXME: This discards ungetc() and pre-read stuff which is
1984 not right if this is just a "sync" from a layer above
1985 Suspect right design is to do _this_ but not have layer above
1986 flush this layer read-to-read
1988 /* Not writeable - sync by attempting a seek */
1990 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1998 PerlIOStdio_fill(PerlIO *f)
2001 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2003 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2004 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2006 if (PerlSIO_fflush(stdio) != 0)
2009 c = PerlSIO_fgetc(stdio);
2010 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2016 PerlIOStdio_eof(PerlIO *f)
2019 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2023 PerlIOStdio_error(PerlIO *f)
2026 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2030 PerlIOStdio_clearerr(PerlIO *f)
2033 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2037 PerlIOStdio_setlinebuf(PerlIO *f)
2040 #ifdef HAS_SETLINEBUF
2041 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2043 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2049 PerlIOStdio_get_base(PerlIO *f)
2052 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2053 return PerlSIO_get_base(stdio);
2057 PerlIOStdio_get_bufsiz(PerlIO *f)
2060 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2061 return PerlSIO_get_bufsiz(stdio);
2065 #ifdef USE_STDIO_PTR
2067 PerlIOStdio_get_ptr(PerlIO *f)
2070 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2071 return PerlSIO_get_ptr(stdio);
2075 PerlIOStdio_get_cnt(PerlIO *f)
2078 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2079 return PerlSIO_get_cnt(stdio);
2083 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2086 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2089 #ifdef STDIO_PTR_LVALUE
2090 PerlSIO_set_ptr(stdio,ptr);
2091 #ifdef STDIO_PTR_LVAL_SETS_CNT
2092 if (PerlSIO_get_cnt(stdio) != (cnt))
2095 assert(PerlSIO_get_cnt(stdio) == (cnt));
2098 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2099 /* Setting ptr _does_ change cnt - we are done */
2102 #else /* STDIO_PTR_LVALUE */
2104 #endif /* STDIO_PTR_LVALUE */
2106 /* Now (or only) set cnt */
2107 #ifdef STDIO_CNT_LVALUE
2108 PerlSIO_set_cnt(stdio,cnt);
2109 #else /* STDIO_CNT_LVALUE */
2110 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2111 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2112 #else /* STDIO_PTR_LVAL_SETS_CNT */
2114 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2115 #endif /* STDIO_CNT_LVALUE */
2120 PerlIO_funcs PerlIO_stdio = {
2122 sizeof(PerlIOStdio),
2139 PerlIOStdio_clearerr,
2140 PerlIOStdio_setlinebuf,
2142 PerlIOStdio_get_base,
2143 PerlIOStdio_get_bufsiz,
2148 #ifdef USE_STDIO_PTR
2149 PerlIOStdio_get_ptr,
2150 PerlIOStdio_get_cnt,
2151 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2152 PerlIOStdio_set_ptrcnt
2153 #else /* STDIO_PTR_LVALUE */
2155 #endif /* STDIO_PTR_LVALUE */
2156 #else /* USE_STDIO_PTR */
2160 #endif /* USE_STDIO_PTR */
2163 #undef PerlIO_exportFILE
2165 PerlIO_exportFILE(PerlIO *f, int fl)
2169 stdio = fdopen(PerlIO_fileno(f),"r+");
2173 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2179 #undef PerlIO_findFILE
2181 PerlIO_findFILE(PerlIO *f)
2186 if (l->tab == &PerlIO_stdio)
2188 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2191 l = *PerlIONext(&l);
2193 return PerlIO_exportFILE(f,0);
2196 #undef PerlIO_releaseFILE
2198 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2202 /*--------------------------------------------------------------------------------------*/
2203 /* perlio buffer layer */
2206 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2208 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2209 int fd = PerlIO_fileno(f);
2211 if (fd >= 0 && PerlLIO_isatty(fd))
2213 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2215 posn = PerlIO_tell(PerlIONext(f));
2216 if (posn != (Off_t) -1)
2220 return PerlIOBase_pushed(f,mode,arg);
2224 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)
2228 PerlIO *next = PerlIONext(f);
2229 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2230 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2231 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,MYARG) != 0)
2238 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2245 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2248 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,MYARG),PerlIOBuf);
2249 fd = PerlIO_fileno(f);
2250 #if O_BINARY != O_TEXT
2251 /* do something about failing setmode()? --jhi */
2252 PerlLIO_setmode(fd , O_BINARY);
2254 if (init && fd == 2)
2256 /* Initial stderr is unbuffered */
2257 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2264 /* This "flush" is akin to sfio's sync in that it handles files in either
2268 PerlIOBuf_flush(PerlIO *f)
2270 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2272 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2274 /* write() the buffer */
2275 STDCHAR *buf = b->buf;
2277 PerlIO *n = PerlIONext(f);
2280 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2285 else if (count < 0 || PerlIO_error(n))
2287 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2292 b->posn += (p - buf);
2294 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2296 STDCHAR *buf = PerlIO_get_base(f);
2297 /* Note position change */
2298 b->posn += (b->ptr - buf);
2299 if (b->ptr < b->end)
2301 /* We did not consume all of it */
2302 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2304 b->posn = PerlIO_tell(PerlIONext(f));
2308 b->ptr = b->end = b->buf;
2309 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2310 /* FIXME: Is this right for read case ? */
2311 if (PerlIO_flush(PerlIONext(f)) != 0)
2317 PerlIOBuf_fill(PerlIO *f)
2319 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2320 PerlIO *n = PerlIONext(f);
2322 /* FIXME: doing the down-stream flush is a bad idea if it causes
2323 pre-read data in stdio buffer to be discarded
2324 but this is too simplistic - as it skips _our_ hosekeeping
2325 and breaks tell tests.
2326 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2330 if (PerlIO_flush(f) != 0)
2334 PerlIO_get_base(f); /* allocate via vtable */
2336 b->ptr = b->end = b->buf;
2337 if (PerlIO_fast_gets(n))
2339 /* Layer below is also buffered
2340 * We do _NOT_ want to call its ->Read() because that will loop
2341 * till it gets what we asked for which may hang on a pipe etc.
2342 * Instead take anything it has to hand, or ask it to fill _once_.
2344 avail = PerlIO_get_cnt(n);
2347 avail = PerlIO_fill(n);
2349 avail = PerlIO_get_cnt(n);
2352 if (!PerlIO_error(n) && PerlIO_eof(n))
2358 STDCHAR *ptr = PerlIO_get_ptr(n);
2359 SSize_t cnt = avail;
2360 if (avail > b->bufsiz)
2362 Copy(ptr,b->buf,avail,STDCHAR);
2363 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2368 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2373 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2375 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2378 b->end = b->buf+avail;
2379 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2384 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2386 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2387 STDCHAR *buf = (STDCHAR *) vbuf;
2392 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2396 SSize_t avail = PerlIO_get_cnt(f);
2397 SSize_t take = (count < avail) ? count : avail;
2400 STDCHAR *ptr = PerlIO_get_ptr(f);
2401 Copy(ptr,buf,take,STDCHAR);
2402 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2406 if (count > 0 && avail <= 0)
2408 if (PerlIO_fill(f) != 0)
2412 return (buf - (STDCHAR *) vbuf);
2418 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2420 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2421 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2424 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2430 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2432 avail = (b->ptr - b->buf);
2437 b->end = b->buf + avail;
2439 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2440 b->posn -= b->bufsiz;
2442 if (avail > (SSize_t) count)
2450 Copy(buf,b->ptr,avail,STDCHAR);
2454 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2461 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2463 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2464 const STDCHAR *buf = (const STDCHAR *) vbuf;
2468 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2472 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2473 if ((SSize_t) count < avail)
2475 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2476 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2496 Copy(buf,b->ptr,avail,STDCHAR);
2503 if (b->ptr >= (b->buf + b->bufsiz))
2506 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2512 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2515 if ((code = PerlIO_flush(f)) == 0)
2517 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2518 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2519 code = PerlIO_seek(PerlIONext(f),offset,whence);
2522 b->posn = PerlIO_tell(PerlIONext(f));
2529 PerlIOBuf_tell(PerlIO *f)
2531 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2532 Off_t posn = b->posn;
2534 posn += (b->ptr - b->buf);
2539 PerlIOBuf_close(PerlIO *f)
2542 IV code = PerlIOBase_close(f);
2543 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2544 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2546 PerlMemShared_free(b->buf);
2549 b->ptr = b->end = b->buf;
2550 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2555 PerlIOBuf_setlinebuf(PerlIO *f)
2559 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2564 PerlIOBuf_get_ptr(PerlIO *f)
2566 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2573 PerlIOBuf_get_cnt(PerlIO *f)
2575 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2578 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2579 return (b->end - b->ptr);
2584 PerlIOBuf_get_base(PerlIO *f)
2586 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2592 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2595 b->buf = (STDCHAR *)&b->oneword;
2596 b->bufsiz = sizeof(b->oneword);
2605 PerlIOBuf_bufsiz(PerlIO *f)
2607 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2610 return (b->end - b->buf);
2614 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2616 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2620 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2623 assert(PerlIO_get_cnt(f) == cnt);
2624 assert(b->ptr >= b->buf);
2626 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2629 PerlIO_funcs PerlIO_perlio = {
2648 PerlIOBase_clearerr,
2649 PerlIOBuf_setlinebuf,
2654 PerlIOBuf_set_ptrcnt,
2657 /*--------------------------------------------------------------------------------------*/
2658 /* Temp layer to hold unread chars when cannot do it any other way */
2661 PerlIOPending_fill(PerlIO *f)
2663 /* Should never happen */
2669 PerlIOPending_close(PerlIO *f)
2671 /* A tad tricky - flush pops us, then we close new top */
2673 return PerlIO_close(f);
2677 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2679 /* A tad tricky - flush pops us, then we seek new top */
2681 return PerlIO_seek(f,offset,whence);
2686 PerlIOPending_flush(PerlIO *f)
2689 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2690 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2692 PerlMemShared_free(b->buf);
2695 PerlIO_pop(aTHX_ f);
2700 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2708 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2713 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2715 IV code = PerlIOBase_pushed(f,mode,arg);
2716 PerlIOl *l = PerlIOBase(f);
2717 /* Our PerlIO_fast_gets must match what we are pushed on,
2718 or sv_gets() etc. get muddled when it changes mid-string
2721 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2722 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2727 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2729 SSize_t avail = PerlIO_get_cnt(f);
2734 got = PerlIOBuf_read(f,vbuf,avail);
2735 if (got >= 0 && got < count)
2737 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2738 if (more >= 0 || got == 0)
2744 PerlIO_funcs PerlIO_pending = {
2748 PerlIOPending_pushed,
2758 PerlIOPending_close,
2759 PerlIOPending_flush,
2763 PerlIOBase_clearerr,
2764 PerlIOBuf_setlinebuf,
2769 PerlIOPending_set_ptrcnt,
2774 /*--------------------------------------------------------------------------------------*/
2775 /* crlf - translation
2776 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2777 to hand back a line at a time and keeping a record of which nl we "lied" about.
2778 On write translate "\n" to CR,LF
2783 PerlIOBuf base; /* PerlIOBuf stuff */
2784 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2788 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2791 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2792 code = PerlIOBuf_pushed(f,mode,arg);
2794 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2795 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2796 PerlIOBase(f)->flags);
2803 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2805 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2811 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2812 return PerlIOBuf_unread(f,vbuf,count);
2815 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2816 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2818 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2824 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2826 b->end = b->ptr = b->buf + b->bufsiz;
2827 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2828 b->posn -= b->bufsiz;
2830 while (count > 0 && b->ptr > b->buf)
2835 if (b->ptr - 2 >= b->buf)
2861 PerlIOCrlf_get_cnt(PerlIO *f)
2863 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2866 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2868 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2869 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2871 STDCHAR *nl = b->ptr;
2873 while (nl < b->end && *nl != 0xd)
2875 if (nl < b->end && *nl == 0xd)
2887 /* Not CR,LF but just CR */
2894 /* Blast - found CR as last char in buffer */
2897 /* They may not care, defer work as long as possible */
2898 return (nl - b->ptr);
2904 b->ptr++; /* say we have read it as far as flush() is concerned */
2905 b->buf++; /* Leave space an front of buffer */
2906 b->bufsiz--; /* Buffer is thus smaller */
2907 code = PerlIO_fill(f); /* Fetch some more */
2908 b->bufsiz++; /* Restore size for next time */
2909 b->buf--; /* Point at space */
2910 b->ptr = nl = b->buf; /* Which is what we hand off */
2911 b->posn--; /* Buffer starts here */
2912 *nl = 0xd; /* Fill in the CR */
2914 goto test; /* fill() call worked */
2915 /* CR at EOF - just fall through */
2920 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2926 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2929 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2930 IV flags = PerlIOBase(f)->flags;
2940 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2947 /* Test code - delete when it works ... */
2954 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2962 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2963 ptr, chk, flags, c->nl, b->end, cnt);
2970 /* They have taken what we lied about */
2977 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2981 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2983 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2984 return PerlIOBuf_write(f,vbuf,count);
2987 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2988 const STDCHAR *buf = (const STDCHAR *) vbuf;
2989 const STDCHAR *ebuf = buf+count;
2992 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2996 STDCHAR *eptr = b->buf+b->bufsiz;
2997 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2998 while (buf < ebuf && b->ptr < eptr)
3002 if ((b->ptr + 2) > eptr)
3004 /* Not room for both */
3010 *(b->ptr)++ = 0xd; /* CR */
3011 *(b->ptr)++ = 0xa; /* LF */
3013 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3032 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3034 return (buf - (STDCHAR *) vbuf);
3039 PerlIOCrlf_flush(PerlIO *f)
3041 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3047 return PerlIOBuf_flush(f);
3050 PerlIO_funcs PerlIO_crlf = {
3053 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3055 PerlIOBase_noop_ok, /* popped */
3059 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3060 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3061 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3069 PerlIOBase_clearerr,
3070 PerlIOBuf_setlinebuf,
3075 PerlIOCrlf_set_ptrcnt,
3079 /*--------------------------------------------------------------------------------------*/
3080 /* mmap as "buffer" layer */
3084 PerlIOBuf base; /* PerlIOBuf stuff */
3085 Mmap_t mptr; /* Mapped address */
3086 Size_t len; /* mapped length */
3087 STDCHAR *bbuf; /* malloced buffer if map fails */
3090 static size_t page_size = 0;
3093 PerlIOMmap_map(PerlIO *f)
3096 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3097 PerlIOBuf *b = &m->base;
3098 IV flags = PerlIOBase(f)->flags;
3102 if (flags & PERLIO_F_CANREAD)
3104 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3105 int fd = PerlIO_fileno(f);
3107 code = fstat(fd,&st);
3108 if (code == 0 && S_ISREG(st.st_mode))
3110 SSize_t len = st.st_size - b->posn;
3115 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3117 SETERRNO(0,SS$_NORMAL);
3118 # ifdef _SC_PAGESIZE
3119 page_size = sysconf(_SC_PAGESIZE);
3121 page_size = sysconf(_SC_PAGE_SIZE);
3123 if ((long)page_size < 0) {
3128 (void)SvUPGRADE(error, SVt_PV);
3129 msg = SvPVx(error, n_a);
3130 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3133 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3137 # ifdef HAS_GETPAGESIZE
3138 page_size = getpagesize();
3140 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3141 page_size = PAGESIZE; /* compiletime, bad */
3145 if ((IV)page_size <= 0)
3146 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3150 /* This is a hack - should never happen - open should have set it ! */
3151 b->posn = PerlIO_tell(PerlIONext(f));
3153 posn = (b->posn / page_size) * page_size;
3154 len = st.st_size - posn;
3155 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3156 if (m->mptr && m->mptr != (Mmap_t) -1)
3158 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3159 madvise(m->mptr, len, MADV_SEQUENTIAL);
3161 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3162 madvise(m->mptr, len, MADV_WILLNEED);
3164 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3165 b->end = ((STDCHAR *)m->mptr) + len;
3166 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3177 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3179 b->ptr = b->end = b->ptr;
3188 PerlIOMmap_unmap(PerlIO *f)
3190 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3191 PerlIOBuf *b = &m->base;
3197 code = munmap(m->mptr, m->len);
3201 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3204 b->ptr = b->end = b->buf;
3205 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3211 PerlIOMmap_get_base(PerlIO *f)
3213 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3214 PerlIOBuf *b = &m->base;
3215 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3217 /* Already have a readbuffer in progress */
3222 /* We have a write buffer or flushed PerlIOBuf read buffer */
3223 m->bbuf = b->buf; /* save it in case we need it again */
3224 b->buf = NULL; /* Clear to trigger below */
3228 PerlIOMmap_map(f); /* Try and map it */
3231 /* Map did not work - recover PerlIOBuf buffer if we have one */
3235 b->ptr = b->end = b->buf;
3238 return PerlIOBuf_get_base(f);
3242 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3244 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3245 PerlIOBuf *b = &m->base;
3246 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3248 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3251 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3256 /* Loose the unwritable mapped buffer */
3258 /* If flush took the "buffer" see if we have one from before */
3259 if (!b->buf && m->bbuf)
3263 PerlIOBuf_get_base(f);
3267 return PerlIOBuf_unread(f,vbuf,count);
3271 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3273 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3274 PerlIOBuf *b = &m->base;
3275 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3277 /* No, or wrong sort of, buffer */
3280 if (PerlIOMmap_unmap(f) != 0)
3283 /* If unmap took the "buffer" see if we have one from before */
3284 if (!b->buf && m->bbuf)
3288 PerlIOBuf_get_base(f);
3292 return PerlIOBuf_write(f,vbuf,count);
3296 PerlIOMmap_flush(PerlIO *f)
3298 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3299 PerlIOBuf *b = &m->base;
3300 IV code = PerlIOBuf_flush(f);
3301 /* Now we are "synced" at PerlIOBuf level */
3306 /* Unmap the buffer */
3307 if (PerlIOMmap_unmap(f) != 0)
3312 /* We seem to have a PerlIOBuf buffer which was not mapped
3313 * remember it in case we need one later
3322 PerlIOMmap_fill(PerlIO *f)
3324 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3325 IV code = PerlIO_flush(f);
3326 if (code == 0 && !b->buf)
3328 code = PerlIOMmap_map(f);
3330 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3332 code = PerlIOBuf_fill(f);
3338 PerlIOMmap_close(PerlIO *f)
3340 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3341 PerlIOBuf *b = &m->base;
3342 IV code = PerlIO_flush(f);
3347 b->ptr = b->end = b->buf;
3349 if (PerlIOBuf_close(f) != 0)
3355 PerlIO_funcs PerlIO_mmap = {
3374 PerlIOBase_clearerr,
3375 PerlIOBuf_setlinebuf,
3376 PerlIOMmap_get_base,
3380 PerlIOBuf_set_ptrcnt,
3383 #endif /* HAS_MMAP */
3391 atexit(&PerlIO_cleanup);
3403 PerlIO_stdstreams(aTHX);
3408 #undef PerlIO_stdout
3415 PerlIO_stdstreams(aTHX);
3420 #undef PerlIO_stderr
3427 PerlIO_stdstreams(aTHX);
3432 /*--------------------------------------------------------------------------------------*/
3434 #undef PerlIO_getname
3436 PerlIO_getname(PerlIO *f, char *buf)
3439 Perl_croak(aTHX_ "Don't know how to get file name");
3444 /*--------------------------------------------------------------------------------------*/
3445 /* Functions which can be called on any kind of PerlIO implemented
3451 PerlIO_getc(PerlIO *f)
3454 SSize_t count = PerlIO_read(f,buf,1);
3457 return (unsigned char) buf[0];
3462 #undef PerlIO_ungetc
3464 PerlIO_ungetc(PerlIO *f, int ch)
3469 if (PerlIO_unread(f,&buf,1) == 1)
3477 PerlIO_putc(PerlIO *f, int ch)
3480 return PerlIO_write(f,&buf,1);
3485 PerlIO_puts(PerlIO *f, const char *s)
3487 STRLEN len = strlen(s);
3488 return PerlIO_write(f,s,len);
3491 #undef PerlIO_rewind
3493 PerlIO_rewind(PerlIO *f)
3495 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3499 #undef PerlIO_vprintf
3501 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3504 SV *sv = newSVpvn("",0);
3510 Perl_va_copy(ap, apc);
3511 sv_vcatpvf(sv, fmt, &apc);
3513 sv_vcatpvf(sv, fmt, &ap);
3516 wrote = PerlIO_write(f,s,len);
3521 #undef PerlIO_printf
3523 PerlIO_printf(PerlIO *f,const char *fmt,...)
3528 result = PerlIO_vprintf(f,fmt,ap);
3533 #undef PerlIO_stdoutf
3535 PerlIO_stdoutf(const char *fmt,...)
3540 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3545 #undef PerlIO_tmpfile
3547 PerlIO_tmpfile(void)
3549 /* I have no idea how portable mkstemp() is ... */
3550 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3553 FILE *stdio = PerlSIO_tmpfile();
3556 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3562 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3563 int fd = mkstemp(SvPVX(sv));
3567 f = PerlIO_fdopen(fd,"w+");
3570 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3572 PerlLIO_unlink(SvPVX(sv));
3582 #endif /* USE_SFIO */
3583 #endif /* PERLIO_IS_STDIO */
3585 /*======================================================================================*/
3586 /* Now some functions in terms of above which may be needed even if
3587 we are not in true PerlIO mode
3591 #undef PerlIO_setpos
3593 PerlIO_setpos(PerlIO *f, SV *pos)
3599 Off_t *posn = (Off_t *) SvPV(pos,len);
3600 if (f && len == sizeof(Off_t))
3601 return PerlIO_seek(f,*posn,SEEK_SET);
3607 #undef PerlIO_setpos
3609 PerlIO_setpos(PerlIO *f, SV *pos)
3615 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3616 if (f && len == sizeof(Fpos_t))
3618 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3619 return fsetpos64(f, fpos);
3621 return fsetpos(f, fpos);
3631 #undef PerlIO_getpos
3633 PerlIO_getpos(PerlIO *f, SV *pos)
3636 Off_t posn = PerlIO_tell(f);
3637 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3638 return (posn == (Off_t)-1) ? -1 : 0;
3641 #undef PerlIO_getpos
3643 PerlIO_getpos(PerlIO *f, SV *pos)
3648 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3649 code = fgetpos64(f, &fpos);
3651 code = fgetpos(f, &fpos);
3653 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3658 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3661 vprintf(char *pat, char *args)
3663 _doprnt(pat, args, stdout);
3664 return 0; /* wrong, but perl doesn't use the return value */
3668 vfprintf(FILE *fd, char *pat, char *args)
3670 _doprnt(pat, args, fd);
3671 return 0; /* wrong, but perl doesn't use the return value */
3676 #ifndef PerlIO_vsprintf
3678 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3680 int val = vsprintf(s, fmt, ap);
3683 if (strlen(s) >= (STRLEN)n)
3686 (void)PerlIO_puts(Perl_error_log,
3687 "panic: sprintf overflow - memory corrupted!\n");
3695 #ifndef PerlIO_sprintf
3697 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3702 result = PerlIO_vsprintf(s, n, fmt, ap);