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
2096 int optval, optlen = sizeof(int);
2098 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2100 #ifdef HAS_SOCKS5_INIT
2101 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
2102 PerlSIO_fclose(stdio) :
2103 close(PerlIO_fileno(f))
2105 PerlSIO_fclose(stdio)
2112 PerlIOStdio_flush(PerlIO *f)
2115 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2116 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2118 return PerlSIO_fflush(stdio);
2123 /* FIXME: This discards ungetc() and pre-read stuff which is
2124 not right if this is just a "sync" from a layer above
2125 Suspect right design is to do _this_ but not have layer above
2126 flush this layer read-to-read
2128 /* Not writeable - sync by attempting a seek */
2130 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2138 PerlIOStdio_fill(PerlIO *f)
2141 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2143 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2144 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2146 if (PerlSIO_fflush(stdio) != 0)
2149 c = PerlSIO_fgetc(stdio);
2150 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2156 PerlIOStdio_eof(PerlIO *f)
2159 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2163 PerlIOStdio_error(PerlIO *f)
2166 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2170 PerlIOStdio_clearerr(PerlIO *f)
2173 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2177 PerlIOStdio_setlinebuf(PerlIO *f)
2180 #ifdef HAS_SETLINEBUF
2181 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2183 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2189 PerlIOStdio_get_base(PerlIO *f)
2192 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2193 return PerlSIO_get_base(stdio);
2197 PerlIOStdio_get_bufsiz(PerlIO *f)
2200 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2201 return PerlSIO_get_bufsiz(stdio);
2205 #ifdef USE_STDIO_PTR
2207 PerlIOStdio_get_ptr(PerlIO *f)
2210 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2211 return PerlSIO_get_ptr(stdio);
2215 PerlIOStdio_get_cnt(PerlIO *f)
2218 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2219 return PerlSIO_get_cnt(stdio);
2223 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2226 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2229 #ifdef STDIO_PTR_LVALUE
2230 PerlSIO_set_ptr(stdio,ptr);
2231 #ifdef STDIO_PTR_LVAL_SETS_CNT
2232 if (PerlSIO_get_cnt(stdio) != (cnt))
2235 assert(PerlSIO_get_cnt(stdio) == (cnt));
2238 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2239 /* Setting ptr _does_ change cnt - we are done */
2242 #else /* STDIO_PTR_LVALUE */
2244 #endif /* STDIO_PTR_LVALUE */
2246 /* Now (or only) set cnt */
2247 #ifdef STDIO_CNT_LVALUE
2248 PerlSIO_set_cnt(stdio,cnt);
2249 #else /* STDIO_CNT_LVALUE */
2250 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2251 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2252 #else /* STDIO_PTR_LVAL_SETS_CNT */
2254 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2255 #endif /* STDIO_CNT_LVALUE */
2260 PerlIO_funcs PerlIO_stdio = {
2262 sizeof(PerlIOStdio),
2279 PerlIOStdio_clearerr,
2280 PerlIOStdio_setlinebuf,
2282 PerlIOStdio_get_base,
2283 PerlIOStdio_get_bufsiz,
2288 #ifdef USE_STDIO_PTR
2289 PerlIOStdio_get_ptr,
2290 PerlIOStdio_get_cnt,
2291 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2292 PerlIOStdio_set_ptrcnt
2293 #else /* STDIO_PTR_LVALUE */
2295 #endif /* STDIO_PTR_LVALUE */
2296 #else /* USE_STDIO_PTR */
2300 #endif /* USE_STDIO_PTR */
2303 #undef PerlIO_exportFILE
2305 PerlIO_exportFILE(PerlIO *f, int fl)
2309 stdio = fdopen(PerlIO_fileno(f),"r+");
2313 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2319 #undef PerlIO_findFILE
2321 PerlIO_findFILE(PerlIO *f)
2326 if (l->tab == &PerlIO_stdio)
2328 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2331 l = *PerlIONext(&l);
2333 return PerlIO_exportFILE(f,0);
2336 #undef PerlIO_releaseFILE
2338 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2342 /*--------------------------------------------------------------------------------------*/
2343 /* perlio buffer layer */
2346 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2348 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2349 int fd = PerlIO_fileno(f);
2352 if (fd >= 0 && PerlLIO_isatty(fd))
2354 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2356 posn = PerlIO_tell(PerlIONext(f));
2357 if (posn != (Off_t) -1)
2361 return PerlIOBase_pushed(f,mode,arg);
2365 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)
2369 PerlIO *next = PerlIONext(f);
2370 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2371 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2372 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2379 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2386 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2389 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2390 fd = PerlIO_fileno(f);
2391 #if O_BINARY != O_TEXT
2392 /* do something about failing setmode()? --jhi */
2393 PerlLIO_setmode(fd , O_BINARY);
2395 if (init && fd == 2)
2397 /* Initial stderr is unbuffered */
2398 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2405 /* This "flush" is akin to sfio's sync in that it handles files in either
2409 PerlIOBuf_flush(PerlIO *f)
2411 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2413 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2415 /* write() the buffer */
2416 STDCHAR *buf = b->buf;
2418 PerlIO *n = PerlIONext(f);
2421 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2426 else if (count < 0 || PerlIO_error(n))
2428 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2433 b->posn += (p - buf);
2435 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2437 STDCHAR *buf = PerlIO_get_base(f);
2438 /* Note position change */
2439 b->posn += (b->ptr - buf);
2440 if (b->ptr < b->end)
2442 /* We did not consume all of it */
2443 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2445 b->posn = PerlIO_tell(PerlIONext(f));
2449 b->ptr = b->end = b->buf;
2450 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2451 /* FIXME: Is this right for read case ? */
2452 if (PerlIO_flush(PerlIONext(f)) != 0)
2458 PerlIOBuf_fill(PerlIO *f)
2460 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2461 PerlIO *n = PerlIONext(f);
2463 /* FIXME: doing the down-stream flush is a bad idea if it causes
2464 pre-read data in stdio buffer to be discarded
2465 but this is too simplistic - as it skips _our_ hosekeeping
2466 and breaks tell tests.
2467 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2471 if (PerlIO_flush(f) != 0)
2473 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2474 PerlIOBase_flush_linebuf();
2477 PerlIO_get_base(f); /* allocate via vtable */
2479 b->ptr = b->end = b->buf;
2480 if (PerlIO_fast_gets(n))
2482 /* Layer below is also buffered
2483 * We do _NOT_ want to call its ->Read() because that will loop
2484 * till it gets what we asked for which may hang on a pipe etc.
2485 * Instead take anything it has to hand, or ask it to fill _once_.
2487 avail = PerlIO_get_cnt(n);
2490 avail = PerlIO_fill(n);
2492 avail = PerlIO_get_cnt(n);
2495 if (!PerlIO_error(n) && PerlIO_eof(n))
2501 STDCHAR *ptr = PerlIO_get_ptr(n);
2502 SSize_t cnt = avail;
2503 if (avail > b->bufsiz)
2505 Copy(ptr,b->buf,avail,STDCHAR);
2506 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2511 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2516 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2518 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2521 b->end = b->buf+avail;
2522 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2527 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2529 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2534 return PerlIOBase_read(f,vbuf,count);
2540 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2542 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2543 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2546 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2552 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2554 avail = (b->ptr - b->buf);
2559 b->end = b->buf + avail;
2561 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2562 b->posn -= b->bufsiz;
2564 if (avail > (SSize_t) count)
2572 Copy(buf,b->ptr,avail,STDCHAR);
2576 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2583 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2585 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2586 const STDCHAR *buf = (const STDCHAR *) vbuf;
2590 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2594 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2595 if ((SSize_t) count < avail)
2597 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2598 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2618 Copy(buf,b->ptr,avail,STDCHAR);
2625 if (b->ptr >= (b->buf + b->bufsiz))
2628 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2634 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2637 if ((code = PerlIO_flush(f)) == 0)
2639 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2640 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2641 code = PerlIO_seek(PerlIONext(f),offset,whence);
2644 b->posn = PerlIO_tell(PerlIONext(f));
2651 PerlIOBuf_tell(PerlIO *f)
2653 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2654 Off_t posn = b->posn;
2656 posn += (b->ptr - b->buf);
2661 PerlIOBuf_close(PerlIO *f)
2664 IV code = PerlIOBase_close(f);
2665 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2666 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2668 PerlMemShared_free(b->buf);
2671 b->ptr = b->end = b->buf;
2672 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2677 PerlIOBuf_get_ptr(PerlIO *f)
2679 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2686 PerlIOBuf_get_cnt(PerlIO *f)
2688 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2691 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2692 return (b->end - b->ptr);
2697 PerlIOBuf_get_base(PerlIO *f)
2699 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2705 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2708 b->buf = (STDCHAR *)&b->oneword;
2709 b->bufsiz = sizeof(b->oneword);
2718 PerlIOBuf_bufsiz(PerlIO *f)
2720 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2723 return (b->end - b->buf);
2727 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2729 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2733 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2736 assert(PerlIO_get_cnt(f) == cnt);
2737 assert(b->ptr >= b->buf);
2739 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2742 PerlIO_funcs PerlIO_perlio = {
2761 PerlIOBase_clearerr,
2762 PerlIOBase_setlinebuf,
2767 PerlIOBuf_set_ptrcnt,
2770 /*--------------------------------------------------------------------------------------*/
2771 /* Temp layer to hold unread chars when cannot do it any other way */
2774 PerlIOPending_fill(PerlIO *f)
2776 /* Should never happen */
2782 PerlIOPending_close(PerlIO *f)
2784 /* A tad tricky - flush pops us, then we close new top */
2786 return PerlIO_close(f);
2790 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2792 /* A tad tricky - flush pops us, then we seek new top */
2794 return PerlIO_seek(f,offset,whence);
2799 PerlIOPending_flush(PerlIO *f)
2802 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2803 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2805 PerlMemShared_free(b->buf);
2808 PerlIO_pop(aTHX_ f);
2813 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2821 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2826 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2828 IV code = PerlIOBase_pushed(f,mode,arg);
2829 PerlIOl *l = PerlIOBase(f);
2830 /* Our PerlIO_fast_gets must match what we are pushed on,
2831 or sv_gets() etc. get muddled when it changes mid-string
2834 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2835 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2840 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2842 SSize_t avail = PerlIO_get_cnt(f);
2847 got = PerlIOBuf_read(f,vbuf,avail);
2848 if (got >= 0 && got < count)
2850 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2851 if (more >= 0 || got == 0)
2857 PerlIO_funcs PerlIO_pending = {
2861 PerlIOPending_pushed,
2871 PerlIOPending_close,
2872 PerlIOPending_flush,
2876 PerlIOBase_clearerr,
2877 PerlIOBase_setlinebuf,
2882 PerlIOPending_set_ptrcnt,
2887 /*--------------------------------------------------------------------------------------*/
2888 /* crlf - translation
2889 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2890 to hand back a line at a time and keeping a record of which nl we "lied" about.
2891 On write translate "\n" to CR,LF
2896 PerlIOBuf base; /* PerlIOBuf stuff */
2897 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2901 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
2904 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2905 code = PerlIOBuf_pushed(f,mode,arg);
2907 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2908 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2909 PerlIOBase(f)->flags);
2916 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2918 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2924 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2925 return PerlIOBuf_unread(f,vbuf,count);
2928 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2929 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2931 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2937 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2939 b->end = b->ptr = b->buf + b->bufsiz;
2940 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2941 b->posn -= b->bufsiz;
2943 while (count > 0 && b->ptr > b->buf)
2948 if (b->ptr - 2 >= b->buf)
2974 PerlIOCrlf_get_cnt(PerlIO *f)
2976 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2979 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2981 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2982 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2984 STDCHAR *nl = b->ptr;
2986 while (nl < b->end && *nl != 0xd)
2988 if (nl < b->end && *nl == 0xd)
3000 /* Not CR,LF but just CR */
3007 /* Blast - found CR as last char in buffer */
3010 /* They may not care, defer work as long as possible */
3011 return (nl - b->ptr);
3017 b->ptr++; /* say we have read it as far as flush() is concerned */
3018 b->buf++; /* Leave space an front of buffer */
3019 b->bufsiz--; /* Buffer is thus smaller */
3020 code = PerlIO_fill(f); /* Fetch some more */
3021 b->bufsiz++; /* Restore size for next time */
3022 b->buf--; /* Point at space */
3023 b->ptr = nl = b->buf; /* Which is what we hand off */
3024 b->posn--; /* Buffer starts here */
3025 *nl = 0xd; /* Fill in the CR */
3027 goto test; /* fill() call worked */
3028 /* CR at EOF - just fall through */
3033 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3039 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3041 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3042 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3043 IV flags = PerlIOBase(f)->flags;
3053 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3060 /* Test code - delete when it works ... */
3067 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3075 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3076 ptr, chk, flags, c->nl, b->end, cnt);
3083 /* They have taken what we lied about */
3090 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3094 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3096 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3097 return PerlIOBuf_write(f,vbuf,count);
3100 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3101 const STDCHAR *buf = (const STDCHAR *) vbuf;
3102 const STDCHAR *ebuf = buf+count;
3105 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3109 STDCHAR *eptr = b->buf+b->bufsiz;
3110 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3111 while (buf < ebuf && b->ptr < eptr)
3115 if ((b->ptr + 2) > eptr)
3117 /* Not room for both */
3123 *(b->ptr)++ = 0xd; /* CR */
3124 *(b->ptr)++ = 0xa; /* LF */
3126 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3145 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3147 return (buf - (STDCHAR *) vbuf);
3152 PerlIOCrlf_flush(PerlIO *f)
3154 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3160 return PerlIOBuf_flush(f);
3163 PerlIO_funcs PerlIO_crlf = {
3166 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3168 PerlIOBase_noop_ok, /* popped */
3172 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3173 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3174 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3182 PerlIOBase_clearerr,
3183 PerlIOBase_setlinebuf,
3188 PerlIOCrlf_set_ptrcnt,
3192 /*--------------------------------------------------------------------------------------*/
3193 /* mmap as "buffer" layer */
3197 PerlIOBuf base; /* PerlIOBuf stuff */
3198 Mmap_t mptr; /* Mapped address */
3199 Size_t len; /* mapped length */
3200 STDCHAR *bbuf; /* malloced buffer if map fails */
3203 static size_t page_size = 0;
3206 PerlIOMmap_map(PerlIO *f)
3209 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3210 PerlIOBuf *b = &m->base;
3211 IV flags = PerlIOBase(f)->flags;
3215 if (flags & PERLIO_F_CANREAD)
3217 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3218 int fd = PerlIO_fileno(f);
3220 code = fstat(fd,&st);
3221 if (code == 0 && S_ISREG(st.st_mode))
3223 SSize_t len = st.st_size - b->posn;
3228 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3230 SETERRNO(0,SS$_NORMAL);
3231 # ifdef _SC_PAGESIZE
3232 page_size = sysconf(_SC_PAGESIZE);
3234 page_size = sysconf(_SC_PAGE_SIZE);
3236 if ((long)page_size < 0) {
3241 (void)SvUPGRADE(error, SVt_PV);
3242 msg = SvPVx(error, n_a);
3243 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3246 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3250 # ifdef HAS_GETPAGESIZE
3251 page_size = getpagesize();
3253 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3254 page_size = PAGESIZE; /* compiletime, bad */
3258 if ((IV)page_size <= 0)
3259 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3263 /* This is a hack - should never happen - open should have set it ! */
3264 b->posn = PerlIO_tell(PerlIONext(f));
3266 posn = (b->posn / page_size) * page_size;
3267 len = st.st_size - posn;
3268 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3269 if (m->mptr && m->mptr != (Mmap_t) -1)
3271 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3272 madvise(m->mptr, len, MADV_SEQUENTIAL);
3274 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3275 madvise(m->mptr, len, MADV_WILLNEED);
3277 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3278 b->end = ((STDCHAR *)m->mptr) + len;
3279 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3290 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3292 b->ptr = b->end = b->ptr;
3301 PerlIOMmap_unmap(PerlIO *f)
3303 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3304 PerlIOBuf *b = &m->base;
3310 code = munmap(m->mptr, m->len);
3314 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3317 b->ptr = b->end = b->buf;
3318 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3324 PerlIOMmap_get_base(PerlIO *f)
3326 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3327 PerlIOBuf *b = &m->base;
3328 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3330 /* Already have a readbuffer in progress */
3335 /* We have a write buffer or flushed PerlIOBuf read buffer */
3336 m->bbuf = b->buf; /* save it in case we need it again */
3337 b->buf = NULL; /* Clear to trigger below */
3341 PerlIOMmap_map(f); /* Try and map it */
3344 /* Map did not work - recover PerlIOBuf buffer if we have one */
3348 b->ptr = b->end = b->buf;
3351 return PerlIOBuf_get_base(f);
3355 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3357 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3358 PerlIOBuf *b = &m->base;
3359 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3361 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3364 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3369 /* Loose the unwritable mapped buffer */
3371 /* If flush took the "buffer" see if we have one from before */
3372 if (!b->buf && m->bbuf)
3376 PerlIOBuf_get_base(f);
3380 return PerlIOBuf_unread(f,vbuf,count);
3384 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3386 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3387 PerlIOBuf *b = &m->base;
3388 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3390 /* No, or wrong sort of, buffer */
3393 if (PerlIOMmap_unmap(f) != 0)
3396 /* If unmap took the "buffer" see if we have one from before */
3397 if (!b->buf && m->bbuf)
3401 PerlIOBuf_get_base(f);
3405 return PerlIOBuf_write(f,vbuf,count);
3409 PerlIOMmap_flush(PerlIO *f)
3411 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3412 PerlIOBuf *b = &m->base;
3413 IV code = PerlIOBuf_flush(f);
3414 /* Now we are "synced" at PerlIOBuf level */
3419 /* Unmap the buffer */
3420 if (PerlIOMmap_unmap(f) != 0)
3425 /* We seem to have a PerlIOBuf buffer which was not mapped
3426 * remember it in case we need one later
3435 PerlIOMmap_fill(PerlIO *f)
3437 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3438 IV code = PerlIO_flush(f);
3439 if (code == 0 && !b->buf)
3441 code = PerlIOMmap_map(f);
3443 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3445 code = PerlIOBuf_fill(f);
3451 PerlIOMmap_close(PerlIO *f)
3453 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3454 PerlIOBuf *b = &m->base;
3455 IV code = PerlIO_flush(f);
3460 b->ptr = b->end = b->buf;
3462 if (PerlIOBuf_close(f) != 0)
3468 PerlIO_funcs PerlIO_mmap = {
3487 PerlIOBase_clearerr,
3488 PerlIOBase_setlinebuf,
3489 PerlIOMmap_get_base,
3493 PerlIOBuf_set_ptrcnt,
3496 #endif /* HAS_MMAP */
3504 atexit(&PerlIO_cleanup);
3516 PerlIO_stdstreams(aTHX);
3521 #undef PerlIO_stdout
3528 PerlIO_stdstreams(aTHX);
3533 #undef PerlIO_stderr
3540 PerlIO_stdstreams(aTHX);
3545 /*--------------------------------------------------------------------------------------*/
3547 #undef PerlIO_getname
3549 PerlIO_getname(PerlIO *f, char *buf)
3552 Perl_croak(aTHX_ "Don't know how to get file name");
3557 /*--------------------------------------------------------------------------------------*/
3558 /* Functions which can be called on any kind of PerlIO implemented
3564 PerlIO_getc(PerlIO *f)
3567 SSize_t count = PerlIO_read(f,buf,1);
3570 return (unsigned char) buf[0];
3575 #undef PerlIO_ungetc
3577 PerlIO_ungetc(PerlIO *f, int ch)
3582 if (PerlIO_unread(f,&buf,1) == 1)
3590 PerlIO_putc(PerlIO *f, int ch)
3593 return PerlIO_write(f,&buf,1);
3598 PerlIO_puts(PerlIO *f, const char *s)
3600 STRLEN len = strlen(s);
3601 return PerlIO_write(f,s,len);
3604 #undef PerlIO_rewind
3606 PerlIO_rewind(PerlIO *f)
3608 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3612 #undef PerlIO_vprintf
3614 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3617 SV *sv = newSVpvn("",0);
3623 Perl_va_copy(ap, apc);
3624 sv_vcatpvf(sv, fmt, &apc);
3626 sv_vcatpvf(sv, fmt, &ap);
3629 wrote = PerlIO_write(f,s,len);
3634 #undef PerlIO_printf
3636 PerlIO_printf(PerlIO *f,const char *fmt,...)
3641 result = PerlIO_vprintf(f,fmt,ap);
3646 #undef PerlIO_stdoutf
3648 PerlIO_stdoutf(const char *fmt,...)
3653 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3658 #undef PerlIO_tmpfile
3660 PerlIO_tmpfile(void)
3662 /* I have no idea how portable mkstemp() is ... */
3663 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3666 FILE *stdio = PerlSIO_tmpfile();
3669 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3675 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3676 int fd = mkstemp(SvPVX(sv));
3680 f = PerlIO_fdopen(fd,"w+");
3683 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3685 PerlLIO_unlink(SvPVX(sv));
3695 #endif /* USE_SFIO */
3696 #endif /* PERLIO_IS_STDIO */
3698 /*======================================================================================*/
3699 /* Now some functions in terms of above which may be needed even if
3700 we are not in true PerlIO mode
3704 #undef PerlIO_setpos
3706 PerlIO_setpos(PerlIO *f, SV *pos)
3712 Off_t *posn = (Off_t *) SvPV(pos,len);
3713 if (f && len == sizeof(Off_t))
3714 return PerlIO_seek(f,*posn,SEEK_SET);
3720 #undef PerlIO_setpos
3722 PerlIO_setpos(PerlIO *f, SV *pos)
3728 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3729 if (f && len == sizeof(Fpos_t))
3731 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3732 return fsetpos64(f, fpos);
3734 return fsetpos(f, fpos);
3744 #undef PerlIO_getpos
3746 PerlIO_getpos(PerlIO *f, SV *pos)
3749 Off_t posn = PerlIO_tell(f);
3750 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3751 return (posn == (Off_t)-1) ? -1 : 0;
3754 #undef PerlIO_getpos
3756 PerlIO_getpos(PerlIO *f, SV *pos)
3761 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3762 code = fgetpos64(f, &fpos);
3764 code = fgetpos(f, &fpos);
3766 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3771 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3774 vprintf(char *pat, char *args)
3776 _doprnt(pat, args, stdout);
3777 return 0; /* wrong, but perl doesn't use the return value */
3781 vfprintf(FILE *fd, char *pat, char *args)
3783 _doprnt(pat, args, fd);
3784 return 0; /* wrong, but perl doesn't use the return value */
3789 #ifndef PerlIO_vsprintf
3791 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3793 int val = vsprintf(s, fmt, ap);
3796 if (strlen(s) >= (STRLEN)n)
3799 (void)PerlIO_puts(Perl_error_log,
3800 "panic: sprintf overflow - memory corrupted!\n");
3808 #ifndef PerlIO_sprintf
3810 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3815 result = PerlIO_vsprintf(s, n, fmt, ap);