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;
1473 if (*mode == '#' || *mode == 'I')
1478 l->flags |= PERLIO_F_CANREAD;
1481 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1484 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1495 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1498 l->flags &= ~PERLIO_F_CRLF;
1501 l->flags |= PERLIO_F_CRLF;
1513 l->flags |= l->next->flags &
1514 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1518 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1519 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1520 l->flags,PerlIO_modestr(f,temp));
1526 PerlIOBase_popped(PerlIO *f)
1532 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1535 Off_t old = PerlIO_tell(f);
1537 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1538 done = PerlIOBuf_unread(f,vbuf,count);
1539 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1544 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1546 STDCHAR *buf = (STDCHAR *) vbuf;
1549 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1553 SSize_t avail = PerlIO_get_cnt(f);
1554 SSize_t take = (count < avail) ? count : avail;
1557 STDCHAR *ptr = PerlIO_get_ptr(f);
1558 Copy(ptr,buf,take,STDCHAR);
1559 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1563 if (count > 0 && avail <= 0)
1565 if (PerlIO_fill(f) != 0)
1569 return (buf - (STDCHAR *) vbuf);
1575 PerlIOBase_noop_ok(PerlIO *f)
1581 PerlIOBase_noop_fail(PerlIO *f)
1587 PerlIOBase_close(PerlIO *f)
1590 PerlIO *n = PerlIONext(f);
1591 if (PerlIO_flush(f) != 0)
1593 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1595 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1600 PerlIOBase_eof(PerlIO *f)
1604 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1610 PerlIOBase_error(PerlIO *f)
1614 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1620 PerlIOBase_clearerr(PerlIO *f)
1624 PerlIO *n = PerlIONext(f);
1625 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1632 PerlIOBase_setlinebuf(PerlIO *f)
1636 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1640 /*--------------------------------------------------------------------------------------*/
1641 /* Bottom-most level for UNIX-like case */
1645 struct _PerlIO base; /* The generic part */
1646 int fd; /* UNIX like file descriptor */
1647 int oflags; /* open/fcntl flags */
1651 PerlIOUnix_oflags(const char *mode)
1666 oflags = O_CREAT|O_TRUNC;
1677 oflags = O_CREAT|O_APPEND;
1693 else if (*mode == 't')
1696 oflags &= ~O_BINARY;
1699 /* Always open in binary mode */
1701 if (*mode || oflags == -1)
1710 PerlIOUnix_fileno(PerlIO *f)
1712 return PerlIOSelf(f,PerlIOUnix)->fd;
1716 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1718 IV code = PerlIOBase_pushed(f,mode,arg);
1721 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1722 s->fd = PerlIO_fileno(PerlIONext(f));
1723 s->oflags = PerlIOUnix_oflags(mode);
1725 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1730 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)
1734 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1735 (*PerlIOBase(f)->tab->Close)(f);
1739 char *path = SvPV_nolen(*args);
1744 imode = PerlIOUnix_oflags(mode);
1749 fd = PerlLIO_open3(path,imode,perm);
1759 f = PerlIO_allocate(aTHX);
1760 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1763 s = PerlIOSelf(f,PerlIOUnix);
1766 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1773 /* FIXME: pop layers ??? */
1780 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1783 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1784 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1788 SSize_t len = PerlLIO_read(fd,vbuf,count);
1789 if (len >= 0 || errno != EINTR)
1792 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1793 else if (len == 0 && count != 0)
1794 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1802 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1805 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1808 SSize_t len = PerlLIO_write(fd,vbuf,count);
1809 if (len >= 0 || errno != EINTR)
1812 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1820 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1823 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1824 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1825 return (new == (Off_t) -1) ? -1 : 0;
1829 PerlIOUnix_tell(PerlIO *f)
1832 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1833 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1837 PerlIOUnix_close(PerlIO *f)
1840 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1842 while (PerlLIO_close(fd) != 0)
1853 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1858 PerlIO_funcs PerlIO_unix = {
1873 PerlIOBase_noop_ok, /* flush */
1874 PerlIOBase_noop_fail, /* fill */
1877 PerlIOBase_clearerr,
1878 PerlIOBase_setlinebuf,
1879 NULL, /* get_base */
1880 NULL, /* get_bufsiz */
1883 NULL, /* set_ptrcnt */
1886 /*--------------------------------------------------------------------------------------*/
1887 /* stdio as a layer */
1891 struct _PerlIO base;
1892 FILE * stdio; /* The stream */
1896 PerlIOStdio_fileno(PerlIO *f)
1899 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1903 PerlIOStdio_mode(const char *mode,char *tmode)
1910 if (O_BINARY != O_TEXT)
1918 /* This isn't used yet ... */
1920 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
1925 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1927 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1933 return PerlIOBase_pushed(f,mode,arg);
1936 #undef PerlIO_importFILE
1938 PerlIO_importFILE(FILE *stdio, int fl)
1944 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
1951 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)
1956 char *path = SvPV_nolen(*args);
1957 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1958 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1968 char *path = SvPV_nolen(*args);
1972 fd = PerlLIO_open3(path,imode,perm);
1976 FILE *stdio = PerlSIO_fopen(path,mode);
1979 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
1980 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2001 stdio = PerlSIO_stdin;
2004 stdio = PerlSIO_stdout;
2007 stdio = PerlSIO_stderr;
2013 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2017 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2027 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2030 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2034 STDCHAR *buf = (STDCHAR *) vbuf;
2035 /* Perl is expecting PerlIO_getc() to fill the buffer
2036 * Linux's stdio does not do that for fread()
2038 int ch = PerlSIO_fgetc(s);
2046 got = PerlSIO_fread(vbuf,1,count,s);
2051 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2054 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2055 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2059 int ch = *buf-- & 0xff;
2060 if (PerlSIO_ungetc(ch,s) != ch)
2069 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2072 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2076 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2079 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2080 return PerlSIO_fseek(stdio,offset,whence);
2084 PerlIOStdio_tell(PerlIO *f)
2087 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2088 return PerlSIO_ftell(stdio);
2092 PerlIOStdio_close(PerlIO *f)
2095 #ifdef HAS_SOCKS5_INIT
2097 Sock_size_t optlen = sizeof(int);
2099 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2101 #ifdef HAS_SOCKS5_INIT
2102 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2103 PerlSIO_fclose(stdio) :
2104 close(PerlIO_fileno(f))
2106 PerlSIO_fclose(stdio)
2113 PerlIOStdio_flush(PerlIO *f)
2116 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2117 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2119 return PerlSIO_fflush(stdio);
2124 /* FIXME: This discards ungetc() and pre-read stuff which is
2125 not right if this is just a "sync" from a layer above
2126 Suspect right design is to do _this_ but not have layer above
2127 flush this layer read-to-read
2129 /* Not writeable - sync by attempting a seek */
2131 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2139 PerlIOStdio_fill(PerlIO *f)
2142 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2144 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2145 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2147 if (PerlSIO_fflush(stdio) != 0)
2150 c = PerlSIO_fgetc(stdio);
2151 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2157 PerlIOStdio_eof(PerlIO *f)
2160 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2164 PerlIOStdio_error(PerlIO *f)
2167 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2171 PerlIOStdio_clearerr(PerlIO *f)
2174 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2178 PerlIOStdio_setlinebuf(PerlIO *f)
2181 #ifdef HAS_SETLINEBUF
2182 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2184 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2190 PerlIOStdio_get_base(PerlIO *f)
2193 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2194 return PerlSIO_get_base(stdio);
2198 PerlIOStdio_get_bufsiz(PerlIO *f)
2201 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2202 return PerlSIO_get_bufsiz(stdio);
2206 #ifdef USE_STDIO_PTR
2208 PerlIOStdio_get_ptr(PerlIO *f)
2211 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2212 return PerlSIO_get_ptr(stdio);
2216 PerlIOStdio_get_cnt(PerlIO *f)
2219 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2220 return PerlSIO_get_cnt(stdio);
2224 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2227 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2230 #ifdef STDIO_PTR_LVALUE
2231 PerlSIO_set_ptr(stdio,ptr);
2232 #ifdef STDIO_PTR_LVAL_SETS_CNT
2233 if (PerlSIO_get_cnt(stdio) != (cnt))
2236 assert(PerlSIO_get_cnt(stdio) == (cnt));
2239 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2240 /* Setting ptr _does_ change cnt - we are done */
2243 #else /* STDIO_PTR_LVALUE */
2245 #endif /* STDIO_PTR_LVALUE */
2247 /* Now (or only) set cnt */
2248 #ifdef STDIO_CNT_LVALUE
2249 PerlSIO_set_cnt(stdio,cnt);
2250 #else /* STDIO_CNT_LVALUE */
2251 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2252 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2253 #else /* STDIO_PTR_LVAL_SETS_CNT */
2255 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2256 #endif /* STDIO_CNT_LVALUE */
2261 PerlIO_funcs PerlIO_stdio = {
2263 sizeof(PerlIOStdio),
2280 PerlIOStdio_clearerr,
2281 PerlIOStdio_setlinebuf,
2283 PerlIOStdio_get_base,
2284 PerlIOStdio_get_bufsiz,
2289 #ifdef USE_STDIO_PTR
2290 PerlIOStdio_get_ptr,
2291 PerlIOStdio_get_cnt,
2292 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2293 PerlIOStdio_set_ptrcnt
2294 #else /* STDIO_PTR_LVALUE */
2296 #endif /* STDIO_PTR_LVALUE */
2297 #else /* USE_STDIO_PTR */
2301 #endif /* USE_STDIO_PTR */
2304 #undef PerlIO_exportFILE
2306 PerlIO_exportFILE(PerlIO *f, int fl)
2310 stdio = fdopen(PerlIO_fileno(f),"r+");
2314 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2320 #undef PerlIO_findFILE
2322 PerlIO_findFILE(PerlIO *f)
2327 if (l->tab == &PerlIO_stdio)
2329 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2332 l = *PerlIONext(&l);
2334 return PerlIO_exportFILE(f,0);
2337 #undef PerlIO_releaseFILE
2339 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2343 /*--------------------------------------------------------------------------------------*/
2344 /* perlio buffer layer */
2347 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2349 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2350 int fd = PerlIO_fileno(f);
2353 if (fd >= 0 && PerlLIO_isatty(fd))
2355 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2357 posn = PerlIO_tell(PerlIONext(f));
2358 if (posn != (Off_t) -1)
2362 return PerlIOBase_pushed(f,mode,arg);
2366 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)
2370 PerlIO *next = PerlIONext(f);
2371 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2372 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2373 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2380 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2387 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2390 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2391 fd = PerlIO_fileno(f);
2392 #if O_BINARY != O_TEXT
2393 /* do something about failing setmode()? --jhi */
2394 PerlLIO_setmode(fd , O_BINARY);
2396 if (init && fd == 2)
2398 /* Initial stderr is unbuffered */
2399 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2406 /* This "flush" is akin to sfio's sync in that it handles files in either
2410 PerlIOBuf_flush(PerlIO *f)
2412 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2414 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2416 /* write() the buffer */
2417 STDCHAR *buf = b->buf;
2419 PerlIO *n = PerlIONext(f);
2422 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2427 else if (count < 0 || PerlIO_error(n))
2429 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2434 b->posn += (p - buf);
2436 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2438 STDCHAR *buf = PerlIO_get_base(f);
2439 /* Note position change */
2440 b->posn += (b->ptr - buf);
2441 if (b->ptr < b->end)
2443 /* We did not consume all of it */
2444 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2446 b->posn = PerlIO_tell(PerlIONext(f));
2450 b->ptr = b->end = b->buf;
2451 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2452 /* FIXME: Is this right for read case ? */
2453 if (PerlIO_flush(PerlIONext(f)) != 0)
2459 PerlIOBuf_fill(PerlIO *f)
2461 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2462 PerlIO *n = PerlIONext(f);
2464 /* FIXME: doing the down-stream flush is a bad idea if it causes
2465 pre-read data in stdio buffer to be discarded
2466 but this is too simplistic - as it skips _our_ hosekeeping
2467 and breaks tell tests.
2468 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2472 if (PerlIO_flush(f) != 0)
2474 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2475 PerlIOBase_flush_linebuf();
2478 PerlIO_get_base(f); /* allocate via vtable */
2480 b->ptr = b->end = b->buf;
2481 if (PerlIO_fast_gets(n))
2483 /* Layer below is also buffered
2484 * We do _NOT_ want to call its ->Read() because that will loop
2485 * till it gets what we asked for which may hang on a pipe etc.
2486 * Instead take anything it has to hand, or ask it to fill _once_.
2488 avail = PerlIO_get_cnt(n);
2491 avail = PerlIO_fill(n);
2493 avail = PerlIO_get_cnt(n);
2496 if (!PerlIO_error(n) && PerlIO_eof(n))
2502 STDCHAR *ptr = PerlIO_get_ptr(n);
2503 SSize_t cnt = avail;
2504 if (avail > b->bufsiz)
2506 Copy(ptr,b->buf,avail,STDCHAR);
2507 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2512 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2517 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2519 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2522 b->end = b->buf+avail;
2523 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2528 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2530 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2535 return PerlIOBase_read(f,vbuf,count);
2541 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2543 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2544 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2547 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2553 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2555 avail = (b->ptr - b->buf);
2560 b->end = b->buf + avail;
2562 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2563 b->posn -= b->bufsiz;
2565 if (avail > (SSize_t) count)
2573 Copy(buf,b->ptr,avail,STDCHAR);
2577 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2584 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2586 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2587 const STDCHAR *buf = (const STDCHAR *) vbuf;
2591 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2595 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2596 if ((SSize_t) count < avail)
2598 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2599 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2619 Copy(buf,b->ptr,avail,STDCHAR);
2626 if (b->ptr >= (b->buf + b->bufsiz))
2629 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2635 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2638 if ((code = PerlIO_flush(f)) == 0)
2640 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2641 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2642 code = PerlIO_seek(PerlIONext(f),offset,whence);
2645 b->posn = PerlIO_tell(PerlIONext(f));
2652 PerlIOBuf_tell(PerlIO *f)
2654 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2655 Off_t posn = b->posn;
2657 posn += (b->ptr - b->buf);
2662 PerlIOBuf_close(PerlIO *f)
2665 IV code = PerlIOBase_close(f);
2666 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2667 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2669 PerlMemShared_free(b->buf);
2672 b->ptr = b->end = b->buf;
2673 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2678 PerlIOBuf_get_ptr(PerlIO *f)
2680 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2687 PerlIOBuf_get_cnt(PerlIO *f)
2689 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2692 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2693 return (b->end - b->ptr);
2698 PerlIOBuf_get_base(PerlIO *f)
2700 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2706 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2709 b->buf = (STDCHAR *)&b->oneword;
2710 b->bufsiz = sizeof(b->oneword);
2719 PerlIOBuf_bufsiz(PerlIO *f)
2721 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2724 return (b->end - b->buf);
2728 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2730 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2734 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2737 assert(PerlIO_get_cnt(f) == cnt);
2738 assert(b->ptr >= b->buf);
2740 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2743 PerlIO_funcs PerlIO_perlio = {
2762 PerlIOBase_clearerr,
2763 PerlIOBase_setlinebuf,
2768 PerlIOBuf_set_ptrcnt,
2771 /*--------------------------------------------------------------------------------------*/
2772 /* Temp layer to hold unread chars when cannot do it any other way */
2775 PerlIOPending_fill(PerlIO *f)
2777 /* Should never happen */
2783 PerlIOPending_close(PerlIO *f)
2785 /* A tad tricky - flush pops us, then we close new top */
2787 return PerlIO_close(f);
2791 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2793 /* A tad tricky - flush pops us, then we seek new top */
2795 return PerlIO_seek(f,offset,whence);
2800 PerlIOPending_flush(PerlIO *f)
2803 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2804 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2806 PerlMemShared_free(b->buf);
2809 PerlIO_pop(aTHX_ f);
2814 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2822 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2827 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2829 IV code = PerlIOBase_pushed(f,mode,arg);
2830 PerlIOl *l = PerlIOBase(f);
2831 /* Our PerlIO_fast_gets must match what we are pushed on,
2832 or sv_gets() etc. get muddled when it changes mid-string
2835 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2836 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2841 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2843 SSize_t avail = PerlIO_get_cnt(f);
2848 got = PerlIOBuf_read(f,vbuf,avail);
2849 if (got >= 0 && got < count)
2851 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2852 if (more >= 0 || got == 0)
2858 PerlIO_funcs PerlIO_pending = {
2862 PerlIOPending_pushed,
2872 PerlIOPending_close,
2873 PerlIOPending_flush,
2877 PerlIOBase_clearerr,
2878 PerlIOBase_setlinebuf,
2883 PerlIOPending_set_ptrcnt,
2888 /*--------------------------------------------------------------------------------------*/
2889 /* crlf - translation
2890 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2891 to hand back a line at a time and keeping a record of which nl we "lied" about.
2892 On write translate "\n" to CR,LF
2897 PerlIOBuf base; /* PerlIOBuf stuff */
2898 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2902 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2905 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2906 code = PerlIOBuf_pushed(f,mode,arg);
2908 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2909 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2910 PerlIOBase(f)->flags);
2917 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2919 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2925 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2926 return PerlIOBuf_unread(f,vbuf,count);
2929 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2930 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2932 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2938 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2940 b->end = b->ptr = b->buf + b->bufsiz;
2941 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2942 b->posn -= b->bufsiz;
2944 while (count > 0 && b->ptr > b->buf)
2949 if (b->ptr - 2 >= b->buf)
2975 PerlIOCrlf_get_cnt(PerlIO *f)
2977 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2980 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2982 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2983 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2985 STDCHAR *nl = b->ptr;
2987 while (nl < b->end && *nl != 0xd)
2989 if (nl < b->end && *nl == 0xd)
3001 /* Not CR,LF but just CR */
3008 /* Blast - found CR as last char in buffer */
3011 /* They may not care, defer work as long as possible */
3012 return (nl - b->ptr);
3018 b->ptr++; /* say we have read it as far as flush() is concerned */
3019 b->buf++; /* Leave space an front of buffer */
3020 b->bufsiz--; /* Buffer is thus smaller */
3021 code = PerlIO_fill(f); /* Fetch some more */
3022 b->bufsiz++; /* Restore size for next time */
3023 b->buf--; /* Point at space */
3024 b->ptr = nl = b->buf; /* Which is what we hand off */
3025 b->posn--; /* Buffer starts here */
3026 *nl = 0xd; /* Fill in the CR */
3028 goto test; /* fill() call worked */
3029 /* CR at EOF - just fall through */
3034 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3040 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3042 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3043 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3044 IV flags = PerlIOBase(f)->flags;
3054 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3061 /* Test code - delete when it works ... */
3068 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3076 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3077 ptr, chk, flags, c->nl, b->end, cnt);
3084 /* They have taken what we lied about */
3091 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3095 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3097 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3098 return PerlIOBuf_write(f,vbuf,count);
3101 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3102 const STDCHAR *buf = (const STDCHAR *) vbuf;
3103 const STDCHAR *ebuf = buf+count;
3106 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3110 STDCHAR *eptr = b->buf+b->bufsiz;
3111 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3112 while (buf < ebuf && b->ptr < eptr)
3116 if ((b->ptr + 2) > eptr)
3118 /* Not room for both */
3124 *(b->ptr)++ = 0xd; /* CR */
3125 *(b->ptr)++ = 0xa; /* LF */
3127 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3146 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3148 return (buf - (STDCHAR *) vbuf);
3153 PerlIOCrlf_flush(PerlIO *f)
3155 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3161 return PerlIOBuf_flush(f);
3164 PerlIO_funcs PerlIO_crlf = {
3167 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3169 PerlIOBase_noop_ok, /* popped */
3173 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3174 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3175 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3183 PerlIOBase_clearerr,
3184 PerlIOBase_setlinebuf,
3189 PerlIOCrlf_set_ptrcnt,
3193 /*--------------------------------------------------------------------------------------*/
3194 /* mmap as "buffer" layer */
3198 PerlIOBuf base; /* PerlIOBuf stuff */
3199 Mmap_t mptr; /* Mapped address */
3200 Size_t len; /* mapped length */
3201 STDCHAR *bbuf; /* malloced buffer if map fails */
3204 static size_t page_size = 0;
3207 PerlIOMmap_map(PerlIO *f)
3210 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3211 PerlIOBuf *b = &m->base;
3212 IV flags = PerlIOBase(f)->flags;
3216 if (flags & PERLIO_F_CANREAD)
3218 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3219 int fd = PerlIO_fileno(f);
3221 code = fstat(fd,&st);
3222 if (code == 0 && S_ISREG(st.st_mode))
3224 SSize_t len = st.st_size - b->posn;
3229 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3231 SETERRNO(0,SS$_NORMAL);
3232 # ifdef _SC_PAGESIZE
3233 page_size = sysconf(_SC_PAGESIZE);
3235 page_size = sysconf(_SC_PAGE_SIZE);
3237 if ((long)page_size < 0) {
3242 (void)SvUPGRADE(error, SVt_PV);
3243 msg = SvPVx(error, n_a);
3244 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3247 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3251 # ifdef HAS_GETPAGESIZE
3252 page_size = getpagesize();
3254 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3255 page_size = PAGESIZE; /* compiletime, bad */
3259 if ((IV)page_size <= 0)
3260 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3264 /* This is a hack - should never happen - open should have set it ! */
3265 b->posn = PerlIO_tell(PerlIONext(f));
3267 posn = (b->posn / page_size) * page_size;
3268 len = st.st_size - posn;
3269 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3270 if (m->mptr && m->mptr != (Mmap_t) -1)
3272 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3273 madvise(m->mptr, len, MADV_SEQUENTIAL);
3275 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3276 madvise(m->mptr, len, MADV_WILLNEED);
3278 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3279 b->end = ((STDCHAR *)m->mptr) + len;
3280 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3291 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3293 b->ptr = b->end = b->ptr;
3302 PerlIOMmap_unmap(PerlIO *f)
3304 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3305 PerlIOBuf *b = &m->base;
3311 code = munmap(m->mptr, m->len);
3315 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3318 b->ptr = b->end = b->buf;
3319 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3325 PerlIOMmap_get_base(PerlIO *f)
3327 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3328 PerlIOBuf *b = &m->base;
3329 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3331 /* Already have a readbuffer in progress */
3336 /* We have a write buffer or flushed PerlIOBuf read buffer */
3337 m->bbuf = b->buf; /* save it in case we need it again */
3338 b->buf = NULL; /* Clear to trigger below */
3342 PerlIOMmap_map(f); /* Try and map it */
3345 /* Map did not work - recover PerlIOBuf buffer if we have one */
3349 b->ptr = b->end = b->buf;
3352 return PerlIOBuf_get_base(f);
3356 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3358 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3359 PerlIOBuf *b = &m->base;
3360 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3362 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3365 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3370 /* Loose the unwritable mapped buffer */
3372 /* If flush took the "buffer" see if we have one from before */
3373 if (!b->buf && m->bbuf)
3377 PerlIOBuf_get_base(f);
3381 return PerlIOBuf_unread(f,vbuf,count);
3385 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3387 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3388 PerlIOBuf *b = &m->base;
3389 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3391 /* No, or wrong sort of, buffer */
3394 if (PerlIOMmap_unmap(f) != 0)
3397 /* If unmap took the "buffer" see if we have one from before */
3398 if (!b->buf && m->bbuf)
3402 PerlIOBuf_get_base(f);
3406 return PerlIOBuf_write(f,vbuf,count);
3410 PerlIOMmap_flush(PerlIO *f)
3412 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3413 PerlIOBuf *b = &m->base;
3414 IV code = PerlIOBuf_flush(f);
3415 /* Now we are "synced" at PerlIOBuf level */
3420 /* Unmap the buffer */
3421 if (PerlIOMmap_unmap(f) != 0)
3426 /* We seem to have a PerlIOBuf buffer which was not mapped
3427 * remember it in case we need one later
3436 PerlIOMmap_fill(PerlIO *f)
3438 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3439 IV code = PerlIO_flush(f);
3440 if (code == 0 && !b->buf)
3442 code = PerlIOMmap_map(f);
3444 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3446 code = PerlIOBuf_fill(f);
3452 PerlIOMmap_close(PerlIO *f)
3454 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3455 PerlIOBuf *b = &m->base;
3456 IV code = PerlIO_flush(f);
3461 b->ptr = b->end = b->buf;
3463 if (PerlIOBuf_close(f) != 0)
3469 PerlIO_funcs PerlIO_mmap = {
3488 PerlIOBase_clearerr,
3489 PerlIOBase_setlinebuf,
3490 PerlIOMmap_get_base,
3494 PerlIOBuf_set_ptrcnt,
3497 #endif /* HAS_MMAP */
3505 atexit(&PerlIO_cleanup);
3517 PerlIO_stdstreams(aTHX);
3522 #undef PerlIO_stdout
3529 PerlIO_stdstreams(aTHX);
3534 #undef PerlIO_stderr
3541 PerlIO_stdstreams(aTHX);
3546 /*--------------------------------------------------------------------------------------*/
3548 #undef PerlIO_getname
3550 PerlIO_getname(PerlIO *f, char *buf)
3553 Perl_croak(aTHX_ "Don't know how to get file name");
3558 /*--------------------------------------------------------------------------------------*/
3559 /* Functions which can be called on any kind of PerlIO implemented
3565 PerlIO_getc(PerlIO *f)
3568 SSize_t count = PerlIO_read(f,buf,1);
3571 return (unsigned char) buf[0];
3576 #undef PerlIO_ungetc
3578 PerlIO_ungetc(PerlIO *f, int ch)
3583 if (PerlIO_unread(f,&buf,1) == 1)
3591 PerlIO_putc(PerlIO *f, int ch)
3594 return PerlIO_write(f,&buf,1);
3599 PerlIO_puts(PerlIO *f, const char *s)
3601 STRLEN len = strlen(s);
3602 return PerlIO_write(f,s,len);
3605 #undef PerlIO_rewind
3607 PerlIO_rewind(PerlIO *f)
3609 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3613 #undef PerlIO_vprintf
3615 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3618 SV *sv = newSVpvn("",0);
3624 Perl_va_copy(ap, apc);
3625 sv_vcatpvf(sv, fmt, &apc);
3627 sv_vcatpvf(sv, fmt, &ap);
3630 wrote = PerlIO_write(f,s,len);
3635 #undef PerlIO_printf
3637 PerlIO_printf(PerlIO *f,const char *fmt,...)
3642 result = PerlIO_vprintf(f,fmt,ap);
3647 #undef PerlIO_stdoutf
3649 PerlIO_stdoutf(const char *fmt,...)
3654 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3659 #undef PerlIO_tmpfile
3661 PerlIO_tmpfile(void)
3663 /* I have no idea how portable mkstemp() is ... */
3664 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3667 FILE *stdio = PerlSIO_tmpfile();
3670 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3676 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3677 int fd = mkstemp(SvPVX(sv));
3681 f = PerlIO_fdopen(fd,"w+");
3684 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3686 PerlLIO_unlink(SvPVX(sv));
3696 #endif /* USE_SFIO */
3697 #endif /* PERLIO_IS_STDIO */
3699 /*======================================================================================*/
3700 /* Now some functions in terms of above which may be needed even if
3701 we are not in true PerlIO mode
3705 #undef PerlIO_setpos
3707 PerlIO_setpos(PerlIO *f, SV *pos)
3713 Off_t *posn = (Off_t *) SvPV(pos,len);
3714 if (f && len == sizeof(Off_t))
3715 return PerlIO_seek(f,*posn,SEEK_SET);
3721 #undef PerlIO_setpos
3723 PerlIO_setpos(PerlIO *f, SV *pos)
3729 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3730 if (f && len == sizeof(Fpos_t))
3732 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3733 return fsetpos64(f, fpos);
3735 return fsetpos(f, fpos);
3745 #undef PerlIO_getpos
3747 PerlIO_getpos(PerlIO *f, SV *pos)
3750 Off_t posn = PerlIO_tell(f);
3751 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3752 return (posn == (Off_t)-1) ? -1 : 0;
3755 #undef PerlIO_getpos
3757 PerlIO_getpos(PerlIO *f, SV *pos)
3762 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3763 code = fgetpos64(f, &fpos);
3765 code = fgetpos(f, &fpos);
3767 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3772 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3775 vprintf(char *pat, char *args)
3777 _doprnt(pat, args, stdout);
3778 return 0; /* wrong, but perl doesn't use the return value */
3782 vfprintf(FILE *fd, char *pat, char *args)
3784 _doprnt(pat, args, fd);
3785 return 0; /* wrong, but perl doesn't use the return value */
3790 #ifndef PerlIO_vsprintf
3792 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3794 int val = vsprintf(s, fmt, ap);
3797 if (strlen(s) >= (STRLEN)n)
3800 (void)PerlIO_puts(Perl_error_log,
3801 "panic: sprintf overflow - memory corrupted!\n");
3809 #ifndef PerlIO_sprintf
3811 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3816 result = PerlIO_vsprintf(s, n, fmt, ap);