3 * Copyright (c) 1996-2001, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
37 perlsio_binmode(FILE *fp, int iotype, int mode)
39 /* This used to be contents of do_binmode in doio.c */
41 # if defined(atarist) || defined(__MINT__)
44 ((FILE*)fp)->_flag |= _IOBIN;
46 ((FILE*)fp)->_flag &= ~ _IOBIN;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
53 # if defined(WIN32) && defined(__BORLANDC__)
54 /* The translation mode of the stream is maintained independent
55 * of the translation mode of the fd in the Borland RTL (heavy
56 * digging through their runtime sources reveal). User has to
57 * set the mode explicitly for the stream (though they don't
58 * document this anywhere). GSAR 97-5-24
64 fp->flags &= ~ _F_BIN;
72 # if defined(USEMYBINMODE)
73 if (my_binmode(fp, iotype, mode) != FALSE)
85 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
87 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
91 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
102 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
104 return perlsio_binmode(fp,iotype,mode);
107 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
110 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
114 if (*args == &PL_sv_undef)
115 return PerlIO_tmpfile();
118 char *name = SvPV_nolen(*args);
121 fd = PerlLIO_open3(name,imode,perm);
123 return PerlIO_fdopen(fd,mode+1);
127 return PerlIO_reopen(name,mode,old);
131 return PerlIO_open(name,mode);
137 return PerlIO_fdopen(fd,mode);
145 #ifdef PERLIO_IS_STDIO
150 /* Does nothing (yet) except force this file to be included
151 in perl binary. That allows this file to force inclusion
152 of other functions that may be required by loadable
153 extensions e.g. for FileHandle::tmpfile
157 #undef PerlIO_tmpfile
164 #else /* PERLIO_IS_STDIO */
171 /* This section is just to make sure these functions
172 get pulled in from libsfio.a
175 #undef PerlIO_tmpfile
185 /* Force this file to be included in perl binary. Which allows
186 * this file to force inclusion of other functions that may be
187 * required by loadable extensions e.g. for FileHandle::tmpfile
191 * sfio does its own 'autoflush' on stdout in common cases.
192 * Flush results in a lot of lseek()s to regular files and
193 * lot of small writes to pipes.
195 sfset(sfstdout,SF_SHARE,0);
199 /*======================================================================================*/
200 /* Implement all the PerlIO interface ourselves.
205 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
210 #include <sys/mman.h>
215 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
218 PerlIO_debug(const char *fmt,...)
226 char *s = PerlEnv_getenv("PERLIO_DEBUG");
228 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
235 SV *sv = newSVpvn("",0);
238 s = CopFILE(PL_curcop);
241 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
242 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
245 PerlLIO_write(dbg,s,len);
251 /*--------------------------------------------------------------------------------------*/
253 /* Inner level routines */
255 /* Table of pointers to the PerlIO structs (malloc'ed) */
256 PerlIO *_perlio = NULL;
257 #define PERLIO_TABLE_SIZE 64
262 PerlIO_allocate(pTHX)
264 /* Find a free slot in the table, allocating new table as necessary */
271 last = (PerlIO **)(f);
272 for (i=1; i < PERLIO_TABLE_SIZE; i++)
280 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
290 PerlIO_cleantable(pTHX_ PerlIO **tablep)
292 PerlIO *table = *tablep;
296 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
297 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
305 PerlMemShared_free(table);
317 PerlIO_cleantable(aTHX_ &_perlio);
321 PerlIO_destruct(pTHX)
323 PerlIO **table = &_perlio;
328 table = (PerlIO **)(f++);
329 for (i=1; i < PERLIO_TABLE_SIZE; i++)
335 if (l->tab->kind & PERLIO_K_DESTRUCT)
337 PerlIO_debug("Destruct popping %s\n",l->tab->name);
352 PerlIO_pop(pTHX_ PerlIO *f)
357 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
359 (*l->tab->Popped)(f);
361 PerlMemShared_free(l);
365 /*--------------------------------------------------------------------------------------*/
366 /* XS Interface for perl code */
369 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
373 if ((SSize_t) len <= 0)
375 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
376 if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2)
378 SV *pkgsv = newSVpvn("PerlIO",6);
379 SV *layer = newSVpvn(name,len);
381 /* The two SVs are magically freed by load_module */
382 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
384 /* Say this is lvalue so we get an 'undef' if still not there */
385 svp = hv_fetch(PerlIO_layer_hv,name,len,1);
387 if (svp && (sv = *svp))
397 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
401 IO *io = GvIOn((GV *)SvRV(sv));
402 PerlIO *ifp = IoIFP(io);
403 PerlIO *ofp = IoOFP(io);
404 AV *av = (AV *) mg->mg_obj;
405 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
411 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
415 IO *io = GvIOn((GV *)SvRV(sv));
416 PerlIO *ifp = IoIFP(io);
417 PerlIO *ofp = IoOFP(io);
418 AV *av = (AV *) mg->mg_obj;
419 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
425 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
427 Perl_warn(aTHX_ "clear %"SVf,sv);
432 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
434 Perl_warn(aTHX_ "free %"SVf,sv);
438 MGVTBL perlio_vtab = {
446 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
449 SV *sv = SvRV(ST(1));
454 sv_magic(sv, (SV *)av, '~', NULL, 0);
456 mg = mg_find(sv,'~');
457 mg->mg_virtual = &perlio_vtab;
459 Perl_warn(aTHX_ "attrib %"SVf,sv);
460 for (i=2; i < items; i++)
463 const char *name = SvPV(ST(i),len);
464 SV *layer = PerlIO_find_layer(aTHX_ name,len,1);
467 av_push(av,SvREFCNT_inc(layer));
480 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
482 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
483 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
488 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
490 if (!PerlIO_layer_hv)
492 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
494 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0);
495 PerlIO_debug("define %s %p\n",tab->name,tab);
499 PerlIO_parse_layers(pTHX_ AV *av, const char *names)
503 const char *s = names;
506 while (isSPACE(*s) || *s == ':')
512 const char *as = Nullch;
516 /* Message is consistent with how attribute lists are passed.
517 Even though this means "foo : : bar" is seen as an invalid separator
519 char q = ((*s == '\'') ? '"' : '\'');
520 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
526 } while (isALNUM(*e));
544 /* It's a nul terminated string, not allowed to \ the terminating null.
545 Anything other character is passed over. */
553 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
563 SV *layer = PerlIO_find_layer(aTHX_ s,llen,1);
566 av_push(av,SvREFCNT_inc(layer));
567 av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef);
570 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
582 PerlIO_default_buffer(pTHX_ AV *av)
584 PerlIO_funcs *tab = &PerlIO_perlio;
585 if (O_BINARY != O_TEXT)
591 if (PerlIO_stdio.Set_ptrcnt)
596 PerlIO_debug("Pushing %s\n",tab->name);
597 av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0)));
598 av_push(av,&PL_sv_undef);
602 PerlIO_arg_fetch(pTHX_ AV *av,IV n)
604 SV **svp = av_fetch(av,n,FALSE);
605 return (svp) ? *svp : Nullsv;
609 PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def)
611 SV **svp = av_fetch(av,n,FALSE);
613 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
615 /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */
616 return INT2PTR(PerlIO_funcs *, SvIV(layer));
619 Perl_croak(aTHX_ "panic:PerlIO layer array corrupt");
624 PerlIO_default_layers(pTHX)
627 if (!PerlIO_layer_av)
629 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
630 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
632 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
634 PerlIO_define_layer(aTHX_ &PerlIO_raw);
635 PerlIO_define_layer(aTHX_ &PerlIO_unix);
636 PerlIO_define_layer(aTHX_ &PerlIO_perlio);
637 PerlIO_define_layer(aTHX_ &PerlIO_stdio);
638 PerlIO_define_layer(aTHX_ &PerlIO_crlf);
640 PerlIO_define_layer(aTHX_ &PerlIO_mmap);
642 PerlIO_define_layer(aTHX_ &PerlIO_utf8);
643 PerlIO_define_layer(aTHX_ &PerlIO_byte);
644 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0)));
645 av_push(PerlIO_layer_av,&PL_sv_undef);
648 PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s);
652 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
655 len = av_len(PerlIO_layer_av)+1;
658 PerlIO_default_buffer(aTHX_ PerlIO_layer_av);
659 len = av_len(PerlIO_layer_av);
661 return PerlIO_layer_av;
666 PerlIO_default_layer(pTHX_ I32 n)
668 AV *av = PerlIO_default_layers(aTHX);
671 n += av_len(PerlIO_layer_av)+1;
672 return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio);
675 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
676 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
679 PerlIO_stdstreams(pTHX)
683 PerlIO_allocate(aTHX);
684 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
685 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
686 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
691 PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg)
694 l = PerlMemShared_calloc(tab->size,sizeof(char));
697 Zero(l,tab->size,char);
701 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name,
702 (mode) ? mode : "(Null)",arg);
703 if ((*l->tab->Pushed)(f,mode,arg) != 0)
713 PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg)
727 PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg)
729 /* Remove the dummy layer */
732 /* Pop back to bottom layer */
737 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
745 /* Nothing bellow - push unix on top then remove it */
746 if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg))
748 PerlIO_pop(aTHX_ PerlIONext(f));
753 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
760 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n)
762 IV max = av_len(layers)+1;
766 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL);
769 if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg))
781 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
786 AV *layers = newAV();
787 code = PerlIO_parse_layers(aTHX_ layers,names);
790 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0);
792 SvREFCNT_dec((SV *) layers);
798 /*--------------------------------------------------------------------------------------*/
799 /* Given the abstraction above the public API functions */
802 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
804 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
805 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
806 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
812 if (PerlIOBase(top)->tab == &PerlIO_crlf)
815 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
818 top = PerlIONext(top);
821 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
826 PerlIO__close(PerlIO *f)
828 return (*PerlIOBase(f)->tab->Close)(f);
831 #undef PerlIO_fdupopen
833 PerlIO_fdupopen(pTHX_ PerlIO *f)
836 int fd = PerlLIO_dup(PerlIO_fileno(f));
837 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
840 Off_t posn = PerlIO_tell(f);
841 PerlIO_seek(new,posn,SEEK_SET);
848 PerlIO_close(PerlIO *f)
854 code = (*PerlIOBase(f)->tab->Close)(f);
865 PerlIO_fileno(PerlIO *f)
867 return (*PerlIOBase(f)->tab->Fileno)(f);
871 PerlIO_context_layers(pTHX_ const char *mode)
873 const char *type = NULL;
874 /* Need to supply default layer info from open.pm */
877 SV *layers = PL_curcop->cop_io;
881 type = SvPV(layers,len);
882 if (type && mode[0] != 'r')
884 /* Skip to write part */
885 const char *s = strchr(type,0);
886 if (s && (s-type) < len)
897 PerlIO_layer_from_ref(pTHX_ SV *sv)
899 /* For any scalar type load the handler which is bundled with perl */
900 if (SvTYPE(sv) < SVt_PVAV)
901 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
903 /* For other types allow if layer is known but don't try and load it */
907 return PerlIO_find_layer(aTHX_ "Array",5, 0);
909 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
911 return PerlIO_find_layer(aTHX_ "Code",4, 0);
913 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
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);
928 /* If it is a reference but not an object see if we have a handler for it */
929 if (SvROK(arg) && !sv_isobject(arg))
931 SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
935 av_push(def,SvREFCNT_inc(handler));
936 av_push(def,&PL_sv_undef);
939 /* Don't fail if handler cannot be found
940 * :Via(...) etc. may do something sensible
941 * else we will just stringfy and open resulting string.
946 layers = PerlIO_context_layers(aTHX_ mode);
947 if (layers && *layers)
952 IV n = av_len(def)+1;
956 SV **svp = av_fetch(def,n,0);
957 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
964 PerlIO_parse_layers(aTHX_ av,layers);
976 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
978 if (!f && narg == 1 && *args == &PL_sv_undef)
980 if ((f = PerlIO_tmpfile()))
983 layers = PerlIO_context_layers(aTHX_ mode);
984 if (layers && *layers)
985 PerlIO_apply_layers(aTHX_ f,mode,layers);
995 /* This is "reopen" - it is not tested as perl does not use it yet */
1000 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1001 av_unshift(layera,2);
1002 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1003 av_store(layera,1,arg);
1004 l = *PerlIONext(&l);
1009 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1011 n = av_len(layera)-1;
1014 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1024 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1025 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1026 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1029 if (n+2 < av_len(layera)+1)
1031 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1038 SvREFCNT_dec(layera);
1044 #undef PerlIO_fdopen
1046 PerlIO_fdopen(int fd, const char *mode)
1049 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1054 PerlIO_open(const char *path, const char *mode)
1057 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1058 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1061 #undef PerlIO_reopen
1063 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1066 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1067 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1072 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1074 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1077 #undef PerlIO_unread
1079 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1081 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1086 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1088 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1093 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1095 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1100 PerlIO_tell(PerlIO *f)
1102 return (*PerlIOBase(f)->tab->Tell)(f);
1107 PerlIO_flush(PerlIO *f)
1111 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1112 if (tab && tab->Flush)
1114 return (*tab->Flush)(f);
1118 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1125 PerlIO **table = &_perlio;
1127 while ((f = *table))
1130 table = (PerlIO **)(f++);
1131 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1133 if (*f && PerlIO_flush(f) != 0)
1143 PerlIOBase_flush_linebuf()
1145 PerlIO **table = &_perlio;
1147 while ((f = *table))
1150 table = (PerlIO **)(f++);
1151 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1153 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1154 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1163 PerlIO_fill(PerlIO *f)
1165 return (*PerlIOBase(f)->tab->Fill)(f);
1168 #undef PerlIO_isutf8
1170 PerlIO_isutf8(PerlIO *f)
1172 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1177 PerlIO_eof(PerlIO *f)
1179 return (*PerlIOBase(f)->tab->Eof)(f);
1184 PerlIO_error(PerlIO *f)
1186 return (*PerlIOBase(f)->tab->Error)(f);
1189 #undef PerlIO_clearerr
1191 PerlIO_clearerr(PerlIO *f)
1194 (*PerlIOBase(f)->tab->Clearerr)(f);
1197 #undef PerlIO_setlinebuf
1199 PerlIO_setlinebuf(PerlIO *f)
1201 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1204 #undef PerlIO_has_base
1206 PerlIO_has_base(PerlIO *f)
1210 return (PerlIOBase(f)->tab->Get_base != NULL);
1215 #undef PerlIO_fast_gets
1217 PerlIO_fast_gets(PerlIO *f)
1219 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1221 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1222 return (tab->Set_ptrcnt != NULL);
1227 #undef PerlIO_has_cntptr
1229 PerlIO_has_cntptr(PerlIO *f)
1233 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1234 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1239 #undef PerlIO_canset_cnt
1241 PerlIO_canset_cnt(PerlIO *f)
1245 PerlIOl *l = PerlIOBase(f);
1246 return (l->tab->Set_ptrcnt != NULL);
1251 #undef PerlIO_get_base
1253 PerlIO_get_base(PerlIO *f)
1255 return (*PerlIOBase(f)->tab->Get_base)(f);
1258 #undef PerlIO_get_bufsiz
1260 PerlIO_get_bufsiz(PerlIO *f)
1262 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1265 #undef PerlIO_get_ptr
1267 PerlIO_get_ptr(PerlIO *f)
1269 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1270 if (tab->Get_ptr == NULL)
1272 return (*tab->Get_ptr)(f);
1275 #undef PerlIO_get_cnt
1277 PerlIO_get_cnt(PerlIO *f)
1279 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1280 if (tab->Get_cnt == NULL)
1282 return (*tab->Get_cnt)(f);
1285 #undef PerlIO_set_cnt
1287 PerlIO_set_cnt(PerlIO *f,int cnt)
1289 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1292 #undef PerlIO_set_ptrcnt
1294 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1296 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1297 if (tab->Set_ptrcnt == NULL)
1300 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1302 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1305 /*--------------------------------------------------------------------------------------*/
1306 /* utf8 and raw dummy layers */
1309 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1314 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1315 PerlIO_pop(aTHX_ f);
1316 if (tab->kind & PERLIO_K_UTF8)
1317 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1319 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1325 PerlIO_funcs PerlIO_utf8 = {
1328 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1346 NULL, /* get_base */
1347 NULL, /* get_bufsiz */
1350 NULL, /* set_ptrcnt */
1353 PerlIO_funcs PerlIO_byte = {
1374 NULL, /* get_base */
1375 NULL, /* get_bufsiz */
1378 NULL, /* set_ptrcnt */
1382 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)
1384 PerlIO_funcs *tab = PerlIO_default_btm();
1385 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1388 PerlIO_funcs PerlIO_raw = {
1409 NULL, /* get_base */
1410 NULL, /* get_bufsiz */
1413 NULL, /* set_ptrcnt */
1415 /*--------------------------------------------------------------------------------------*/
1416 /*--------------------------------------------------------------------------------------*/
1417 /* "Methods" of the "base class" */
1420 PerlIOBase_fileno(PerlIO *f)
1422 return PerlIO_fileno(PerlIONext(f));
1426 PerlIO_modestr(PerlIO *f,char *buf)
1429 IV flags = PerlIOBase(f)->flags;
1430 if (flags & PERLIO_F_APPEND)
1433 if (flags & PERLIO_F_CANREAD)
1438 else if (flags & PERLIO_F_CANREAD)
1441 if (flags & PERLIO_F_CANWRITE)
1444 else if (flags & PERLIO_F_CANWRITE)
1447 if (flags & PERLIO_F_CANREAD)
1452 #if O_TEXT != O_BINARY
1453 if (!(flags & PERLIO_F_CRLF))
1461 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1463 PerlIOl *l = PerlIOBase(f);
1464 const char *omode = mode;
1466 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1467 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1468 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1469 if (tab->Set_ptrcnt != NULL)
1470 l->flags |= PERLIO_F_FASTGETS;
1476 l->flags |= PERLIO_F_CANREAD;
1479 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1482 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1493 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1496 l->flags &= ~PERLIO_F_CRLF;
1499 l->flags |= PERLIO_F_CRLF;
1511 l->flags |= l->next->flags &
1512 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1516 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1517 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1518 l->flags,PerlIO_modestr(f,temp));
1524 PerlIOBase_popped(PerlIO *f)
1530 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1533 Off_t old = PerlIO_tell(f);
1535 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1536 done = PerlIOBuf_unread(f,vbuf,count);
1537 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1542 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1544 STDCHAR *buf = (STDCHAR *) vbuf;
1547 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1551 SSize_t avail = PerlIO_get_cnt(f);
1552 SSize_t take = (count < avail) ? count : avail;
1555 STDCHAR *ptr = PerlIO_get_ptr(f);
1556 Copy(ptr,buf,take,STDCHAR);
1557 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1561 if (count > 0 && avail <= 0)
1563 if (PerlIO_fill(f) != 0)
1567 return (buf - (STDCHAR *) vbuf);
1573 PerlIOBase_noop_ok(PerlIO *f)
1579 PerlIOBase_noop_fail(PerlIO *f)
1585 PerlIOBase_close(PerlIO *f)
1588 PerlIO *n = PerlIONext(f);
1589 if (PerlIO_flush(f) != 0)
1591 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1593 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1598 PerlIOBase_eof(PerlIO *f)
1602 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1608 PerlIOBase_error(PerlIO *f)
1612 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1618 PerlIOBase_clearerr(PerlIO *f)
1622 PerlIO *n = PerlIONext(f);
1623 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1630 PerlIOBase_setlinebuf(PerlIO *f)
1634 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1638 /*--------------------------------------------------------------------------------------*/
1639 /* Bottom-most level for UNIX-like case */
1643 struct _PerlIO base; /* The generic part */
1644 int fd; /* UNIX like file descriptor */
1645 int oflags; /* open/fcntl flags */
1649 PerlIOUnix_oflags(const char *mode)
1664 oflags = O_CREAT|O_TRUNC;
1675 oflags = O_CREAT|O_APPEND;
1691 else if (*mode == 't')
1694 oflags &= ~O_BINARY;
1697 /* Always open in binary mode */
1699 if (*mode || oflags == -1)
1708 PerlIOUnix_fileno(PerlIO *f)
1710 return PerlIOSelf(f,PerlIOUnix)->fd;
1714 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1716 IV code = PerlIOBase_pushed(f,mode,arg);
1719 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1720 s->fd = PerlIO_fileno(PerlIONext(f));
1721 s->oflags = PerlIOUnix_oflags(mode);
1723 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1728 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)
1732 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1733 (*PerlIOBase(f)->tab->Close)(f);
1737 char *path = SvPV_nolen(*args);
1742 imode = PerlIOUnix_oflags(mode);
1747 fd = PerlLIO_open3(path,imode,perm);
1757 f = PerlIO_allocate(aTHX);
1758 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1761 s = PerlIOSelf(f,PerlIOUnix);
1764 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1771 /* FIXME: pop layers ??? */
1778 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1781 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1782 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1786 SSize_t len = PerlLIO_read(fd,vbuf,count);
1787 if (len >= 0 || errno != EINTR)
1790 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1791 else if (len == 0 && count != 0)
1792 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1800 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1803 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1806 SSize_t len = PerlLIO_write(fd,vbuf,count);
1807 if (len >= 0 || errno != EINTR)
1810 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1818 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1821 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1822 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1823 return (new == (Off_t) -1) ? -1 : 0;
1827 PerlIOUnix_tell(PerlIO *f)
1830 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1831 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1835 PerlIOUnix_close(PerlIO *f)
1838 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1840 while (PerlLIO_close(fd) != 0)
1851 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1856 PerlIO_funcs PerlIO_unix = {
1871 PerlIOBase_noop_ok, /* flush */
1872 PerlIOBase_noop_fail, /* fill */
1875 PerlIOBase_clearerr,
1876 PerlIOBase_setlinebuf,
1877 NULL, /* get_base */
1878 NULL, /* get_bufsiz */
1881 NULL, /* set_ptrcnt */
1884 /*--------------------------------------------------------------------------------------*/
1885 /* stdio as a layer */
1889 struct _PerlIO base;
1890 FILE * stdio; /* The stream */
1894 PerlIOStdio_fileno(PerlIO *f)
1897 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1901 PerlIOStdio_mode(const char *mode,char *tmode)
1908 if (O_BINARY != O_TEXT)
1916 /* This isn't used yet ... */
1918 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1923 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1925 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1931 return PerlIOBase_pushed(f,mode,arg);
1934 #undef PerlIO_importFILE
1936 PerlIO_importFILE(FILE *stdio, int fl)
1942 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1949 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)
1954 char *path = SvPV_nolen(*args);
1955 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1956 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1966 char *path = SvPV_nolen(*args);
1970 fd = PerlLIO_open3(path,imode,perm);
1974 FILE *stdio = PerlSIO_fopen(path,mode);
1977 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1978 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
1999 stdio = PerlSIO_stdin;
2002 stdio = PerlSIO_stdout;
2005 stdio = PerlSIO_stderr;
2011 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2015 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2025 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2028 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2032 STDCHAR *buf = (STDCHAR *) vbuf;
2033 /* Perl is expecting PerlIO_getc() to fill the buffer
2034 * Linux's stdio does not do that for fread()
2036 int ch = PerlSIO_fgetc(s);
2044 got = PerlSIO_fread(vbuf,1,count,s);
2049 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2052 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2053 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2057 int ch = *buf-- & 0xff;
2058 if (PerlSIO_ungetc(ch,s) != ch)
2067 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2070 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2074 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2077 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2078 return PerlSIO_fseek(stdio,offset,whence);
2082 PerlIOStdio_tell(PerlIO *f)
2085 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2086 return PerlSIO_ftell(stdio);
2090 PerlIOStdio_close(PerlIO *f)
2093 #ifdef HAS_SOCKS5_INIT
2094 int optval, optlen = sizeof(int);
2096 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2098 #ifdef HAS_SOCKS5_INIT
2099 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2100 PerlSIO_fclose(stdio) :
2101 close(PerlIO_fileno(f))
2103 PerlSIO_fclose(stdio)
2110 PerlIOStdio_flush(PerlIO *f)
2113 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2114 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2116 return PerlSIO_fflush(stdio);
2121 /* FIXME: This discards ungetc() and pre-read stuff which is
2122 not right if this is just a "sync" from a layer above
2123 Suspect right design is to do _this_ but not have layer above
2124 flush this layer read-to-read
2126 /* Not writeable - sync by attempting a seek */
2128 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2136 PerlIOStdio_fill(PerlIO *f)
2139 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2141 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2142 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2144 if (PerlSIO_fflush(stdio) != 0)
2147 c = PerlSIO_fgetc(stdio);
2148 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2154 PerlIOStdio_eof(PerlIO *f)
2157 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2161 PerlIOStdio_error(PerlIO *f)
2164 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2168 PerlIOStdio_clearerr(PerlIO *f)
2171 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2175 PerlIOStdio_setlinebuf(PerlIO *f)
2178 #ifdef HAS_SETLINEBUF
2179 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2181 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2187 PerlIOStdio_get_base(PerlIO *f)
2190 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2191 return PerlSIO_get_base(stdio);
2195 PerlIOStdio_get_bufsiz(PerlIO *f)
2198 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2199 return PerlSIO_get_bufsiz(stdio);
2203 #ifdef USE_STDIO_PTR
2205 PerlIOStdio_get_ptr(PerlIO *f)
2208 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2209 return PerlSIO_get_ptr(stdio);
2213 PerlIOStdio_get_cnt(PerlIO *f)
2216 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2217 return PerlSIO_get_cnt(stdio);
2221 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2224 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2227 #ifdef STDIO_PTR_LVALUE
2228 PerlSIO_set_ptr(stdio,ptr);
2229 #ifdef STDIO_PTR_LVAL_SETS_CNT
2230 if (PerlSIO_get_cnt(stdio) != (cnt))
2233 assert(PerlSIO_get_cnt(stdio) == (cnt));
2236 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2237 /* Setting ptr _does_ change cnt - we are done */
2240 #else /* STDIO_PTR_LVALUE */
2242 #endif /* STDIO_PTR_LVALUE */
2244 /* Now (or only) set cnt */
2245 #ifdef STDIO_CNT_LVALUE
2246 PerlSIO_set_cnt(stdio,cnt);
2247 #else /* STDIO_CNT_LVALUE */
2248 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2249 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2250 #else /* STDIO_PTR_LVAL_SETS_CNT */
2252 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2253 #endif /* STDIO_CNT_LVALUE */
2258 PerlIO_funcs PerlIO_stdio = {
2260 sizeof(PerlIOStdio),
2277 PerlIOStdio_clearerr,
2278 PerlIOStdio_setlinebuf,
2280 PerlIOStdio_get_base,
2281 PerlIOStdio_get_bufsiz,
2286 #ifdef USE_STDIO_PTR
2287 PerlIOStdio_get_ptr,
2288 PerlIOStdio_get_cnt,
2289 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2290 PerlIOStdio_set_ptrcnt
2291 #else /* STDIO_PTR_LVALUE */
2293 #endif /* STDIO_PTR_LVALUE */
2294 #else /* USE_STDIO_PTR */
2298 #endif /* USE_STDIO_PTR */
2301 #undef PerlIO_exportFILE
2303 PerlIO_exportFILE(PerlIO *f, int fl)
2307 stdio = fdopen(PerlIO_fileno(f),"r+");
2311 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2317 #undef PerlIO_findFILE
2319 PerlIO_findFILE(PerlIO *f)
2324 if (l->tab == &PerlIO_stdio)
2326 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2329 l = *PerlIONext(&l);
2331 return PerlIO_exportFILE(f,0);
2334 #undef PerlIO_releaseFILE
2336 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2340 /*--------------------------------------------------------------------------------------*/
2341 /* perlio buffer layer */
2344 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2346 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2347 int fd = PerlIO_fileno(f);
2350 if (fd >= 0 && PerlLIO_isatty(fd))
2352 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2354 posn = PerlIO_tell(PerlIONext(f));
2355 if (posn != (Off_t) -1)
2359 return PerlIOBase_pushed(f,mode,arg);
2363 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)
2367 PerlIO *next = PerlIONext(f);
2368 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2369 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2370 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2377 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2384 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2387 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2388 fd = PerlIO_fileno(f);
2389 #if O_BINARY != O_TEXT
2390 /* do something about failing setmode()? --jhi */
2391 PerlLIO_setmode(fd , O_BINARY);
2393 if (init && fd == 2)
2395 /* Initial stderr is unbuffered */
2396 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2403 /* This "flush" is akin to sfio's sync in that it handles files in either
2407 PerlIOBuf_flush(PerlIO *f)
2409 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2411 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2413 /* write() the buffer */
2414 STDCHAR *buf = b->buf;
2416 PerlIO *n = PerlIONext(f);
2419 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2424 else if (count < 0 || PerlIO_error(n))
2426 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2431 b->posn += (p - buf);
2433 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2435 STDCHAR *buf = PerlIO_get_base(f);
2436 /* Note position change */
2437 b->posn += (b->ptr - buf);
2438 if (b->ptr < b->end)
2440 /* We did not consume all of it */
2441 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2443 b->posn = PerlIO_tell(PerlIONext(f));
2447 b->ptr = b->end = b->buf;
2448 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2449 /* FIXME: Is this right for read case ? */
2450 if (PerlIO_flush(PerlIONext(f)) != 0)
2456 PerlIOBuf_fill(PerlIO *f)
2458 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2459 PerlIO *n = PerlIONext(f);
2461 /* FIXME: doing the down-stream flush is a bad idea if it causes
2462 pre-read data in stdio buffer to be discarded
2463 but this is too simplistic - as it skips _our_ hosekeeping
2464 and breaks tell tests.
2465 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2469 if (PerlIO_flush(f) != 0)
2471 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2472 PerlIOBase_flush_linebuf();
2475 PerlIO_get_base(f); /* allocate via vtable */
2477 b->ptr = b->end = b->buf;
2478 if (PerlIO_fast_gets(n))
2480 /* Layer below is also buffered
2481 * We do _NOT_ want to call its ->Read() because that will loop
2482 * till it gets what we asked for which may hang on a pipe etc.
2483 * Instead take anything it has to hand, or ask it to fill _once_.
2485 avail = PerlIO_get_cnt(n);
2488 avail = PerlIO_fill(n);
2490 avail = PerlIO_get_cnt(n);
2493 if (!PerlIO_error(n) && PerlIO_eof(n))
2499 STDCHAR *ptr = PerlIO_get_ptr(n);
2500 SSize_t cnt = avail;
2501 if (avail > b->bufsiz)
2503 Copy(ptr,b->buf,avail,STDCHAR);
2504 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2509 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2514 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2516 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2519 b->end = b->buf+avail;
2520 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2525 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2527 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2532 return PerlIOBase_read(f,vbuf,count);
2538 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2540 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2541 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2544 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2550 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2552 avail = (b->ptr - b->buf);
2557 b->end = b->buf + avail;
2559 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2560 b->posn -= b->bufsiz;
2562 if (avail > (SSize_t) count)
2570 Copy(buf,b->ptr,avail,STDCHAR);
2574 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2581 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2583 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2584 const STDCHAR *buf = (const STDCHAR *) vbuf;
2588 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2592 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2593 if ((SSize_t) count < avail)
2595 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2596 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2616 Copy(buf,b->ptr,avail,STDCHAR);
2623 if (b->ptr >= (b->buf + b->bufsiz))
2626 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2632 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2635 if ((code = PerlIO_flush(f)) == 0)
2637 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2638 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2639 code = PerlIO_seek(PerlIONext(f),offset,whence);
2642 b->posn = PerlIO_tell(PerlIONext(f));
2649 PerlIOBuf_tell(PerlIO *f)
2651 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2652 Off_t posn = b->posn;
2654 posn += (b->ptr - b->buf);
2659 PerlIOBuf_close(PerlIO *f)
2662 IV code = PerlIOBase_close(f);
2663 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2664 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2666 PerlMemShared_free(b->buf);
2669 b->ptr = b->end = b->buf;
2670 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2675 PerlIOBuf_get_ptr(PerlIO *f)
2677 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2684 PerlIOBuf_get_cnt(PerlIO *f)
2686 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2689 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2690 return (b->end - b->ptr);
2695 PerlIOBuf_get_base(PerlIO *f)
2697 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2703 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2706 b->buf = (STDCHAR *)&b->oneword;
2707 b->bufsiz = sizeof(b->oneword);
2716 PerlIOBuf_bufsiz(PerlIO *f)
2718 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2721 return (b->end - b->buf);
2725 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2727 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2731 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2734 assert(PerlIO_get_cnt(f) == cnt);
2735 assert(b->ptr >= b->buf);
2737 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2740 PerlIO_funcs PerlIO_perlio = {
2759 PerlIOBase_clearerr,
2760 PerlIOBase_setlinebuf,
2765 PerlIOBuf_set_ptrcnt,
2768 /*--------------------------------------------------------------------------------------*/
2769 /* Temp layer to hold unread chars when cannot do it any other way */
2772 PerlIOPending_fill(PerlIO *f)
2774 /* Should never happen */
2780 PerlIOPending_close(PerlIO *f)
2782 /* A tad tricky - flush pops us, then we close new top */
2784 return PerlIO_close(f);
2788 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2790 /* A tad tricky - flush pops us, then we seek new top */
2792 return PerlIO_seek(f,offset,whence);
2797 PerlIOPending_flush(PerlIO *f)
2800 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2801 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2803 PerlMemShared_free(b->buf);
2806 PerlIO_pop(aTHX_ f);
2811 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2819 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2824 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2826 IV code = PerlIOBase_pushed(f,mode,arg);
2827 PerlIOl *l = PerlIOBase(f);
2828 /* Our PerlIO_fast_gets must match what we are pushed on,
2829 or sv_gets() etc. get muddled when it changes mid-string
2832 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2833 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2838 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2840 SSize_t avail = PerlIO_get_cnt(f);
2845 got = PerlIOBuf_read(f,vbuf,avail);
2846 if (got >= 0 && got < count)
2848 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2849 if (more >= 0 || got == 0)
2855 PerlIO_funcs PerlIO_pending = {
2859 PerlIOPending_pushed,
2869 PerlIOPending_close,
2870 PerlIOPending_flush,
2874 PerlIOBase_clearerr,
2875 PerlIOBase_setlinebuf,
2880 PerlIOPending_set_ptrcnt,
2885 /*--------------------------------------------------------------------------------------*/
2886 /* crlf - translation
2887 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2888 to hand back a line at a time and keeping a record of which nl we "lied" about.
2889 On write translate "\n" to CR,LF
2894 PerlIOBuf base; /* PerlIOBuf stuff */
2895 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2899 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2902 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2903 code = PerlIOBuf_pushed(f,mode,arg);
2905 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2906 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2907 PerlIOBase(f)->flags);
2914 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2916 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2922 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2923 return PerlIOBuf_unread(f,vbuf,count);
2926 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2927 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2929 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2935 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2937 b->end = b->ptr = b->buf + b->bufsiz;
2938 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2939 b->posn -= b->bufsiz;
2941 while (count > 0 && b->ptr > b->buf)
2946 if (b->ptr - 2 >= b->buf)
2972 PerlIOCrlf_get_cnt(PerlIO *f)
2974 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2977 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2979 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2980 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2982 STDCHAR *nl = b->ptr;
2984 while (nl < b->end && *nl != 0xd)
2986 if (nl < b->end && *nl == 0xd)
2998 /* Not CR,LF but just CR */
3005 /* Blast - found CR as last char in buffer */
3008 /* They may not care, defer work as long as possible */
3009 return (nl - b->ptr);
3015 b->ptr++; /* say we have read it as far as flush() is concerned */
3016 b->buf++; /* Leave space an front of buffer */
3017 b->bufsiz--; /* Buffer is thus smaller */
3018 code = PerlIO_fill(f); /* Fetch some more */
3019 b->bufsiz++; /* Restore size for next time */
3020 b->buf--; /* Point at space */
3021 b->ptr = nl = b->buf; /* Which is what we hand off */
3022 b->posn--; /* Buffer starts here */
3023 *nl = 0xd; /* Fill in the CR */
3025 goto test; /* fill() call worked */
3026 /* CR at EOF - just fall through */
3031 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3037 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3039 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3040 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3041 IV flags = PerlIOBase(f)->flags;
3051 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3058 /* Test code - delete when it works ... */
3065 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3073 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3074 ptr, chk, flags, c->nl, b->end, cnt);
3081 /* They have taken what we lied about */
3088 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3092 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3094 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3095 return PerlIOBuf_write(f,vbuf,count);
3098 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3099 const STDCHAR *buf = (const STDCHAR *) vbuf;
3100 const STDCHAR *ebuf = buf+count;
3103 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3107 STDCHAR *eptr = b->buf+b->bufsiz;
3108 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3109 while (buf < ebuf && b->ptr < eptr)
3113 if ((b->ptr + 2) > eptr)
3115 /* Not room for both */
3121 *(b->ptr)++ = 0xd; /* CR */
3122 *(b->ptr)++ = 0xa; /* LF */
3124 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3143 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3145 return (buf - (STDCHAR *) vbuf);
3150 PerlIOCrlf_flush(PerlIO *f)
3152 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3158 return PerlIOBuf_flush(f);
3161 PerlIO_funcs PerlIO_crlf = {
3164 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3166 PerlIOBase_noop_ok, /* popped */
3170 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3171 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3172 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3180 PerlIOBase_clearerr,
3181 PerlIOBase_setlinebuf,
3186 PerlIOCrlf_set_ptrcnt,
3190 /*--------------------------------------------------------------------------------------*/
3191 /* mmap as "buffer" layer */
3195 PerlIOBuf base; /* PerlIOBuf stuff */
3196 Mmap_t mptr; /* Mapped address */
3197 Size_t len; /* mapped length */
3198 STDCHAR *bbuf; /* malloced buffer if map fails */
3201 static size_t page_size = 0;
3204 PerlIOMmap_map(PerlIO *f)
3207 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3208 PerlIOBuf *b = &m->base;
3209 IV flags = PerlIOBase(f)->flags;
3213 if (flags & PERLIO_F_CANREAD)
3215 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3216 int fd = PerlIO_fileno(f);
3218 code = fstat(fd,&st);
3219 if (code == 0 && S_ISREG(st.st_mode))
3221 SSize_t len = st.st_size - b->posn;
3226 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3228 SETERRNO(0,SS$_NORMAL);
3229 # ifdef _SC_PAGESIZE
3230 page_size = sysconf(_SC_PAGESIZE);
3232 page_size = sysconf(_SC_PAGE_SIZE);
3234 if ((long)page_size < 0) {
3239 (void)SvUPGRADE(error, SVt_PV);
3240 msg = SvPVx(error, n_a);
3241 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3244 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3248 # ifdef HAS_GETPAGESIZE
3249 page_size = getpagesize();
3251 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3252 page_size = PAGESIZE; /* compiletime, bad */
3256 if ((IV)page_size <= 0)
3257 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3261 /* This is a hack - should never happen - open should have set it ! */
3262 b->posn = PerlIO_tell(PerlIONext(f));
3264 posn = (b->posn / page_size) * page_size;
3265 len = st.st_size - posn;
3266 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3267 if (m->mptr && m->mptr != (Mmap_t) -1)
3269 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3270 madvise(m->mptr, len, MADV_SEQUENTIAL);
3272 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3273 madvise(m->mptr, len, MADV_WILLNEED);
3275 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3276 b->end = ((STDCHAR *)m->mptr) + len;
3277 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3288 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3290 b->ptr = b->end = b->ptr;
3299 PerlIOMmap_unmap(PerlIO *f)
3301 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3302 PerlIOBuf *b = &m->base;
3308 code = munmap(m->mptr, m->len);
3312 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3315 b->ptr = b->end = b->buf;
3316 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3322 PerlIOMmap_get_base(PerlIO *f)
3324 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3325 PerlIOBuf *b = &m->base;
3326 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3328 /* Already have a readbuffer in progress */
3333 /* We have a write buffer or flushed PerlIOBuf read buffer */
3334 m->bbuf = b->buf; /* save it in case we need it again */
3335 b->buf = NULL; /* Clear to trigger below */
3339 PerlIOMmap_map(f); /* Try and map it */
3342 /* Map did not work - recover PerlIOBuf buffer if we have one */
3346 b->ptr = b->end = b->buf;
3349 return PerlIOBuf_get_base(f);
3353 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3355 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3356 PerlIOBuf *b = &m->base;
3357 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3359 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3362 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3367 /* Loose the unwritable mapped buffer */
3369 /* If flush took the "buffer" see if we have one from before */
3370 if (!b->buf && m->bbuf)
3374 PerlIOBuf_get_base(f);
3378 return PerlIOBuf_unread(f,vbuf,count);
3382 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3384 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3385 PerlIOBuf *b = &m->base;
3386 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3388 /* No, or wrong sort of, buffer */
3391 if (PerlIOMmap_unmap(f) != 0)
3394 /* If unmap took the "buffer" see if we have one from before */
3395 if (!b->buf && m->bbuf)
3399 PerlIOBuf_get_base(f);
3403 return PerlIOBuf_write(f,vbuf,count);
3407 PerlIOMmap_flush(PerlIO *f)
3409 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3410 PerlIOBuf *b = &m->base;
3411 IV code = PerlIOBuf_flush(f);
3412 /* Now we are "synced" at PerlIOBuf level */
3417 /* Unmap the buffer */
3418 if (PerlIOMmap_unmap(f) != 0)
3423 /* We seem to have a PerlIOBuf buffer which was not mapped
3424 * remember it in case we need one later
3433 PerlIOMmap_fill(PerlIO *f)
3435 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3436 IV code = PerlIO_flush(f);
3437 if (code == 0 && !b->buf)
3439 code = PerlIOMmap_map(f);
3441 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3443 code = PerlIOBuf_fill(f);
3449 PerlIOMmap_close(PerlIO *f)
3451 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3452 PerlIOBuf *b = &m->base;
3453 IV code = PerlIO_flush(f);
3458 b->ptr = b->end = b->buf;
3460 if (PerlIOBuf_close(f) != 0)
3466 PerlIO_funcs PerlIO_mmap = {
3485 PerlIOBase_clearerr,
3486 PerlIOBase_setlinebuf,
3487 PerlIOMmap_get_base,
3491 PerlIOBuf_set_ptrcnt,
3494 #endif /* HAS_MMAP */
3502 atexit(&PerlIO_cleanup);
3514 PerlIO_stdstreams(aTHX);
3519 #undef PerlIO_stdout
3526 PerlIO_stdstreams(aTHX);
3531 #undef PerlIO_stderr
3538 PerlIO_stdstreams(aTHX);
3543 /*--------------------------------------------------------------------------------------*/
3545 #undef PerlIO_getname
3547 PerlIO_getname(PerlIO *f, char *buf)
3550 Perl_croak(aTHX_ "Don't know how to get file name");
3555 /*--------------------------------------------------------------------------------------*/
3556 /* Functions which can be called on any kind of PerlIO implemented
3562 PerlIO_getc(PerlIO *f)
3565 SSize_t count = PerlIO_read(f,buf,1);
3568 return (unsigned char) buf[0];
3573 #undef PerlIO_ungetc
3575 PerlIO_ungetc(PerlIO *f, int ch)
3580 if (PerlIO_unread(f,&buf,1) == 1)
3588 PerlIO_putc(PerlIO *f, int ch)
3591 return PerlIO_write(f,&buf,1);
3596 PerlIO_puts(PerlIO *f, const char *s)
3598 STRLEN len = strlen(s);
3599 return PerlIO_write(f,s,len);
3602 #undef PerlIO_rewind
3604 PerlIO_rewind(PerlIO *f)
3606 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3610 #undef PerlIO_vprintf
3612 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3615 SV *sv = newSVpvn("",0);
3621 Perl_va_copy(ap, apc);
3622 sv_vcatpvf(sv, fmt, &apc);
3624 sv_vcatpvf(sv, fmt, &ap);
3627 wrote = PerlIO_write(f,s,len);
3632 #undef PerlIO_printf
3634 PerlIO_printf(PerlIO *f,const char *fmt,...)
3639 result = PerlIO_vprintf(f,fmt,ap);
3644 #undef PerlIO_stdoutf
3646 PerlIO_stdoutf(const char *fmt,...)
3651 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3656 #undef PerlIO_tmpfile
3658 PerlIO_tmpfile(void)
3660 /* I have no idea how portable mkstemp() is ... */
3661 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3664 FILE *stdio = PerlSIO_tmpfile();
3667 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3673 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3674 int fd = mkstemp(SvPVX(sv));
3678 f = PerlIO_fdopen(fd,"w+");
3681 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3683 PerlLIO_unlink(SvPVX(sv));
3693 #endif /* USE_SFIO */
3694 #endif /* PERLIO_IS_STDIO */
3696 /*======================================================================================*/
3697 /* Now some functions in terms of above which may be needed even if
3698 we are not in true PerlIO mode
3702 #undef PerlIO_setpos
3704 PerlIO_setpos(PerlIO *f, SV *pos)
3710 Off_t *posn = (Off_t *) SvPV(pos,len);
3711 if (f && len == sizeof(Off_t))
3712 return PerlIO_seek(f,*posn,SEEK_SET);
3718 #undef PerlIO_setpos
3720 PerlIO_setpos(PerlIO *f, SV *pos)
3726 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3727 if (f && len == sizeof(Fpos_t))
3729 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3730 return fsetpos64(f, fpos);
3732 return fsetpos(f, fpos);
3742 #undef PerlIO_getpos
3744 PerlIO_getpos(PerlIO *f, SV *pos)
3747 Off_t posn = PerlIO_tell(f);
3748 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3749 return (posn == (Off_t)-1) ? -1 : 0;
3752 #undef PerlIO_getpos
3754 PerlIO_getpos(PerlIO *f, SV *pos)
3759 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3760 code = fgetpos64(f, &fpos);
3762 code = fgetpos(f, &fpos);
3764 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3769 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3772 vprintf(char *pat, char *args)
3774 _doprnt(pat, args, stdout);
3775 return 0; /* wrong, but perl doesn't use the return value */
3779 vfprintf(FILE *fd, char *pat, char *args)
3781 _doprnt(pat, args, fd);
3782 return 0; /* wrong, but perl doesn't use the return value */
3787 #ifndef PerlIO_vsprintf
3789 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3791 int val = vsprintf(s, fmt, ap);
3794 if (strlen(s) >= (STRLEN)n)
3797 (void)PerlIO_puts(Perl_error_log,
3798 "panic: sprintf overflow - memory corrupted!\n");
3806 #ifndef PerlIO_sprintf
3808 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3813 result = PerlIO_vsprintf(s, n, fmt, ap);