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,(char *)mode+1);
127 return PerlIO_reopen(name,mode,old);
131 return PerlIO_open(name,mode);
137 return PerlIO_fdopen(fd,(char *)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, PERL_MAGIC_ext, NULL, 0);
456 mg = mg_find(sv, PERL_MAGIC_ext);
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)
829 return (*PerlIOBase(f)->tab->Close)(f);
832 SETERRNO(EBADF,SS$_IVCHAN);
837 #undef PerlIO_fdupopen
839 PerlIO_fdupopen(pTHX_ PerlIO *f)
844 int fd = PerlLIO_dup(PerlIO_fileno(f));
845 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
848 Off_t posn = PerlIO_tell(f);
849 PerlIO_seek(new,posn,SEEK_SET);
855 SETERRNO(EBADF,SS$_IVCHAN);
862 PerlIO_close(PerlIO *f)
868 code = (*PerlIOBase(f)->tab->Close)(f);
879 PerlIO_fileno(PerlIO *f)
882 return (*PerlIOBase(f)->tab->Fileno)(f);
885 SETERRNO(EBADF,SS$_IVCHAN);
891 PerlIO_context_layers(pTHX_ const char *mode)
893 const char *type = NULL;
894 /* Need to supply default layer info from open.pm */
897 SV *layers = PL_curcop->cop_io;
901 type = SvPV(layers,len);
902 if (type && mode[0] != 'r')
904 /* Skip to write part */
905 const char *s = strchr(type,0);
906 if (s && (s-type) < len)
917 PerlIO_layer_from_ref(pTHX_ SV *sv)
919 /* For any scalar type load the handler which is bundled with perl */
920 if (SvTYPE(sv) < SVt_PVAV)
921 return PerlIO_find_layer(aTHX_ "Scalar",6, 1);
923 /* For other types allow if layer is known but don't try and load it */
927 return PerlIO_find_layer(aTHX_ "Array",5, 0);
929 return PerlIO_find_layer(aTHX_ "Hash",4, 0);
931 return PerlIO_find_layer(aTHX_ "Code",4, 0);
933 return PerlIO_find_layer(aTHX_ "Glob",4, 0);
939 PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args)
941 AV *def = PerlIO_default_layers(aTHX);
944 PerlIO_stdstreams(aTHX);
948 /* If it is a reference but not an object see if we have a handler for it */
949 if (SvROK(arg) && !sv_isobject(arg))
951 SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
955 av_push(def,SvREFCNT_inc(handler));
956 av_push(def,&PL_sv_undef);
959 /* Don't fail if handler cannot be found
960 * :Via(...) etc. may do something sensible
961 * else we will just stringfy and open resulting string.
966 layers = PerlIO_context_layers(aTHX_ mode);
967 if (layers && *layers)
972 IV n = av_len(def)+1;
976 SV **svp = av_fetch(def,n,0);
977 av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef);
984 PerlIO_parse_layers(aTHX_ av,layers);
996 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
998 if (!f && narg == 1 && *args == &PL_sv_undef)
1000 if ((f = PerlIO_tmpfile()))
1003 layers = PerlIO_context_layers(aTHX_ mode);
1004 if (layers && *layers)
1005 PerlIO_apply_layers(aTHX_ f,mode,layers);
1015 /* This is "reopen" - it is not tested as perl does not use it yet */
1020 SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef;
1021 av_unshift(layera,2);
1022 av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab));
1023 av_store(layera,1,arg);
1024 l = *PerlIONext(&l);
1029 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1031 n = av_len(layera)-1;
1034 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL);
1044 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1045 tab->name,layers,mode,fd,imode,perm,f,narg,args);
1046 f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args);
1049 if (n+2 < av_len(layera)+1)
1051 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0)
1058 SvREFCNT_dec(layera);
1064 #undef PerlIO_fdopen
1066 PerlIO_fdopen(int fd, const char *mode)
1069 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
1074 PerlIO_open(const char *path, const char *mode)
1077 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1078 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
1081 #undef PerlIO_reopen
1083 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
1086 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
1087 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
1092 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
1095 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
1098 SETERRNO(EBADF,SS$_IVCHAN);
1103 #undef PerlIO_unread
1105 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
1108 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
1111 SETERRNO(EBADF,SS$_IVCHAN);
1118 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
1121 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
1124 SETERRNO(EBADF,SS$_IVCHAN);
1131 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
1134 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
1137 SETERRNO(EBADF,SS$_IVCHAN);
1144 PerlIO_tell(PerlIO *f)
1147 return (*PerlIOBase(f)->tab->Tell)(f);
1150 SETERRNO(EBADF,SS$_IVCHAN);
1157 PerlIO_flush(PerlIO *f)
1163 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1164 if (tab && tab->Flush)
1166 return (*tab->Flush)(f);
1170 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
1171 SETERRNO(EBADF,SS$_IVCHAN);
1177 PerlIO_debug("Cannot flush f=%p\n",f);
1178 SETERRNO(EBADF,SS$_IVCHAN);
1184 /* Is it good API design to do flush-all on NULL,
1185 * a potentially errorneous input? Maybe some magical
1186 * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)?
1187 * Yes, stdio does similar things on fflush(NULL),
1188 * but should we be bound by their design decisions?
1190 PerlIO **table = &_perlio;
1192 while ((f = *table))
1195 table = (PerlIO **)(f++);
1196 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1198 if (*f && PerlIO_flush(f) != 0)
1208 PerlIOBase_flush_linebuf()
1210 PerlIO **table = &_perlio;
1212 while ((f = *table))
1215 table = (PerlIO **)(f++);
1216 for (i=1; i < PERLIO_TABLE_SIZE; i++)
1218 if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1219 == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE))
1228 PerlIO_fill(PerlIO *f)
1231 return (*PerlIOBase(f)->tab->Fill)(f);
1234 SETERRNO(EBADF,SS$_IVCHAN);
1239 #undef PerlIO_isutf8
1241 PerlIO_isutf8(PerlIO *f)
1244 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1247 SETERRNO(EBADF,SS$_IVCHAN);
1254 PerlIO_eof(PerlIO *f)
1257 return (*PerlIOBase(f)->tab->Eof)(f);
1260 SETERRNO(EBADF,SS$_IVCHAN);
1267 PerlIO_error(PerlIO *f)
1270 return (*PerlIOBase(f)->tab->Error)(f);
1273 SETERRNO(EBADF,SS$_IVCHAN);
1278 #undef PerlIO_clearerr
1280 PerlIO_clearerr(PerlIO *f)
1283 (*PerlIOBase(f)->tab->Clearerr)(f);
1285 SETERRNO(EBADF,SS$_IVCHAN);
1288 #undef PerlIO_setlinebuf
1290 PerlIO_setlinebuf(PerlIO *f)
1293 (*PerlIOBase(f)->tab->Setlinebuf)(f);
1295 SETERRNO(EBADF,SS$_IVCHAN);
1298 #undef PerlIO_has_base
1300 PerlIO_has_base(PerlIO *f)
1302 if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); }
1306 #undef PerlIO_fast_gets
1308 PerlIO_fast_gets(PerlIO *f)
1310 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
1312 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1313 return (tab->Set_ptrcnt != NULL);
1318 #undef PerlIO_has_cntptr
1320 PerlIO_has_cntptr(PerlIO *f)
1324 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1325 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1330 #undef PerlIO_canset_cnt
1332 PerlIO_canset_cnt(PerlIO *f)
1336 PerlIOl *l = PerlIOBase(f);
1337 return (l->tab->Set_ptrcnt != NULL);
1342 #undef PerlIO_get_base
1344 PerlIO_get_base(PerlIO *f)
1347 return (*PerlIOBase(f)->tab->Get_base)(f);
1351 #undef PerlIO_get_bufsiz
1353 PerlIO_get_bufsiz(PerlIO *f)
1356 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1360 #undef PerlIO_get_ptr
1362 PerlIO_get_ptr(PerlIO *f)
1364 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1365 if (tab->Get_ptr == NULL)
1367 return (*tab->Get_ptr)(f);
1370 #undef PerlIO_get_cnt
1372 PerlIO_get_cnt(PerlIO *f)
1374 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1375 if (tab->Get_cnt == NULL)
1377 return (*tab->Get_cnt)(f);
1380 #undef PerlIO_set_cnt
1382 PerlIO_set_cnt(PerlIO *f,int cnt)
1384 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1387 #undef PerlIO_set_ptrcnt
1389 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1391 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1392 if (tab->Set_ptrcnt == NULL)
1395 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1397 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1400 /*--------------------------------------------------------------------------------------*/
1401 /* utf8 and raw dummy layers */
1404 PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg)
1409 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1410 PerlIO_pop(aTHX_ f);
1411 if (tab->kind & PERLIO_K_UTF8)
1412 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1414 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1420 PerlIO_funcs PerlIO_utf8 = {
1423 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1441 NULL, /* get_base */
1442 NULL, /* get_bufsiz */
1445 NULL, /* set_ptrcnt */
1448 PerlIO_funcs PerlIO_byte = {
1469 NULL, /* get_base */
1470 NULL, /* get_bufsiz */
1473 NULL, /* set_ptrcnt */
1477 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)
1479 PerlIO_funcs *tab = PerlIO_default_btm();
1480 return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args);
1483 PerlIO_funcs PerlIO_raw = {
1504 NULL, /* get_base */
1505 NULL, /* get_bufsiz */
1508 NULL, /* set_ptrcnt */
1510 /*--------------------------------------------------------------------------------------*/
1511 /*--------------------------------------------------------------------------------------*/
1512 /* "Methods" of the "base class" */
1515 PerlIOBase_fileno(PerlIO *f)
1517 return PerlIO_fileno(PerlIONext(f));
1521 PerlIO_modestr(PerlIO *f,char *buf)
1524 IV flags = PerlIOBase(f)->flags;
1525 if (flags & PERLIO_F_APPEND)
1528 if (flags & PERLIO_F_CANREAD)
1533 else if (flags & PERLIO_F_CANREAD)
1536 if (flags & PERLIO_F_CANWRITE)
1539 else if (flags & PERLIO_F_CANWRITE)
1542 if (flags & PERLIO_F_CANREAD)
1547 #if O_TEXT != O_BINARY
1548 if (!(flags & PERLIO_F_CRLF))
1556 PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg)
1558 PerlIOl *l = PerlIOBase(f);
1559 const char *omode = mode;
1561 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1562 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1563 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1564 if (tab->Set_ptrcnt != NULL)
1565 l->flags |= PERLIO_F_FASTGETS;
1568 if (*mode == '#' || *mode == 'I')
1573 l->flags |= PERLIO_F_CANREAD;
1576 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1579 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1582 SETERRNO(EINVAL,LIB$_INVARG);
1590 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1593 l->flags &= ~PERLIO_F_CRLF;
1596 l->flags |= PERLIO_F_CRLF;
1599 SETERRNO(EINVAL,LIB$_INVARG);
1608 l->flags |= l->next->flags &
1609 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1613 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1614 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1615 l->flags,PerlIO_modestr(f,temp));
1621 PerlIOBase_popped(PerlIO *f)
1627 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1630 Off_t old = PerlIO_tell(f);
1632 PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
1633 done = PerlIOBuf_unread(f,vbuf,count);
1634 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1639 PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count)
1641 STDCHAR *buf = (STDCHAR *) vbuf;
1644 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1648 SSize_t avail = PerlIO_get_cnt(f);
1651 take = (count < avail) ? count : avail;
1654 STDCHAR *ptr = PerlIO_get_ptr(f);
1655 Copy(ptr,buf,take,STDCHAR);
1656 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1660 if (count > 0 && avail <= 0)
1662 if (PerlIO_fill(f) != 0)
1666 return (buf - (STDCHAR *) vbuf);
1672 PerlIOBase_noop_ok(PerlIO *f)
1678 PerlIOBase_noop_fail(PerlIO *f)
1684 PerlIOBase_close(PerlIO *f)
1687 PerlIO *n = PerlIONext(f);
1688 if (PerlIO_flush(f) != 0)
1690 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1692 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1697 PerlIOBase_eof(PerlIO *f)
1701 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1707 PerlIOBase_error(PerlIO *f)
1711 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1717 PerlIOBase_clearerr(PerlIO *f)
1721 PerlIO *n = PerlIONext(f);
1722 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1729 PerlIOBase_setlinebuf(PerlIO *f)
1733 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1737 /*--------------------------------------------------------------------------------------*/
1738 /* Bottom-most level for UNIX-like case */
1742 struct _PerlIO base; /* The generic part */
1743 int fd; /* UNIX like file descriptor */
1744 int oflags; /* open/fcntl flags */
1748 PerlIOUnix_oflags(const char *mode)
1763 oflags = O_CREAT|O_TRUNC;
1774 oflags = O_CREAT|O_APPEND;
1790 else if (*mode == 't')
1793 oflags &= ~O_BINARY;
1796 /* Always open in binary mode */
1798 if (*mode || oflags == -1)
1800 SETERRNO(EINVAL,LIB$_INVARG);
1807 PerlIOUnix_fileno(PerlIO *f)
1809 return PerlIOSelf(f,PerlIOUnix)->fd;
1813 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1815 IV code = PerlIOBase_pushed(f,mode,arg);
1818 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1819 s->fd = PerlIO_fileno(PerlIONext(f));
1820 s->oflags = PerlIOUnix_oflags(mode);
1822 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1827 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)
1831 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1832 (*PerlIOBase(f)->tab->Close)(f);
1836 char *path = SvPV_nolen(*args);
1841 imode = PerlIOUnix_oflags(mode);
1846 fd = PerlLIO_open3(path,imode,perm);
1856 f = PerlIO_allocate(aTHX);
1857 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1860 s = PerlIOSelf(f,PerlIOUnix);
1863 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1870 /* FIXME: pop layers ??? */
1877 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1880 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1881 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1885 SSize_t len = PerlLIO_read(fd,vbuf,count);
1886 if (len >= 0 || errno != EINTR)
1889 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1890 else if (len == 0 && count != 0)
1891 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1899 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1902 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1905 SSize_t len = PerlLIO_write(fd,vbuf,count);
1906 if (len >= 0 || errno != EINTR)
1909 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1917 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1920 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1921 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1922 return (new == (Off_t) -1) ? -1 : 0;
1926 PerlIOUnix_tell(PerlIO *f)
1929 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1930 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1934 PerlIOUnix_close(PerlIO *f)
1937 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1939 while (PerlLIO_close(fd) != 0)
1950 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1955 PerlIO_funcs PerlIO_unix = {
1970 PerlIOBase_noop_ok, /* flush */
1971 PerlIOBase_noop_fail, /* fill */
1974 PerlIOBase_clearerr,
1975 PerlIOBase_setlinebuf,
1976 NULL, /* get_base */
1977 NULL, /* get_bufsiz */
1980 NULL, /* set_ptrcnt */
1983 /*--------------------------------------------------------------------------------------*/
1984 /* stdio as a layer */
1988 struct _PerlIO base;
1989 FILE * stdio; /* The stream */
1993 PerlIOStdio_fileno(PerlIO *f)
1996 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
2000 PerlIOStdio_mode(const char *mode,char *tmode)
2007 if (O_BINARY != O_TEXT)
2015 /* This isn't used yet ... */
2017 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2022 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2024 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2030 return PerlIOBase_pushed(f,mode,arg);
2033 #undef PerlIO_importFILE
2035 PerlIO_importFILE(FILE *stdio, int fl)
2041 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2048 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)
2053 char *path = SvPV_nolen(*args);
2054 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2055 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2065 char *path = SvPV_nolen(*args);
2069 fd = PerlLIO_open3(path,imode,perm);
2073 FILE *stdio = PerlSIO_fopen(path,mode);
2076 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2077 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2098 stdio = PerlSIO_stdin;
2101 stdio = PerlSIO_stdout;
2104 stdio = PerlSIO_stderr;
2110 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2114 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2124 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2127 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2131 STDCHAR *buf = (STDCHAR *) vbuf;
2132 /* Perl is expecting PerlIO_getc() to fill the buffer
2133 * Linux's stdio does not do that for fread()
2135 int ch = PerlSIO_fgetc(s);
2143 got = PerlSIO_fread(vbuf,1,count,s);
2148 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2151 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2152 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2156 int ch = *buf-- & 0xff;
2157 if (PerlSIO_ungetc(ch,s) != ch)
2166 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2169 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2173 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2176 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2177 return PerlSIO_fseek(stdio,offset,whence);
2181 PerlIOStdio_tell(PerlIO *f)
2184 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2185 return PerlSIO_ftell(stdio);
2189 PerlIOStdio_close(PerlIO *f)
2192 #ifdef SOCKS5_VERSION_NAME
2194 Sock_size_t optlen = sizeof(int);
2196 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2198 #ifdef SOCKS5_VERSION_NAME
2199 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2200 PerlSIO_fclose(stdio) :
2201 close(PerlIO_fileno(f))
2203 PerlSIO_fclose(stdio)
2210 PerlIOStdio_flush(PerlIO *f)
2213 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2214 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2216 return PerlSIO_fflush(stdio);
2221 /* FIXME: This discards ungetc() and pre-read stuff which is
2222 not right if this is just a "sync" from a layer above
2223 Suspect right design is to do _this_ but not have layer above
2224 flush this layer read-to-read
2226 /* Not writeable - sync by attempting a seek */
2228 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2236 PerlIOStdio_fill(PerlIO *f)
2239 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2241 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2242 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2244 if (PerlSIO_fflush(stdio) != 0)
2247 c = PerlSIO_fgetc(stdio);
2248 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2254 PerlIOStdio_eof(PerlIO *f)
2257 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2261 PerlIOStdio_error(PerlIO *f)
2264 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2268 PerlIOStdio_clearerr(PerlIO *f)
2271 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2275 PerlIOStdio_setlinebuf(PerlIO *f)
2278 #ifdef HAS_SETLINEBUF
2279 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2281 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2287 PerlIOStdio_get_base(PerlIO *f)
2290 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2291 return PerlSIO_get_base(stdio);
2295 PerlIOStdio_get_bufsiz(PerlIO *f)
2298 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2299 return PerlSIO_get_bufsiz(stdio);
2303 #ifdef USE_STDIO_PTR
2305 PerlIOStdio_get_ptr(PerlIO *f)
2308 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2309 return PerlSIO_get_ptr(stdio);
2313 PerlIOStdio_get_cnt(PerlIO *f)
2316 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2317 return PerlSIO_get_cnt(stdio);
2321 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2324 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2327 #ifdef STDIO_PTR_LVALUE
2328 PerlSIO_set_ptr(stdio,ptr);
2329 #ifdef STDIO_PTR_LVAL_SETS_CNT
2330 if (PerlSIO_get_cnt(stdio) != (cnt))
2333 assert(PerlSIO_get_cnt(stdio) == (cnt));
2336 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2337 /* Setting ptr _does_ change cnt - we are done */
2340 #else /* STDIO_PTR_LVALUE */
2342 #endif /* STDIO_PTR_LVALUE */
2344 /* Now (or only) set cnt */
2345 #ifdef STDIO_CNT_LVALUE
2346 PerlSIO_set_cnt(stdio,cnt);
2347 #else /* STDIO_CNT_LVALUE */
2348 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2349 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2350 #else /* STDIO_PTR_LVAL_SETS_CNT */
2352 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2353 #endif /* STDIO_CNT_LVALUE */
2358 PerlIO_funcs PerlIO_stdio = {
2360 sizeof(PerlIOStdio),
2377 PerlIOStdio_clearerr,
2378 PerlIOStdio_setlinebuf,
2380 PerlIOStdio_get_base,
2381 PerlIOStdio_get_bufsiz,
2386 #ifdef USE_STDIO_PTR
2387 PerlIOStdio_get_ptr,
2388 PerlIOStdio_get_cnt,
2389 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2390 PerlIOStdio_set_ptrcnt
2391 #else /* STDIO_PTR_LVALUE */
2393 #endif /* STDIO_PTR_LVALUE */
2394 #else /* USE_STDIO_PTR */
2398 #endif /* USE_STDIO_PTR */
2401 #undef PerlIO_exportFILE
2403 PerlIO_exportFILE(PerlIO *f, int fl)
2407 stdio = fdopen(PerlIO_fileno(f),"r+");
2411 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2417 #undef PerlIO_findFILE
2419 PerlIO_findFILE(PerlIO *f)
2424 if (l->tab == &PerlIO_stdio)
2426 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2429 l = *PerlIONext(&l);
2431 return PerlIO_exportFILE(f,0);
2434 #undef PerlIO_releaseFILE
2436 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2440 /*--------------------------------------------------------------------------------------*/
2441 /* perlio buffer layer */
2444 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2446 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2447 int fd = PerlIO_fileno(f);
2450 if (fd >= 0 && PerlLIO_isatty(fd))
2452 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2454 posn = PerlIO_tell(PerlIONext(f));
2455 if (posn != (Off_t) -1)
2459 return PerlIOBase_pushed(f,mode,arg);
2463 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)
2467 PerlIO *next = PerlIONext(f);
2468 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2469 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2470 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2477 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2484 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2487 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2488 fd = PerlIO_fileno(f);
2489 #if O_BINARY != O_TEXT
2490 /* do something about failing setmode()? --jhi */
2491 PerlLIO_setmode(fd , O_BINARY);
2493 if (init && fd == 2)
2495 /* Initial stderr is unbuffered */
2496 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2503 /* This "flush" is akin to sfio's sync in that it handles files in either
2507 PerlIOBuf_flush(PerlIO *f)
2509 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2511 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2513 /* write() the buffer */
2514 STDCHAR *buf = b->buf;
2516 PerlIO *n = PerlIONext(f);
2519 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2524 else if (count < 0 || PerlIO_error(n))
2526 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2531 b->posn += (p - buf);
2533 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2535 STDCHAR *buf = PerlIO_get_base(f);
2536 /* Note position change */
2537 b->posn += (b->ptr - buf);
2538 if (b->ptr < b->end)
2540 /* We did not consume all of it */
2541 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2543 b->posn = PerlIO_tell(PerlIONext(f));
2547 b->ptr = b->end = b->buf;
2548 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2549 /* FIXME: Is this right for read case ? */
2550 if (PerlIO_flush(PerlIONext(f)) != 0)
2556 PerlIOBuf_fill(PerlIO *f)
2558 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2559 PerlIO *n = PerlIONext(f);
2561 /* FIXME: doing the down-stream flush is a bad idea if it causes
2562 pre-read data in stdio buffer to be discarded
2563 but this is too simplistic - as it skips _our_ hosekeeping
2564 and breaks tell tests.
2565 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2569 if (PerlIO_flush(f) != 0)
2571 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2572 PerlIOBase_flush_linebuf();
2575 PerlIO_get_base(f); /* allocate via vtable */
2577 b->ptr = b->end = b->buf;
2578 if (PerlIO_fast_gets(n))
2580 /* Layer below is also buffered
2581 * We do _NOT_ want to call its ->Read() because that will loop
2582 * till it gets what we asked for which may hang on a pipe etc.
2583 * Instead take anything it has to hand, or ask it to fill _once_.
2585 avail = PerlIO_get_cnt(n);
2588 avail = PerlIO_fill(n);
2590 avail = PerlIO_get_cnt(n);
2593 if (!PerlIO_error(n) && PerlIO_eof(n))
2599 STDCHAR *ptr = PerlIO_get_ptr(n);
2600 SSize_t cnt = avail;
2601 if (avail > b->bufsiz)
2603 Copy(ptr,b->buf,avail,STDCHAR);
2604 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2609 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2614 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2616 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2619 b->end = b->buf+avail;
2620 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2625 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2627 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2632 return PerlIOBase_read(f,vbuf,count);
2638 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2640 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2641 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2644 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2650 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2652 avail = (b->ptr - b->buf);
2657 b->end = b->buf + avail;
2659 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2660 b->posn -= b->bufsiz;
2662 if (avail > (SSize_t) count)
2670 Copy(buf,b->ptr,avail,STDCHAR);
2674 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2681 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2683 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2684 const STDCHAR *buf = (const STDCHAR *) vbuf;
2688 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2692 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2693 if ((SSize_t) count < avail)
2695 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2696 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2716 Copy(buf,b->ptr,avail,STDCHAR);
2723 if (b->ptr >= (b->buf + b->bufsiz))
2726 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2732 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2735 if ((code = PerlIO_flush(f)) == 0)
2737 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2738 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2739 code = PerlIO_seek(PerlIONext(f),offset,whence);
2742 b->posn = PerlIO_tell(PerlIONext(f));
2749 PerlIOBuf_tell(PerlIO *f)
2751 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2752 Off_t posn = b->posn;
2754 posn += (b->ptr - b->buf);
2759 PerlIOBuf_close(PerlIO *f)
2762 IV code = PerlIOBase_close(f);
2763 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2764 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2766 PerlMemShared_free(b->buf);
2769 b->ptr = b->end = b->buf;
2770 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2775 PerlIOBuf_get_ptr(PerlIO *f)
2777 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2784 PerlIOBuf_get_cnt(PerlIO *f)
2786 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2789 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2790 return (b->end - b->ptr);
2795 PerlIOBuf_get_base(PerlIO *f)
2797 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2803 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2806 b->buf = (STDCHAR *)&b->oneword;
2807 b->bufsiz = sizeof(b->oneword);
2816 PerlIOBuf_bufsiz(PerlIO *f)
2818 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2821 return (b->end - b->buf);
2825 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2827 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2831 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2834 assert(PerlIO_get_cnt(f) == cnt);
2835 assert(b->ptr >= b->buf);
2837 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2840 PerlIO_funcs PerlIO_perlio = {
2859 PerlIOBase_clearerr,
2860 PerlIOBase_setlinebuf,
2865 PerlIOBuf_set_ptrcnt,
2868 /*--------------------------------------------------------------------------------------*/
2869 /* Temp layer to hold unread chars when cannot do it any other way */
2872 PerlIOPending_fill(PerlIO *f)
2874 /* Should never happen */
2880 PerlIOPending_close(PerlIO *f)
2882 /* A tad tricky - flush pops us, then we close new top */
2884 return PerlIO_close(f);
2888 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2890 /* A tad tricky - flush pops us, then we seek new top */
2892 return PerlIO_seek(f,offset,whence);
2897 PerlIOPending_flush(PerlIO *f)
2900 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2901 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2903 PerlMemShared_free(b->buf);
2906 PerlIO_pop(aTHX_ f);
2911 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2919 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2924 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2926 IV code = PerlIOBase_pushed(f,mode,arg);
2927 PerlIOl *l = PerlIOBase(f);
2928 /* Our PerlIO_fast_gets must match what we are pushed on,
2929 or sv_gets() etc. get muddled when it changes mid-string
2932 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2933 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2938 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2940 SSize_t avail = PerlIO_get_cnt(f);
2945 got = PerlIOBuf_read(f,vbuf,avail);
2946 if (got >= 0 && got < count)
2948 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2949 if (more >= 0 || got == 0)
2955 PerlIO_funcs PerlIO_pending = {
2959 PerlIOPending_pushed,
2969 PerlIOPending_close,
2970 PerlIOPending_flush,
2974 PerlIOBase_clearerr,
2975 PerlIOBase_setlinebuf,
2980 PerlIOPending_set_ptrcnt,
2985 /*--------------------------------------------------------------------------------------*/
2986 /* crlf - translation
2987 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2988 to hand back a line at a time and keeping a record of which nl we "lied" about.
2989 On write translate "\n" to CR,LF
2994 PerlIOBuf base; /* PerlIOBuf stuff */
2995 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2999 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3002 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3003 code = PerlIOBuf_pushed(f,mode,arg);
3005 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3006 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3007 PerlIOBase(f)->flags);
3014 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3016 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3022 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3023 return PerlIOBuf_unread(f,vbuf,count);
3026 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3027 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3029 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3035 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3037 b->end = b->ptr = b->buf + b->bufsiz;
3038 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3039 b->posn -= b->bufsiz;
3041 while (count > 0 && b->ptr > b->buf)
3046 if (b->ptr - 2 >= b->buf)
3072 PerlIOCrlf_get_cnt(PerlIO *f)
3074 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3077 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3079 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3080 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3082 STDCHAR *nl = b->ptr;
3084 while (nl < b->end && *nl != 0xd)
3086 if (nl < b->end && *nl == 0xd)
3098 /* Not CR,LF but just CR */
3105 /* Blast - found CR as last char in buffer */
3108 /* They may not care, defer work as long as possible */
3109 return (nl - b->ptr);
3115 b->ptr++; /* say we have read it as far as flush() is concerned */
3116 b->buf++; /* Leave space an front of buffer */
3117 b->bufsiz--; /* Buffer is thus smaller */
3118 code = PerlIO_fill(f); /* Fetch some more */
3119 b->bufsiz++; /* Restore size for next time */
3120 b->buf--; /* Point at space */
3121 b->ptr = nl = b->buf; /* Which is what we hand off */
3122 b->posn--; /* Buffer starts here */
3123 *nl = 0xd; /* Fill in the CR */
3125 goto test; /* fill() call worked */
3126 /* CR at EOF - just fall through */
3131 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3137 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3139 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3140 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3141 IV flags = PerlIOBase(f)->flags;
3151 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3158 /* Test code - delete when it works ... */
3165 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3173 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3174 ptr, chk, flags, c->nl, b->end, cnt);
3181 /* They have taken what we lied about */
3188 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3192 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3194 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3195 return PerlIOBuf_write(f,vbuf,count);
3198 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3199 const STDCHAR *buf = (const STDCHAR *) vbuf;
3200 const STDCHAR *ebuf = buf+count;
3203 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3207 STDCHAR *eptr = b->buf+b->bufsiz;
3208 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3209 while (buf < ebuf && b->ptr < eptr)
3213 if ((b->ptr + 2) > eptr)
3215 /* Not room for both */
3221 *(b->ptr)++ = 0xd; /* CR */
3222 *(b->ptr)++ = 0xa; /* LF */
3224 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3243 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3245 return (buf - (STDCHAR *) vbuf);
3250 PerlIOCrlf_flush(PerlIO *f)
3252 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3258 return PerlIOBuf_flush(f);
3261 PerlIO_funcs PerlIO_crlf = {
3264 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3266 PerlIOBase_noop_ok, /* popped */
3270 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3271 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3272 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3280 PerlIOBase_clearerr,
3281 PerlIOBase_setlinebuf,
3286 PerlIOCrlf_set_ptrcnt,
3290 /*--------------------------------------------------------------------------------------*/
3291 /* mmap as "buffer" layer */
3295 PerlIOBuf base; /* PerlIOBuf stuff */
3296 Mmap_t mptr; /* Mapped address */
3297 Size_t len; /* mapped length */
3298 STDCHAR *bbuf; /* malloced buffer if map fails */
3301 static size_t page_size = 0;
3304 PerlIOMmap_map(PerlIO *f)
3307 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3308 PerlIOBuf *b = &m->base;
3309 IV flags = PerlIOBase(f)->flags;
3313 if (flags & PERLIO_F_CANREAD)
3315 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3316 int fd = PerlIO_fileno(f);
3318 code = fstat(fd,&st);
3319 if (code == 0 && S_ISREG(st.st_mode))
3321 SSize_t len = st.st_size - b->posn;
3326 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3328 SETERRNO(0,SS$_NORMAL);
3329 # ifdef _SC_PAGESIZE
3330 page_size = sysconf(_SC_PAGESIZE);
3332 page_size = sysconf(_SC_PAGE_SIZE);
3334 if ((long)page_size < 0) {
3339 (void)SvUPGRADE(error, SVt_PV);
3340 msg = SvPVx(error, n_a);
3341 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3344 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3348 # ifdef HAS_GETPAGESIZE
3349 page_size = getpagesize();
3351 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3352 page_size = PAGESIZE; /* compiletime, bad */
3356 if ((IV)page_size <= 0)
3357 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3361 /* This is a hack - should never happen - open should have set it ! */
3362 b->posn = PerlIO_tell(PerlIONext(f));
3364 posn = (b->posn / page_size) * page_size;
3365 len = st.st_size - posn;
3366 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3367 if (m->mptr && m->mptr != (Mmap_t) -1)
3369 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3370 madvise(m->mptr, len, MADV_SEQUENTIAL);
3372 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3373 madvise(m->mptr, len, MADV_WILLNEED);
3375 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3376 b->end = ((STDCHAR *)m->mptr) + len;
3377 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3388 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3390 b->ptr = b->end = b->ptr;
3399 PerlIOMmap_unmap(PerlIO *f)
3401 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3402 PerlIOBuf *b = &m->base;
3408 code = munmap(m->mptr, m->len);
3412 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3415 b->ptr = b->end = b->buf;
3416 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3422 PerlIOMmap_get_base(PerlIO *f)
3424 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3425 PerlIOBuf *b = &m->base;
3426 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3428 /* Already have a readbuffer in progress */
3433 /* We have a write buffer or flushed PerlIOBuf read buffer */
3434 m->bbuf = b->buf; /* save it in case we need it again */
3435 b->buf = NULL; /* Clear to trigger below */
3439 PerlIOMmap_map(f); /* Try and map it */
3442 /* Map did not work - recover PerlIOBuf buffer if we have one */
3446 b->ptr = b->end = b->buf;
3449 return PerlIOBuf_get_base(f);
3453 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3455 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3456 PerlIOBuf *b = &m->base;
3457 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3459 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3462 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3467 /* Loose the unwritable mapped buffer */
3469 /* If flush took the "buffer" see if we have one from before */
3470 if (!b->buf && m->bbuf)
3474 PerlIOBuf_get_base(f);
3478 return PerlIOBuf_unread(f,vbuf,count);
3482 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3484 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3485 PerlIOBuf *b = &m->base;
3486 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3488 /* No, or wrong sort of, buffer */
3491 if (PerlIOMmap_unmap(f) != 0)
3494 /* If unmap took the "buffer" see if we have one from before */
3495 if (!b->buf && m->bbuf)
3499 PerlIOBuf_get_base(f);
3503 return PerlIOBuf_write(f,vbuf,count);
3507 PerlIOMmap_flush(PerlIO *f)
3509 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3510 PerlIOBuf *b = &m->base;
3511 IV code = PerlIOBuf_flush(f);
3512 /* Now we are "synced" at PerlIOBuf level */
3517 /* Unmap the buffer */
3518 if (PerlIOMmap_unmap(f) != 0)
3523 /* We seem to have a PerlIOBuf buffer which was not mapped
3524 * remember it in case we need one later
3533 PerlIOMmap_fill(PerlIO *f)
3535 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3536 IV code = PerlIO_flush(f);
3537 if (code == 0 && !b->buf)
3539 code = PerlIOMmap_map(f);
3541 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3543 code = PerlIOBuf_fill(f);
3549 PerlIOMmap_close(PerlIO *f)
3551 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3552 PerlIOBuf *b = &m->base;
3553 IV code = PerlIO_flush(f);
3558 b->ptr = b->end = b->buf;
3560 if (PerlIOBuf_close(f) != 0)
3566 PerlIO_funcs PerlIO_mmap = {
3585 PerlIOBase_clearerr,
3586 PerlIOBase_setlinebuf,
3587 PerlIOMmap_get_base,
3591 PerlIOBuf_set_ptrcnt,
3594 #endif /* HAS_MMAP */
3602 atexit(&PerlIO_cleanup);
3614 PerlIO_stdstreams(aTHX);
3619 #undef PerlIO_stdout
3626 PerlIO_stdstreams(aTHX);
3631 #undef PerlIO_stderr
3638 PerlIO_stdstreams(aTHX);
3643 /*--------------------------------------------------------------------------------------*/
3645 #undef PerlIO_getname
3647 PerlIO_getname(PerlIO *f, char *buf)
3650 Perl_croak(aTHX_ "Don't know how to get file name");
3655 /*--------------------------------------------------------------------------------------*/
3656 /* Functions which can be called on any kind of PerlIO implemented
3662 PerlIO_getc(PerlIO *f)
3665 SSize_t count = PerlIO_read(f,buf,1);
3668 return (unsigned char) buf[0];
3673 #undef PerlIO_ungetc
3675 PerlIO_ungetc(PerlIO *f, int ch)
3680 if (PerlIO_unread(f,&buf,1) == 1)
3688 PerlIO_putc(PerlIO *f, int ch)
3691 return PerlIO_write(f,&buf,1);
3696 PerlIO_puts(PerlIO *f, const char *s)
3698 STRLEN len = strlen(s);
3699 return PerlIO_write(f,s,len);
3702 #undef PerlIO_rewind
3704 PerlIO_rewind(PerlIO *f)
3706 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3710 #undef PerlIO_vprintf
3712 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3715 SV *sv = newSVpvn("",0);
3721 Perl_va_copy(ap, apc);
3722 sv_vcatpvf(sv, fmt, &apc);
3724 sv_vcatpvf(sv, fmt, &ap);
3727 wrote = PerlIO_write(f,s,len);
3732 #undef PerlIO_printf
3734 PerlIO_printf(PerlIO *f,const char *fmt,...)
3739 result = PerlIO_vprintf(f,fmt,ap);
3744 #undef PerlIO_stdoutf
3746 PerlIO_stdoutf(const char *fmt,...)
3751 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3756 #undef PerlIO_tmpfile
3758 PerlIO_tmpfile(void)
3760 /* I have no idea how portable mkstemp() is ... */
3761 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3764 FILE *stdio = PerlSIO_tmpfile();
3767 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3773 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3774 int fd = mkstemp(SvPVX(sv));
3778 f = PerlIO_fdopen(fd,"w+");
3781 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3783 PerlLIO_unlink(SvPVX(sv));
3793 #endif /* USE_SFIO */
3794 #endif /* PERLIO_IS_STDIO */
3796 /*======================================================================================*/
3797 /* Now some functions in terms of above which may be needed even if
3798 we are not in true PerlIO mode
3802 #undef PerlIO_setpos
3804 PerlIO_setpos(PerlIO *f, SV *pos)
3810 Off_t *posn = (Off_t *) SvPV(pos,len);
3811 if (f && len == sizeof(Off_t))
3812 return PerlIO_seek(f,*posn,SEEK_SET);
3814 SETERRNO(EINVAL,SS$_IVCHAN);
3818 #undef PerlIO_setpos
3820 PerlIO_setpos(PerlIO *f, SV *pos)
3826 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3827 if (f && len == sizeof(Fpos_t))
3829 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3830 return fsetpos64(f, fpos);
3832 return fsetpos(f, fpos);
3836 SETERRNO(EINVAL,SS$_IVCHAN);
3842 #undef PerlIO_getpos
3844 PerlIO_getpos(PerlIO *f, SV *pos)
3847 Off_t posn = PerlIO_tell(f);
3848 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3849 return (posn == (Off_t)-1) ? -1 : 0;
3852 #undef PerlIO_getpos
3854 PerlIO_getpos(PerlIO *f, SV *pos)
3859 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3860 code = fgetpos64(f, &fpos);
3862 code = fgetpos(f, &fpos);
3864 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3869 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3872 vprintf(char *pat, char *args)
3874 _doprnt(pat, args, stdout);
3875 return 0; /* wrong, but perl doesn't use the return value */
3879 vfprintf(FILE *fd, char *pat, char *args)
3881 _doprnt(pat, args, fd);
3882 return 0; /* wrong, but perl doesn't use the return value */
3887 #ifndef PerlIO_vsprintf
3889 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3891 int val = vsprintf(s, fmt, ap);
3894 if (strlen(s) >= (STRLEN)n)
3897 (void)PerlIO_puts(Perl_error_log,
3898 "panic: sprintf overflow - memory corrupted!\n");
3906 #ifndef PerlIO_sprintf
3908 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3913 result = PerlIO_vsprintf(s, n, fmt, ap);