3 * Copyright (c) 1996-2001, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
37 perlsio_binmode(FILE *fp, int iotype, int mode)
39 /* This used to be contents of do_binmode in doio.c */
41 # if defined(atarist) || defined(__MINT__)
44 ((FILE*)fp)->_flag |= _IOBIN;
46 ((FILE*)fp)->_flag &= ~ _IOBIN;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
53 # if defined(WIN32) && defined(__BORLANDC__)
54 /* The translation mode of the stream is maintained independent
55 * of the translation mode of the fd in the Borland RTL (heavy
56 * digging through their runtime sources reveal). User has to
57 * set the mode explicitly for the stream (though they don't
58 * document this anywhere). GSAR 97-5-24
64 fp->flags &= ~ _F_BIN;
72 # if defined(USEMYBINMODE)
73 if (my_binmode(fp, iotype, mode) != FALSE)
85 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
87 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
91 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
102 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
104 return perlsio_binmode(fp,iotype,mode);
107 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
110 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
114 if (*args == &PL_sv_undef)
115 return PerlIO_tmpfile();
118 char *name = SvPV_nolen(*args);
121 fd = PerlLIO_open3(name,imode,perm);
123 return PerlIO_fdopen(fd,mode+1);
127 return PerlIO_reopen(name,mode,old);
131 return PerlIO_open(name,mode);
137 return PerlIO_fdopen(fd,mode);
145 #ifdef PERLIO_IS_STDIO
150 /* Does nothing (yet) except force this file to be included
151 in perl binary. That allows this file to force inclusion
152 of other functions that may be required by loadable
153 extensions e.g. for FileHandle::tmpfile
157 #undef PerlIO_tmpfile
164 #else /* PERLIO_IS_STDIO */
171 /* This section is just to make sure these functions
172 get pulled in from libsfio.a
175 #undef PerlIO_tmpfile
185 /* Force this file to be included in perl binary. Which allows
186 * this file to force inclusion of other functions that may be
187 * required by loadable extensions e.g. for FileHandle::tmpfile
191 * sfio does its own 'autoflush' on stdout in common cases.
192 * Flush results in a lot of lseek()s to regular files and
193 * lot of small writes to pipes.
195 sfset(sfstdout,SF_SHARE,0);
199 /*======================================================================================*/
200 /* Implement all the PerlIO interface ourselves.
205 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
210 #include <sys/mman.h>
215 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
218 PerlIO_debug(const char *fmt,...)
226 char *s = PerlEnv_getenv("PERLIO_DEBUG");
228 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
235 SV *sv = newSVpvn("",0);
238 s = CopFILE(PL_curcop);
241 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
242 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
245 PerlLIO_write(dbg,s,len);
251 /*--------------------------------------------------------------------------------------*/
253 /* Inner level routines */
255 /* Table of pointers to the PerlIO structs (malloc'ed) */
256 PerlIO *_perlio = NULL;
257 #define PERLIO_TABLE_SIZE 64
262 PerlIO_allocate(pTHX)
264 /* Find a free slot in the table, allocating new table as necessary */
271 last = (PerlIO **)(f);
272 for (i=1; i < PERLIO_TABLE_SIZE; i++)
280 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
290 PerlIO_cleantable(pTHX_ PerlIO **tablep)
292 PerlIO *table = *tablep;
296 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
297 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
305 PerlMemShared_free(table);
317 PerlIO_cleantable(aTHX_ &_perlio);
321 PerlIO_destruct(pTHX)
323 PerlIO **table = &_perlio;
328 table = (PerlIO **)(f++);
329 for (i=1; i < PERLIO_TABLE_SIZE; i++)
335 if (l->tab->kind & PERLIO_K_DESTRUCT)
337 PerlIO_debug("Destruct popping %s\n",l->tab->name);
352 PerlIO_pop(pTHX_ PerlIO *f)
357 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
359 (*l->tab->Popped)(f);
361 PerlMemShared_free(l);
365 /*--------------------------------------------------------------------------------------*/
366 /* XS Interface for perl code */
372 char *s = GvNAME(gv);
373 STRLEN l = GvNAMELEN(gv);
374 PerlIO_debug("%.*s\n",(int) l,s);
378 XS(XS_perlio_unimport)
382 char *s = GvNAME(gv);
383 STRLEN l = GvNAMELEN(gv);
384 PerlIO_debug("%.*s\n",(int) l,s);
389 PerlIO_find_layer(pTHX_ const char *name, STRLEN len)
393 if ((SSize_t) len <= 0)
395 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
396 if (!svp && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
398 SV *pkgsv = newSVpvn("PerlIO",6);
399 SV *layer = newSVpvn(name,len);
401 /* The two SVs are magically freed by load_module */
402 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
404 /* Say this is lvalue so we get an 'undef' if still not there */
405 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
407 if (svp && (sv = *svp))
417 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
421 IO *io = GvIOn((GV *)SvRV(sv));
422 PerlIO *ifp = IoIFP(io);
423 PerlIO *ofp = IoOFP(io);
424 AV *av = (AV *) mg->mg_obj;
425 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
431 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
435 IO *io = GvIOn((GV *)SvRV(sv));
436 PerlIO *ifp = IoIFP(io);
437 PerlIO *ofp = IoOFP(io);
438 AV *av = (AV *) mg->mg_obj;
439 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
445 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
447 Perl_warn(aTHX_ "clear %"SVf,sv);
452 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
454 Perl_warn(aTHX_ "free %"SVf,sv);
458 MGVTBL perlio_vtab = {
466 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
469 SV *sv = SvRV(ST(1));
474 sv_magic(sv, (SV *)av, '~', NULL, 0);
476 mg = mg_find(sv,'~');
477 mg->mg_virtual = &perlio_vtab;
479 Perl_warn(aTHX_ "attrib %"SVf,sv);
480 for (i=2; i < items; i++)
483 const char *name = SvPV(ST(i),len);
484 SV *layer = PerlIO_find_layer(aTHX_ name,len);
487 av_push(av,SvREFCNT_inc(layer));
500 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
502 HV *stash = gv_stashpv("perlio::Layer", TRUE);
503 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
508 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
510 if (!PerlIO_layer_hv)
512 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
514 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
515 PerlIO_debug("define %s %p\n",tab->name,tab);
519 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
523 const char *s = names;
526 while (isSPACE(*s) || *s == ':')
532 const char *as = Nullch;
536 /* Message is consistent with how attribute lists are passed.
537 Even though this means "foo : : bar" is seen as an invalid separator
539 char q = ((*s == '\'') ? '"' : '\'');
540 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
546 } while (isALNUM(*e));
564 /* It's a nul terminated string, not allowed to \ the terminating null.
565 Anything other character is passed over. */
573 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
583 SV *layer = PerlIO_find_layer(aTHX_ s,llen);
586 av_push(av,SvREFCNT_inc(layer));
587 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
590 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
602 PerlIO_default_buffer(pTHX_ AV *av)
604 PerlIO_funcs *tab = &PerlIO_perlio;
605 if (O_BINARY != O_TEXT)
611 if (PerlIO_stdio.Set_ptrcnt)
616 PerlIO_debug("Pushing %s\n",tab->name);
617 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0)));
618 av_push(av,&PL_sv_undef);
622 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
624 SV **svp = av_fetch(av,n,FALSE);
625 return (svp) ? *svp : Nullsv;
629 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
631 SV **svp = av_fetch(av,n,FALSE);
633 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
635 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
636 return INT2PTR(PerlIO_funcs *, SvIV(layer));
639 Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
644 PerlIO_default_layers(pTHX)
647 if (!PerlIO_layer_av)
649 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
650 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
651 newXS("perlio::import",XS_perlio_import,__FILE__);
652 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
654 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
656 PerlIO_define_layer(aTHX_ &PerlIO_raw);
657 PerlIO_define_layer(aTHX_ &PerlIO_unix);
658 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
659 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
660 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
662 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
664 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
665 PerlIO_define_layer(aTHX_ &PerlIO_byte);
666 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0)));
667 av_push(PerlIO_layer_av,&PL_sv_undef);
670 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
674 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
677 len = av_len(PerlIO_layer_av)+1;
680 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
681 len = av_len(PerlIO_layer_av);
683 return PerlIO_layer_av;
688 PerlIO_default_layer(pTHX_ I32 n)
690 AV *av = PerlIO_default_layers(aTHX);
693 n += av_len(PerlIO_layer_av)+1;
694 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
697 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
698 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
701 PerlIO_stdstreams(pTHX)
705 PerlIO_allocate(aTHX);
706 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
707 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
708 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
713 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
716 l = PerlMemShared_calloc(tab->size,sizeof(char));
719 Zero(l,tab->size,char);
723 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
724 (mode) ? mode : "(Null)",arg);
725 if ((*l->tab->Pushed)(f,mode,arg) != 0)
735 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
749 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
751 /* Remove the dummy layer */
754 /* Pop back to bottom layer */
759 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
767 /* Nothing bellow - push unix on top then remove it */
768 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
770 PerlIO_pop(aTHX_ PerlIONext(f));
775 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
782 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
784 IV max = av_len(layers)+1;
788 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
791 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
803 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
808 AV *layers = newAV();
809 code = PerlIO_parse_layers(aTHX_ layers,names);
812 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
814 SvREFCNT_dec((SV *) layers);
820 /*--------------------------------------------------------------------------------------*/
821 /* Given the abstraction above the public API functions */
824 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
826 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
827 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
828 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
834 if (PerlIOBase(top)->tab == &PerlIO_crlf)
837 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
840 top = PerlIONext(top);
843 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
848 PerlIO__close(PerlIO *f)
850 return (*PerlIOBase(f)->tab->Close)(f);
853 #undef PerlIO_fdupopen
855 PerlIO_fdupopen(pTHX_ PerlIO *f)
858 int fd = PerlLIO_dup(PerlIO_fileno(f));
859 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
862 Off_t posn = PerlIO_tell(f);
863 PerlIO_seek(new,posn,SEEK_SET);
870 PerlIO_close(PerlIO *f)
876 code = (*PerlIOBase(f)->tab->Close)(f);
887 PerlIO_fileno(PerlIO *f)
889 return (*PerlIOBase(f)->tab->Fileno)(f);
893 PerlIO_context_layers(pTHX_ const char *mode)
895 const char *type = NULL;
896 /* Need to supply default layer info from open.pm */
899 SV *layers = PL_curcop->cop_io;
903 type = SvPV(layers,len);
904 if (type && mode[0] != 'r')
906 /* Skip to write part */
907 const char *s = strchr(type,0);
908 if (s && (s-type) < len)
919 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
921 AV *def = PerlIO_default_layers(aTHX);
924 PerlIO_stdstreams(aTHX);
927 if (SvROK(*args) && !sv_isobject(*args))
929 if (SvTYPE(SvRV(*args)) < SVt_PVAV)
931 SV *handler = PerlIO_find_layer(aTHX_ "Scalar",6);
935 av_push(def,SvREFCNT_inc(handler));
936 av_push(def,&PL_sv_undef);
942 Perl_croak(aTHX_ "Unsupported reference arg to open()");
947 layers = PerlIO_context_layers(aTHX_ mode);
948 if (layers && *layers)
953 IV n = av_len(def)+1;
957 SV **svp = av_fetch(def,n,0);
958 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
965 PerlIO_parse_layers(aTHX_ av,layers);
977 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
979 if (!f && narg == 1 && *args == &PL_sv_undef)
981 if ((f = PerlIO_tmpfile()))
984 layers = PerlIO_context_layers(aTHX_ mode);
985 if (layers && *layers)
986 PerlIO_apply_layers(aTHX_ f,mode,layers);
996 /* This is "reopen" - it is not tested as perl does not use it yet */
1001 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1002 av_unshift(layera,2);
1003 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1004 av_store(layera,1,arg);
1005 l = *PerlIONext(&l);
1010 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1012 n = av_len(layera)-1;
1015 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1025 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1026 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1027 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1030 if (n+2 < av_len(layera)+1)
1032 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1039 SvREFCNT_dec(layera);
1045 #undef PerlIO_fdopen
1047 PerlIO_fdopen(int fd, const char *mode)
1050 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1055 PerlIO_open(const char *path, const char *mode)
1058 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1059 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1062 #undef PerlIO_reopen
1064 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1067 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1068 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1073 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1075 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1078 #undef PerlIO_unread
1080 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1082 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1087 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1089 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1094 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1096 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1101 PerlIO_tell(PerlIO *f)
1103 return (*PerlIOBase(f)->tab->Tell)(f);
1108 PerlIO_flush(PerlIO *f)
1112 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1113 if (tab && tab->Flush)
1115 return (*tab->Flush)(f);
1119 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1126 PerlIO **table = &_perlio;
1128 while ((f = *table))
1131 table = (PerlIO **)(f++);
1132 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1134 if (*f && PerlIO_flush(f) != 0)
1144 PerlIOBase_flush_linebuf()
1146 PerlIO **table = &_perlio;
1148 while ((f = *table))
1151 table = (PerlIO **)(f++);
1152 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1154 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1155 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1164 PerlIO_fill(PerlIO *f)
1166 return (*PerlIOBase(f)->tab->Fill)(f);
1169 #undef PerlIO_isutf8
1171 PerlIO_isutf8(PerlIO *f)
1173 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1178 PerlIO_eof(PerlIO *f)
1180 return (*PerlIOBase(f)->tab->Eof)(f);
1185 PerlIO_error(PerlIO *f)
1187 return (*PerlIOBase(f)->tab->Error)(f);
1190 #undef PerlIO_clearerr
1192 PerlIO_clearerr(PerlIO *f)
1195 (*PerlIOBase(f)->tab->Clearerr)(f);
1198 #undef PerlIO_setlinebuf
1200 PerlIO_setlinebuf(PerlIO *f)
1202 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1205 #undef PerlIO_has_base
1207 PerlIO_has_base(PerlIO *f)
1211 return (PerlIOBase(f)->tab->Get_base != NULL);
1216 #undef PerlIO_fast_gets
1218 PerlIO_fast_gets(PerlIO *f)
1220 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1222 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1223 return (tab->Set_ptrcnt != NULL);
1228 #undef PerlIO_has_cntptr
1230 PerlIO_has_cntptr(PerlIO *f)
1234 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1235 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1240 #undef PerlIO_canset_cnt
1242 PerlIO_canset_cnt(PerlIO *f)
1246 PerlIOl *l = PerlIOBase(f);
1247 return (l->tab->Set_ptrcnt != NULL);
1252 #undef PerlIO_get_base
1254 PerlIO_get_base(PerlIO *f)
1256 return (*PerlIOBase(f)->tab->Get_base)(f);
1259 #undef PerlIO_get_bufsiz
1261 PerlIO_get_bufsiz(PerlIO *f)
1263 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1266 #undef PerlIO_get_ptr
1268 PerlIO_get_ptr(PerlIO *f)
1270 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1271 if (tab->Get_ptr == NULL)
1273 return (*tab->Get_ptr)(f);
1276 #undef PerlIO_get_cnt
1278 PerlIO_get_cnt(PerlIO *f)
1280 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1281 if (tab->Get_cnt == NULL)
1283 return (*tab->Get_cnt)(f);
1286 #undef PerlIO_set_cnt
1288 PerlIO_set_cnt(PerlIO *f,int cnt)
1290 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1293 #undef PerlIO_set_ptrcnt
1295 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1297 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1298 if (tab->Set_ptrcnt == NULL)
1301 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1303 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1306 /*--------------------------------------------------------------------------------------*/
1307 /* utf8 and raw dummy layers */
1310 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1315 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1316 PerlIO_pop(aTHX_ f);
1317 if (tab->kind & PERLIO_K_UTF8)
1318 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1320 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1326 PerlIO_funcs PerlIO_utf8 = {
1329 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1347 NULL, /* get_base */
1348 NULL, /* get_bufsiz */
1351 NULL, /* set_ptrcnt */
1354 PerlIO_funcs PerlIO_byte = {
1375 NULL, /* get_base */
1376 NULL, /* get_bufsiz */
1379 NULL, /* set_ptrcnt */
1383 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)
1385 PerlIO_funcs *tab = PerlIO_default_btm();
1386 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1389 PerlIO_funcs PerlIO_raw = {
1410 NULL, /* get_base */
1411 NULL, /* get_bufsiz */
1414 NULL, /* set_ptrcnt */
1416 /*--------------------------------------------------------------------------------------*/
1417 /*--------------------------------------------------------------------------------------*/
1418 /* "Methods" of the "base class" */
1421 PerlIOBase_fileno(PerlIO *f)
1423 return PerlIO_fileno(PerlIONext(f));
1427 PerlIO_modestr(PerlIO *f,char *buf)
1430 IV flags = PerlIOBase(f)->flags;
1431 if (flags & PERLIO_F_APPEND)
1434 if (flags & PERLIO_F_CANREAD)
1439 else if (flags & PERLIO_F_CANREAD)
1442 if (flags & PERLIO_F_CANWRITE)
1445 else if (flags & PERLIO_F_CANWRITE)
1448 if (flags & PERLIO_F_CANREAD)
1453 #if O_TEXT != O_BINARY
1454 if (!(flags & PERLIO_F_CRLF))
1462 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1464 PerlIOl *l = PerlIOBase(f);
1465 const char *omode = mode;
1467 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1468 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1469 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1470 if (tab->Set_ptrcnt != NULL)
1471 l->flags |= PERLIO_F_FASTGETS;
1477 l->flags |= PERLIO_F_CANREAD;
1480 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1483 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1494 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1497 l->flags &= ~PERLIO_F_CRLF;
1500 l->flags |= PERLIO_F_CRLF;
1512 l->flags |= l->next->flags &
1513 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1517 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1518 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1519 l->flags,PerlIO_modestr(f,temp));
1525 PerlIOBase_popped(PerlIO *f)
1531 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1534 Off_t old = PerlIO_tell(f);
1536 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1537 done = PerlIOBuf_unread(f,vbuf,count);
1538 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1543 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1545 STDCHAR *buf = (STDCHAR *) vbuf;
1548 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1552 SSize_t avail = PerlIO_get_cnt(f);
1553 SSize_t take = (count < avail) ? count : avail;
1556 STDCHAR *ptr = PerlIO_get_ptr(f);
1557 Copy(ptr,buf,take,STDCHAR);
1558 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1562 if (count > 0 && avail <= 0)
1564 if (PerlIO_fill(f) != 0)
1568 return (buf - (STDCHAR *) vbuf);
1574 PerlIOBase_noop_ok(PerlIO *f)
1580 PerlIOBase_noop_fail(PerlIO *f)
1586 PerlIOBase_close(PerlIO *f)
1589 PerlIO *n = PerlIONext(f);
1590 if (PerlIO_flush(f) != 0)
1592 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1594 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1599 PerlIOBase_eof(PerlIO *f)
1603 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1609 PerlIOBase_error(PerlIO *f)
1613 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1619 PerlIOBase_clearerr(PerlIO *f)
1623 PerlIO *n = PerlIONext(f);
1624 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1631 PerlIOBase_setlinebuf(PerlIO *f)
1635 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1639 /*--------------------------------------------------------------------------------------*/
1640 /* Bottom-most level for UNIX-like case */
1644 struct _PerlIO base; /* The generic part */
1645 int fd; /* UNIX like file descriptor */
1646 int oflags; /* open/fcntl flags */
1650 PerlIOUnix_oflags(const char *mode)
1665 oflags = O_CREAT|O_TRUNC;
1676 oflags = O_CREAT|O_APPEND;
1692 else if (*mode == 't')
1695 oflags &= ~O_BINARY;
1698 /* Always open in binary mode */
1700 if (*mode || oflags == -1)
1709 PerlIOUnix_fileno(PerlIO *f)
1711 return PerlIOSelf(f,PerlIOUnix)->fd;
1715 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1717 IV code = PerlIOBase_pushed(f,mode,arg);
1720 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1721 s->fd = PerlIO_fileno(PerlIONext(f));
1722 s->oflags = PerlIOUnix_oflags(mode);
1724 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1729 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)
1733 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1734 (*PerlIOBase(f)->tab->Close)(f);
1738 char *path = SvPV_nolen(*args);
1743 imode = PerlIOUnix_oflags(mode);
1748 fd = PerlLIO_open3(path,imode,perm);
1758 f = PerlIO_allocate(aTHX);
1759 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1762 s = PerlIOSelf(f,PerlIOUnix);
1765 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1772 /* FIXME: pop layers ??? */
1779 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1782 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1783 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1787 SSize_t len = PerlLIO_read(fd,vbuf,count);
1788 if (len >= 0 || errno != EINTR)
1791 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1792 else if (len == 0 && count != 0)
1793 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1801 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1804 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1807 SSize_t len = PerlLIO_write(fd,vbuf,count);
1808 if (len >= 0 || errno != EINTR)
1811 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1819 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1822 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1823 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1824 return (new == (Off_t) -1) ? -1 : 0;
1828 PerlIOUnix_tell(PerlIO *f)
1831 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1832 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1836 PerlIOUnix_close(PerlIO *f)
1839 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1841 while (PerlLIO_close(fd) != 0)
1852 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1857 PerlIO_funcs PerlIO_unix = {
1872 PerlIOBase_noop_ok, /* flush */
1873 PerlIOBase_noop_fail, /* fill */
1876 PerlIOBase_clearerr,
1877 PerlIOBase_setlinebuf,
1878 NULL, /* get_base */
1879 NULL, /* get_bufsiz */
1882 NULL, /* set_ptrcnt */
1885 /*--------------------------------------------------------------------------------------*/
1886 /* stdio as a layer */
1890 struct _PerlIO base;
1891 FILE * stdio; /* The stream */
1895 PerlIOStdio_fileno(PerlIO *f)
1898 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1902 PerlIOStdio_mode(const char *mode,char *tmode)
1909 if (O_BINARY != O_TEXT)
1917 /* This isn't used yet ... */
1919 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1924 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1926 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1932 return PerlIOBase_pushed(f,mode,arg);
1935 #undef PerlIO_importFILE
1937 PerlIO_importFILE(FILE *stdio, int fl)
1943 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1950 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)
1955 char *path = SvPV_nolen(*args);
1956 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1957 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1967 char *path = SvPV_nolen(*args);
1971 fd = PerlLIO_open3(path,imode,perm);
1975 FILE *stdio = PerlSIO_fopen(path,mode);
1978 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1979 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2000 stdio = PerlSIO_stdin;
2003 stdio = PerlSIO_stdout;
2006 stdio = PerlSIO_stderr;
2012 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2016 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2026 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2029 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2033 STDCHAR *buf = (STDCHAR *) vbuf;
2034 /* Perl is expecting PerlIO_getc() to fill the buffer
2035 * Linux's stdio does not do that for fread()
2037 int ch = PerlSIO_fgetc(s);
2045 got = PerlSIO_fread(vbuf,1,count,s);
2050 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2053 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2054 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2058 int ch = *buf-- & 0xff;
2059 if (PerlSIO_ungetc(ch,s) != ch)
2068 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2071 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2075 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2078 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2079 return PerlSIO_fseek(stdio,offset,whence);
2083 PerlIOStdio_tell(PerlIO *f)
2086 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2087 return PerlSIO_ftell(stdio);
2091 PerlIOStdio_close(PerlIO *f)
2094 #ifdef HAS_SOCKS5_INIT
2095 int optval, optlen = sizeof(int);
2097 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2099 #ifdef HAS_SOCKS5_INIT
2100 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2101 PerlSIO_fclose(stdio) :
2102 close(PerlIO_fileno(f))
2104 PerlSIO_fclose(stdio)
2111 PerlIOStdio_flush(PerlIO *f)
2114 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2115 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2117 return PerlSIO_fflush(stdio);
2122 /* FIXME: This discards ungetc() and pre-read stuff which is
2123 not right if this is just a "sync" from a layer above
2124 Suspect right design is to do _this_ but not have layer above
2125 flush this layer read-to-read
2127 /* Not writeable - sync by attempting a seek */
2129 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2137 PerlIOStdio_fill(PerlIO *f)
2140 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2142 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2143 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2145 if (PerlSIO_fflush(stdio) != 0)
2148 c = PerlSIO_fgetc(stdio);
2149 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2155 PerlIOStdio_eof(PerlIO *f)
2158 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2162 PerlIOStdio_error(PerlIO *f)
2165 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2169 PerlIOStdio_clearerr(PerlIO *f)
2172 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2176 PerlIOStdio_setlinebuf(PerlIO *f)
2179 #ifdef HAS_SETLINEBUF
2180 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2182 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2188 PerlIOStdio_get_base(PerlIO *f)
2191 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2192 return PerlSIO_get_base(stdio);
2196 PerlIOStdio_get_bufsiz(PerlIO *f)
2199 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2200 return PerlSIO_get_bufsiz(stdio);
2204 #ifdef USE_STDIO_PTR
2206 PerlIOStdio_get_ptr(PerlIO *f)
2209 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2210 return PerlSIO_get_ptr(stdio);
2214 PerlIOStdio_get_cnt(PerlIO *f)
2217 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2218 return PerlSIO_get_cnt(stdio);
2222 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2225 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2228 #ifdef STDIO_PTR_LVALUE
2229 PerlSIO_set_ptr(stdio,ptr);
2230 #ifdef STDIO_PTR_LVAL_SETS_CNT
2231 if (PerlSIO_get_cnt(stdio) != (cnt))
2234 assert(PerlSIO_get_cnt(stdio) == (cnt));
2237 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2238 /* Setting ptr _does_ change cnt - we are done */
2241 #else /* STDIO_PTR_LVALUE */
2243 #endif /* STDIO_PTR_LVALUE */
2245 /* Now (or only) set cnt */
2246 #ifdef STDIO_CNT_LVALUE
2247 PerlSIO_set_cnt(stdio,cnt);
2248 #else /* STDIO_CNT_LVALUE */
2249 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2250 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2251 #else /* STDIO_PTR_LVAL_SETS_CNT */
2253 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2254 #endif /* STDIO_CNT_LVALUE */
2259 PerlIO_funcs PerlIO_stdio = {
2261 sizeof(PerlIOStdio),
2278 PerlIOStdio_clearerr,
2279 PerlIOStdio_setlinebuf,
2281 PerlIOStdio_get_base,
2282 PerlIOStdio_get_bufsiz,
2287 #ifdef USE_STDIO_PTR
2288 PerlIOStdio_get_ptr,
2289 PerlIOStdio_get_cnt,
2290 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2291 PerlIOStdio_set_ptrcnt
2292 #else /* STDIO_PTR_LVALUE */
2294 #endif /* STDIO_PTR_LVALUE */
2295 #else /* USE_STDIO_PTR */
2299 #endif /* USE_STDIO_PTR */
2302 #undef PerlIO_exportFILE
2304 PerlIO_exportFILE(PerlIO *f, int fl)
2308 stdio = fdopen(PerlIO_fileno(f),"r+");
2312 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2318 #undef PerlIO_findFILE
2320 PerlIO_findFILE(PerlIO *f)
2325 if (l->tab == &PerlIO_stdio)
2327 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2330 l = *PerlIONext(&l);
2332 return PerlIO_exportFILE(f,0);
2335 #undef PerlIO_releaseFILE
2337 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2341 /*--------------------------------------------------------------------------------------*/
2342 /* perlio buffer layer */
2345 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2347 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2348 int fd = PerlIO_fileno(f);
2351 if (fd >= 0 && PerlLIO_isatty(fd))
2353 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2355 posn = PerlIO_tell(PerlIONext(f));
2356 if (posn != (Off_t) -1)
2360 return PerlIOBase_pushed(f,mode,arg);
2364 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)
2368 PerlIO *next = PerlIONext(f);
2369 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2370 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2371 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2378 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2385 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2388 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2389 fd = PerlIO_fileno(f);
2390 #if O_BINARY != O_TEXT
2391 /* do something about failing setmode()? --jhi */
2392 PerlLIO_setmode(fd , O_BINARY);
2394 if (init && fd == 2)
2396 /* Initial stderr is unbuffered */
2397 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2404 /* This "flush" is akin to sfio's sync in that it handles files in either
2408 PerlIOBuf_flush(PerlIO *f)
2410 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2412 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2414 /* write() the buffer */
2415 STDCHAR *buf = b->buf;
2417 PerlIO *n = PerlIONext(f);
2420 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2425 else if (count < 0 || PerlIO_error(n))
2427 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2432 b->posn += (p - buf);
2434 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2436 STDCHAR *buf = PerlIO_get_base(f);
2437 /* Note position change */
2438 b->posn += (b->ptr - buf);
2439 if (b->ptr < b->end)
2441 /* We did not consume all of it */
2442 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2444 b->posn = PerlIO_tell(PerlIONext(f));
2448 b->ptr = b->end = b->buf;
2449 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2450 /* FIXME: Is this right for read case ? */
2451 if (PerlIO_flush(PerlIONext(f)) != 0)
2457 PerlIOBuf_fill(PerlIO *f)
2459 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2460 PerlIO *n = PerlIONext(f);
2462 /* FIXME: doing the down-stream flush is a bad idea if it causes
2463 pre-read data in stdio buffer to be discarded
2464 but this is too simplistic - as it skips _our_ hosekeeping
2465 and breaks tell tests.
2466 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2470 if (PerlIO_flush(f) != 0)
2472 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2473 PerlIOBase_flush_linebuf();
2476 PerlIO_get_base(f); /* allocate via vtable */
2478 b->ptr = b->end = b->buf;
2479 if (PerlIO_fast_gets(n))
2481 /* Layer below is also buffered
2482 * We do _NOT_ want to call its ->Read() because that will loop
2483 * till it gets what we asked for which may hang on a pipe etc.
2484 * Instead take anything it has to hand, or ask it to fill _once_.
2486 avail = PerlIO_get_cnt(n);
2489 avail = PerlIO_fill(n);
2491 avail = PerlIO_get_cnt(n);
2494 if (!PerlIO_error(n) && PerlIO_eof(n))
2500 STDCHAR *ptr = PerlIO_get_ptr(n);
2501 SSize_t cnt = avail;
2502 if (avail > b->bufsiz)
2504 Copy(ptr,b->buf,avail,STDCHAR);
2505 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2510 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2515 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2517 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2520 b->end = b->buf+avail;
2521 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2526 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2528 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2533 return PerlIOBase_read(f,vbuf,count);
2539 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2541 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2542 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2545 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2551 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2553 avail = (b->ptr - b->buf);
2558 b->end = b->buf + avail;
2560 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2561 b->posn -= b->bufsiz;
2563 if (avail > (SSize_t) count)
2571 Copy(buf,b->ptr,avail,STDCHAR);
2575 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2582 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2584 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2585 const STDCHAR *buf = (const STDCHAR *) vbuf;
2589 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2593 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2594 if ((SSize_t) count < avail)
2596 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2597 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2617 Copy(buf,b->ptr,avail,STDCHAR);
2624 if (b->ptr >= (b->buf + b->bufsiz))
2627 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2633 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2636 if ((code = PerlIO_flush(f)) == 0)
2638 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2639 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2640 code = PerlIO_seek(PerlIONext(f),offset,whence);
2643 b->posn = PerlIO_tell(PerlIONext(f));
2650 PerlIOBuf_tell(PerlIO *f)
2652 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2653 Off_t posn = b->posn;
2655 posn += (b->ptr - b->buf);
2660 PerlIOBuf_close(PerlIO *f)
2663 IV code = PerlIOBase_close(f);
2664 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2665 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2667 PerlMemShared_free(b->buf);
2670 b->ptr = b->end = b->buf;
2671 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2676 PerlIOBuf_get_ptr(PerlIO *f)
2678 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2685 PerlIOBuf_get_cnt(PerlIO *f)
2687 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2690 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2691 return (b->end - b->ptr);
2696 PerlIOBuf_get_base(PerlIO *f)
2698 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2704 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2707 b->buf = (STDCHAR *)&b->oneword;
2708 b->bufsiz = sizeof(b->oneword);
2717 PerlIOBuf_bufsiz(PerlIO *f)
2719 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2722 return (b->end - b->buf);
2726 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2728 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2732 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2735 assert(PerlIO_get_cnt(f) == cnt);
2736 assert(b->ptr >= b->buf);
2738 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2741 PerlIO_funcs PerlIO_perlio = {
2760 PerlIOBase_clearerr,
2761 PerlIOBase_setlinebuf,
2766 PerlIOBuf_set_ptrcnt,
2769 /*--------------------------------------------------------------------------------------*/
2770 /* Temp layer to hold unread chars when cannot do it any other way */
2773 PerlIOPending_fill(PerlIO *f)
2775 /* Should never happen */
2781 PerlIOPending_close(PerlIO *f)
2783 /* A tad tricky - flush pops us, then we close new top */
2785 return PerlIO_close(f);
2789 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2791 /* A tad tricky - flush pops us, then we seek new top */
2793 return PerlIO_seek(f,offset,whence);
2798 PerlIOPending_flush(PerlIO *f)
2801 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2802 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2804 PerlMemShared_free(b->buf);
2807 PerlIO_pop(aTHX_ f);
2812 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2820 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2825 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2827 IV code = PerlIOBase_pushed(f,mode,arg);
2828 PerlIOl *l = PerlIOBase(f);
2829 /* Our PerlIO_fast_gets must match what we are pushed on,
2830 or sv_gets() etc. get muddled when it changes mid-string
2833 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2834 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2839 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2841 SSize_t avail = PerlIO_get_cnt(f);
2846 got = PerlIOBuf_read(f,vbuf,avail);
2847 if (got >= 0 && got < count)
2849 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2850 if (more >= 0 || got == 0)
2856 PerlIO_funcs PerlIO_pending = {
2860 PerlIOPending_pushed,
2870 PerlIOPending_close,
2871 PerlIOPending_flush,
2875 PerlIOBase_clearerr,
2876 PerlIOBase_setlinebuf,
2881 PerlIOPending_set_ptrcnt,
2886 /*--------------------------------------------------------------------------------------*/
2887 /* crlf - translation
2888 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2889 to hand back a line at a time and keeping a record of which nl we "lied" about.
2890 On write translate "\n" to CR,LF
2895 PerlIOBuf base; /* PerlIOBuf stuff */
2896 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2900 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2903 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2904 code = PerlIOBuf_pushed(f,mode,arg);
2906 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2907 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2908 PerlIOBase(f)->flags);
2915 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2917 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2923 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2924 return PerlIOBuf_unread(f,vbuf,count);
2927 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2930 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2936 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2938 b->end = b->ptr = b->buf + b->bufsiz;
2939 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2940 b->posn -= b->bufsiz;
2942 while (count > 0 && b->ptr > b->buf)
2947 if (b->ptr - 2 >= b->buf)
2973 PerlIOCrlf_get_cnt(PerlIO *f)
2975 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2978 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2980 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2981 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2983 STDCHAR *nl = b->ptr;
2985 while (nl < b->end && *nl != 0xd)
2987 if (nl < b->end && *nl == 0xd)
2999 /* Not CR,LF but just CR */
3006 /* Blast - found CR as last char in buffer */
3009 /* They may not care, defer work as long as possible */
3010 return (nl - b->ptr);
3016 b->ptr++; /* say we have read it as far as flush() is concerned */
3017 b->buf++; /* Leave space an front of buffer */
3018 b->bufsiz--; /* Buffer is thus smaller */
3019 code = PerlIO_fill(f); /* Fetch some more */
3020 b->bufsiz++; /* Restore size for next time */
3021 b->buf--; /* Point at space */
3022 b->ptr = nl = b->buf; /* Which is what we hand off */
3023 b->posn--; /* Buffer starts here */
3024 *nl = 0xd; /* Fill in the CR */
3026 goto test; /* fill() call worked */
3027 /* CR at EOF - just fall through */
3032 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3038 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3040 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3041 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3042 IV flags = PerlIOBase(f)->flags;
3052 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3059 /* Test code - delete when it works ... */
3066 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3074 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3075 ptr, chk, flags, c->nl, b->end, cnt);
3082 /* They have taken what we lied about */
3089 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3093 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3095 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3096 return PerlIOBuf_write(f,vbuf,count);
3099 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3100 const STDCHAR *buf = (const STDCHAR *) vbuf;
3101 const STDCHAR *ebuf = buf+count;
3104 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3108 STDCHAR *eptr = b->buf+b->bufsiz;
3109 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3110 while (buf < ebuf && b->ptr < eptr)
3114 if ((b->ptr + 2) > eptr)
3116 /* Not room for both */
3122 *(b->ptr)++ = 0xd; /* CR */
3123 *(b->ptr)++ = 0xa; /* LF */
3125 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3144 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3146 return (buf - (STDCHAR *) vbuf);
3151 PerlIOCrlf_flush(PerlIO *f)
3153 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3159 return PerlIOBuf_flush(f);
3162 PerlIO_funcs PerlIO_crlf = {
3165 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3167 PerlIOBase_noop_ok, /* popped */
3171 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3172 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3173 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3181 PerlIOBase_clearerr,
3182 PerlIOBase_setlinebuf,
3187 PerlIOCrlf_set_ptrcnt,
3191 /*--------------------------------------------------------------------------------------*/
3192 /* mmap as "buffer" layer */
3196 PerlIOBuf base; /* PerlIOBuf stuff */
3197 Mmap_t mptr; /* Mapped address */
3198 Size_t len; /* mapped length */
3199 STDCHAR *bbuf; /* malloced buffer if map fails */
3202 static size_t page_size = 0;
3205 PerlIOMmap_map(PerlIO *f)
3208 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3209 PerlIOBuf *b = &m->base;
3210 IV flags = PerlIOBase(f)->flags;
3214 if (flags & PERLIO_F_CANREAD)
3216 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3217 int fd = PerlIO_fileno(f);
3219 code = fstat(fd,&st);
3220 if (code == 0 && S_ISREG(st.st_mode))
3222 SSize_t len = st.st_size - b->posn;
3227 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3229 SETERRNO(0,SS$_NORMAL);
3230 # ifdef _SC_PAGESIZE
3231 page_size = sysconf(_SC_PAGESIZE);
3233 page_size = sysconf(_SC_PAGE_SIZE);
3235 if ((long)page_size < 0) {
3240 (void)SvUPGRADE(error, SVt_PV);
3241 msg = SvPVx(error, n_a);
3242 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3245 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3249 # ifdef HAS_GETPAGESIZE
3250 page_size = getpagesize();
3252 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3253 page_size = PAGESIZE; /* compiletime, bad */
3257 if ((IV)page_size <= 0)
3258 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3262 /* This is a hack - should never happen - open should have set it ! */
3263 b->posn = PerlIO_tell(PerlIONext(f));
3265 posn = (b->posn / page_size) * page_size;
3266 len = st.st_size - posn;
3267 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3268 if (m->mptr && m->mptr != (Mmap_t) -1)
3270 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3271 madvise(m->mptr, len, MADV_SEQUENTIAL);
3273 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3274 madvise(m->mptr, len, MADV_WILLNEED);
3276 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3277 b->end = ((STDCHAR *)m->mptr) + len;
3278 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3289 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3291 b->ptr = b->end = b->ptr;
3300 PerlIOMmap_unmap(PerlIO *f)
3302 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3303 PerlIOBuf *b = &m->base;
3309 code = munmap(m->mptr, m->len);
3313 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3316 b->ptr = b->end = b->buf;
3317 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3323 PerlIOMmap_get_base(PerlIO *f)
3325 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3326 PerlIOBuf *b = &m->base;
3327 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3329 /* Already have a readbuffer in progress */
3334 /* We have a write buffer or flushed PerlIOBuf read buffer */
3335 m->bbuf = b->buf; /* save it in case we need it again */
3336 b->buf = NULL; /* Clear to trigger below */
3340 PerlIOMmap_map(f); /* Try and map it */
3343 /* Map did not work - recover PerlIOBuf buffer if we have one */
3347 b->ptr = b->end = b->buf;
3350 return PerlIOBuf_get_base(f);
3354 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3356 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3357 PerlIOBuf *b = &m->base;
3358 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3360 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3363 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3368 /* Loose the unwritable mapped buffer */
3370 /* If flush took the "buffer" see if we have one from before */
3371 if (!b->buf && m->bbuf)
3375 PerlIOBuf_get_base(f);
3379 return PerlIOBuf_unread(f,vbuf,count);
3383 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3385 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3386 PerlIOBuf *b = &m->base;
3387 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3389 /* No, or wrong sort of, buffer */
3392 if (PerlIOMmap_unmap(f) != 0)
3395 /* If unmap took the "buffer" see if we have one from before */
3396 if (!b->buf && m->bbuf)
3400 PerlIOBuf_get_base(f);
3404 return PerlIOBuf_write(f,vbuf,count);
3408 PerlIOMmap_flush(PerlIO *f)
3410 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3411 PerlIOBuf *b = &m->base;
3412 IV code = PerlIOBuf_flush(f);
3413 /* Now we are "synced" at PerlIOBuf level */
3418 /* Unmap the buffer */
3419 if (PerlIOMmap_unmap(f) != 0)
3424 /* We seem to have a PerlIOBuf buffer which was not mapped
3425 * remember it in case we need one later
3434 PerlIOMmap_fill(PerlIO *f)
3436 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3437 IV code = PerlIO_flush(f);
3438 if (code == 0 && !b->buf)
3440 code = PerlIOMmap_map(f);
3442 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3444 code = PerlIOBuf_fill(f);
3450 PerlIOMmap_close(PerlIO *f)
3452 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3453 PerlIOBuf *b = &m->base;
3454 IV code = PerlIO_flush(f);
3459 b->ptr = b->end = b->buf;
3461 if (PerlIOBuf_close(f) != 0)
3467 PerlIO_funcs PerlIO_mmap = {
3486 PerlIOBase_clearerr,
3487 PerlIOBase_setlinebuf,
3488 PerlIOMmap_get_base,
3492 PerlIOBuf_set_ptrcnt,
3495 #endif /* HAS_MMAP */
3503 atexit(&PerlIO_cleanup);
3515 PerlIO_stdstreams(aTHX);
3520 #undef PerlIO_stdout
3527 PerlIO_stdstreams(aTHX);
3532 #undef PerlIO_stderr
3539 PerlIO_stdstreams(aTHX);
3544 /*--------------------------------------------------------------------------------------*/
3546 #undef PerlIO_getname
3548 PerlIO_getname(PerlIO *f, char *buf)
3551 Perl_croak(aTHX_ "Don't know how to get file name");
3556 /*--------------------------------------------------------------------------------------*/
3557 /* Functions which can be called on any kind of PerlIO implemented
3563 PerlIO_getc(PerlIO *f)
3566 SSize_t count = PerlIO_read(f,buf,1);
3569 return (unsigned char) buf[0];
3574 #undef PerlIO_ungetc
3576 PerlIO_ungetc(PerlIO *f, int ch)
3581 if (PerlIO_unread(f,&buf,1) == 1)
3589 PerlIO_putc(PerlIO *f, int ch)
3592 return PerlIO_write(f,&buf,1);
3597 PerlIO_puts(PerlIO *f, const char *s)
3599 STRLEN len = strlen(s);
3600 return PerlIO_write(f,s,len);
3603 #undef PerlIO_rewind
3605 PerlIO_rewind(PerlIO *f)
3607 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3611 #undef PerlIO_vprintf
3613 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3616 SV *sv = newSVpvn("",0);
3622 Perl_va_copy(ap, apc);
3623 sv_vcatpvf(sv, fmt, &apc);
3625 sv_vcatpvf(sv, fmt, &ap);
3628 wrote = PerlIO_write(f,s,len);
3633 #undef PerlIO_printf
3635 PerlIO_printf(PerlIO *f,const char *fmt,...)
3640 result = PerlIO_vprintf(f,fmt,ap);
3645 #undef PerlIO_stdoutf
3647 PerlIO_stdoutf(const char *fmt,...)
3652 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3657 #undef PerlIO_tmpfile
3659 PerlIO_tmpfile(void)
3661 /* I have no idea how portable mkstemp() is ... */
3662 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3665 FILE *stdio = PerlSIO_tmpfile();
3668 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3674 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3675 int fd = mkstemp(SvPVX(sv));
3679 f = PerlIO_fdopen(fd,"w+");
3682 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3684 PerlLIO_unlink(SvPVX(sv));
3694 #endif /* USE_SFIO */
3695 #endif /* PERLIO_IS_STDIO */
3697 /*======================================================================================*/
3698 /* Now some functions in terms of above which may be needed even if
3699 we are not in true PerlIO mode
3703 #undef PerlIO_setpos
3705 PerlIO_setpos(PerlIO *f, SV *pos)
3711 Off_t *posn = (Off_t *) SvPV(pos,len);
3712 if (f && len == sizeof(Off_t))
3713 return PerlIO_seek(f,*posn,SEEK_SET);
3719 #undef PerlIO_setpos
3721 PerlIO_setpos(PerlIO *f, SV *pos)
3727 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3728 if (f && len == sizeof(Fpos_t))
3730 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3731 return fsetpos64(f, fpos);
3733 return fsetpos(f, fpos);
3743 #undef PerlIO_getpos
3745 PerlIO_getpos(PerlIO *f, SV *pos)
3748 Off_t posn = PerlIO_tell(f);
3749 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3750 return (posn == (Off_t)-1) ? -1 : 0;
3753 #undef PerlIO_getpos
3755 PerlIO_getpos(PerlIO *f, SV *pos)
3760 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3761 code = fgetpos64(f, &fpos);
3763 code = fgetpos(f, &fpos);
3765 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3770 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3773 vprintf(char *pat, char *args)
3775 _doprnt(pat, args, stdout);
3776 return 0; /* wrong, but perl doesn't use the return value */
3780 vfprintf(FILE *fd, char *pat, char *args)
3782 _doprnt(pat, args, fd);
3783 return 0; /* wrong, but perl doesn't use the return value */
3788 #ifndef PerlIO_vsprintf
3790 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3792 int val = vsprintf(s, fmt, ap);
3795 if (strlen(s) >= (STRLEN)n)
3798 (void)PerlIO_puts(Perl_error_log,
3799 "panic: sprintf overflow - memory corrupted!\n");
3807 #ifndef PerlIO_sprintf
3809 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3814 result = PerlIO_vsprintf(s, n, fmt, ap);