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)
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);
1649 SSize_t take = (count < avail) ? count : avail;
1652 STDCHAR *ptr = PerlIO_get_ptr(f);
1653 Copy(ptr,buf,take,STDCHAR);
1654 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1658 if (count > 0 && avail <= 0)
1660 if (PerlIO_fill(f) != 0)
1664 return (buf - (STDCHAR *) vbuf);
1670 PerlIOBase_noop_ok(PerlIO *f)
1676 PerlIOBase_noop_fail(PerlIO *f)
1682 PerlIOBase_close(PerlIO *f)
1685 PerlIO *n = PerlIONext(f);
1686 if (PerlIO_flush(f) != 0)
1688 if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1690 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1695 PerlIOBase_eof(PerlIO *f)
1699 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1705 PerlIOBase_error(PerlIO *f)
1709 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1715 PerlIOBase_clearerr(PerlIO *f)
1719 PerlIO *n = PerlIONext(f);
1720 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1727 PerlIOBase_setlinebuf(PerlIO *f)
1731 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1735 /*--------------------------------------------------------------------------------------*/
1736 /* Bottom-most level for UNIX-like case */
1740 struct _PerlIO base; /* The generic part */
1741 int fd; /* UNIX like file descriptor */
1742 int oflags; /* open/fcntl flags */
1746 PerlIOUnix_oflags(const char *mode)
1761 oflags = O_CREAT|O_TRUNC;
1772 oflags = O_CREAT|O_APPEND;
1788 else if (*mode == 't')
1791 oflags &= ~O_BINARY;
1794 /* Always open in binary mode */
1796 if (*mode || oflags == -1)
1798 SETERRNO(EINVAL,LIB$_INVARG);
1805 PerlIOUnix_fileno(PerlIO *f)
1807 return PerlIOSelf(f,PerlIOUnix)->fd;
1811 PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg)
1813 IV code = PerlIOBase_pushed(f,mode,arg);
1816 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1817 s->fd = PerlIO_fileno(PerlIONext(f));
1818 s->oflags = PerlIOUnix_oflags(mode);
1820 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1825 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)
1829 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1830 (*PerlIOBase(f)->tab->Close)(f);
1834 char *path = SvPV_nolen(*args);
1839 imode = PerlIOUnix_oflags(mode);
1844 fd = PerlLIO_open3(path,imode,perm);
1854 f = PerlIO_allocate(aTHX);
1855 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
1858 s = PerlIOSelf(f,PerlIOUnix);
1861 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1868 /* FIXME: pop layers ??? */
1875 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1878 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1879 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1883 SSize_t len = PerlLIO_read(fd,vbuf,count);
1884 if (len >= 0 || errno != EINTR)
1887 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1888 else if (len == 0 && count != 0)
1889 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1897 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1900 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1903 SSize_t len = PerlLIO_write(fd,vbuf,count);
1904 if (len >= 0 || errno != EINTR)
1907 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1915 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1918 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1919 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1920 return (new == (Off_t) -1) ? -1 : 0;
1924 PerlIOUnix_tell(PerlIO *f)
1927 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1928 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1932 PerlIOUnix_close(PerlIO *f)
1935 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1937 while (PerlLIO_close(fd) != 0)
1948 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1953 PerlIO_funcs PerlIO_unix = {
1968 PerlIOBase_noop_ok, /* flush */
1969 PerlIOBase_noop_fail, /* fill */
1972 PerlIOBase_clearerr,
1973 PerlIOBase_setlinebuf,
1974 NULL, /* get_base */
1975 NULL, /* get_bufsiz */
1978 NULL, /* set_ptrcnt */
1981 /*--------------------------------------------------------------------------------------*/
1982 /* stdio as a layer */
1986 struct _PerlIO base;
1987 FILE * stdio; /* The stream */
1991 PerlIOStdio_fileno(PerlIO *f)
1994 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1998 PerlIOStdio_mode(const char *mode,char *tmode)
2005 if (O_BINARY != O_TEXT)
2013 /* This isn't used yet ... */
2015 PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
2020 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2022 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2028 return PerlIOBase_pushed(f,mode,arg);
2031 #undef PerlIO_importFILE
2033 PerlIO_importFILE(FILE *stdio, int fl)
2039 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2046 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)
2051 char *path = SvPV_nolen(*args);
2052 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2053 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2063 char *path = SvPV_nolen(*args);
2067 fd = PerlLIO_open3(path,imode,perm);
2071 FILE *stdio = PerlSIO_fopen(path,mode);
2074 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
2075 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
2096 stdio = PerlSIO_stdin;
2099 stdio = PerlSIO_stdout;
2102 stdio = PerlSIO_stderr;
2108 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2112 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
2122 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2125 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2129 STDCHAR *buf = (STDCHAR *) vbuf;
2130 /* Perl is expecting PerlIO_getc() to fill the buffer
2131 * Linux's stdio does not do that for fread()
2133 int ch = PerlSIO_fgetc(s);
2141 got = PerlSIO_fread(vbuf,1,count,s);
2146 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2149 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2150 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2154 int ch = *buf-- & 0xff;
2155 if (PerlSIO_ungetc(ch,s) != ch)
2164 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2167 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
2171 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2174 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2175 return PerlSIO_fseek(stdio,offset,whence);
2179 PerlIOStdio_tell(PerlIO *f)
2182 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2183 return PerlSIO_ftell(stdio);
2187 PerlIOStdio_close(PerlIO *f)
2190 #ifdef SOCKS5_VERSION_NAME
2192 Sock_size_t optlen = sizeof(int);
2194 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2196 #ifdef SOCKS5_VERSION_NAME
2197 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
2198 PerlSIO_fclose(stdio) :
2199 close(PerlIO_fileno(f))
2201 PerlSIO_fclose(stdio)
2208 PerlIOStdio_flush(PerlIO *f)
2211 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2212 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2214 return PerlSIO_fflush(stdio);
2219 /* FIXME: This discards ungetc() and pre-read stuff which is
2220 not right if this is just a "sync" from a layer above
2221 Suspect right design is to do _this_ but not have layer above
2222 flush this layer read-to-read
2224 /* Not writeable - sync by attempting a seek */
2226 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
2234 PerlIOStdio_fill(PerlIO *f)
2237 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2239 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2240 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2242 if (PerlSIO_fflush(stdio) != 0)
2245 c = PerlSIO_fgetc(stdio);
2246 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
2252 PerlIOStdio_eof(PerlIO *f)
2255 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
2259 PerlIOStdio_error(PerlIO *f)
2262 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
2266 PerlIOStdio_clearerr(PerlIO *f)
2269 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
2273 PerlIOStdio_setlinebuf(PerlIO *f)
2276 #ifdef HAS_SETLINEBUF
2277 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
2279 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2285 PerlIOStdio_get_base(PerlIO *f)
2288 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2289 return PerlSIO_get_base(stdio);
2293 PerlIOStdio_get_bufsiz(PerlIO *f)
2296 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2297 return PerlSIO_get_bufsiz(stdio);
2301 #ifdef USE_STDIO_PTR
2303 PerlIOStdio_get_ptr(PerlIO *f)
2306 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2307 return PerlSIO_get_ptr(stdio);
2311 PerlIOStdio_get_cnt(PerlIO *f)
2314 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2315 return PerlSIO_get_cnt(stdio);
2319 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2322 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2325 #ifdef STDIO_PTR_LVALUE
2326 PerlSIO_set_ptr(stdio,ptr);
2327 #ifdef STDIO_PTR_LVAL_SETS_CNT
2328 if (PerlSIO_get_cnt(stdio) != (cnt))
2331 assert(PerlSIO_get_cnt(stdio) == (cnt));
2334 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2335 /* Setting ptr _does_ change cnt - we are done */
2338 #else /* STDIO_PTR_LVALUE */
2340 #endif /* STDIO_PTR_LVALUE */
2342 /* Now (or only) set cnt */
2343 #ifdef STDIO_CNT_LVALUE
2344 PerlSIO_set_cnt(stdio,cnt);
2345 #else /* STDIO_CNT_LVALUE */
2346 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2347 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2348 #else /* STDIO_PTR_LVAL_SETS_CNT */
2350 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2351 #endif /* STDIO_CNT_LVALUE */
2356 PerlIO_funcs PerlIO_stdio = {
2358 sizeof(PerlIOStdio),
2375 PerlIOStdio_clearerr,
2376 PerlIOStdio_setlinebuf,
2378 PerlIOStdio_get_base,
2379 PerlIOStdio_get_bufsiz,
2384 #ifdef USE_STDIO_PTR
2385 PerlIOStdio_get_ptr,
2386 PerlIOStdio_get_cnt,
2387 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2388 PerlIOStdio_set_ptrcnt
2389 #else /* STDIO_PTR_LVALUE */
2391 #endif /* STDIO_PTR_LVALUE */
2392 #else /* USE_STDIO_PTR */
2396 #endif /* USE_STDIO_PTR */
2399 #undef PerlIO_exportFILE
2401 PerlIO_exportFILE(PerlIO *f, int fl)
2405 stdio = fdopen(PerlIO_fileno(f),"r+");
2409 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
2415 #undef PerlIO_findFILE
2417 PerlIO_findFILE(PerlIO *f)
2422 if (l->tab == &PerlIO_stdio)
2424 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2427 l = *PerlIONext(&l);
2429 return PerlIO_exportFILE(f,0);
2432 #undef PerlIO_releaseFILE
2434 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2438 /*--------------------------------------------------------------------------------------*/
2439 /* perlio buffer layer */
2442 PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
2444 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2445 int fd = PerlIO_fileno(f);
2448 if (fd >= 0 && PerlLIO_isatty(fd))
2450 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
2452 posn = PerlIO_tell(PerlIONext(f));
2453 if (posn != (Off_t) -1)
2457 return PerlIOBase_pushed(f,mode,arg);
2461 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)
2465 PerlIO *next = PerlIONext(f);
2466 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab);
2467 next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args);
2468 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
2475 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm());
2482 f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args);
2485 PerlIOBuf *b = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOBuf);
2486 fd = PerlIO_fileno(f);
2487 #if O_BINARY != O_TEXT
2488 /* do something about failing setmode()? --jhi */
2489 PerlLIO_setmode(fd , O_BINARY);
2491 if (init && fd == 2)
2493 /* Initial stderr is unbuffered */
2494 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2501 /* This "flush" is akin to sfio's sync in that it handles files in either
2505 PerlIOBuf_flush(PerlIO *f)
2507 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2509 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2511 /* write() the buffer */
2512 STDCHAR *buf = b->buf;
2514 PerlIO *n = PerlIONext(f);
2517 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2522 else if (count < 0 || PerlIO_error(n))
2524 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2529 b->posn += (p - buf);
2531 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2533 STDCHAR *buf = PerlIO_get_base(f);
2534 /* Note position change */
2535 b->posn += (b->ptr - buf);
2536 if (b->ptr < b->end)
2538 /* We did not consume all of it */
2539 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2541 b->posn = PerlIO_tell(PerlIONext(f));
2545 b->ptr = b->end = b->buf;
2546 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2547 /* FIXME: Is this right for read case ? */
2548 if (PerlIO_flush(PerlIONext(f)) != 0)
2554 PerlIOBuf_fill(PerlIO *f)
2556 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2557 PerlIO *n = PerlIONext(f);
2559 /* FIXME: doing the down-stream flush is a bad idea if it causes
2560 pre-read data in stdio buffer to be discarded
2561 but this is too simplistic - as it skips _our_ hosekeeping
2562 and breaks tell tests.
2563 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2567 if (PerlIO_flush(f) != 0)
2569 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2570 PerlIOBase_flush_linebuf();
2573 PerlIO_get_base(f); /* allocate via vtable */
2575 b->ptr = b->end = b->buf;
2576 if (PerlIO_fast_gets(n))
2578 /* Layer below is also buffered
2579 * We do _NOT_ want to call its ->Read() because that will loop
2580 * till it gets what we asked for which may hang on a pipe etc.
2581 * Instead take anything it has to hand, or ask it to fill _once_.
2583 avail = PerlIO_get_cnt(n);
2586 avail = PerlIO_fill(n);
2588 avail = PerlIO_get_cnt(n);
2591 if (!PerlIO_error(n) && PerlIO_eof(n))
2597 STDCHAR *ptr = PerlIO_get_ptr(n);
2598 SSize_t cnt = avail;
2599 if (avail > b->bufsiz)
2601 Copy(ptr,b->buf,avail,STDCHAR);
2602 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2607 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2612 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2614 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2617 b->end = b->buf+avail;
2618 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2623 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2625 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2630 return PerlIOBase_read(f,vbuf,count);
2636 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2638 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2639 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2642 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2648 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2650 avail = (b->ptr - b->buf);
2655 b->end = b->buf + avail;
2657 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2658 b->posn -= b->bufsiz;
2660 if (avail > (SSize_t) count)
2668 Copy(buf,b->ptr,avail,STDCHAR);
2672 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2679 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2681 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2682 const STDCHAR *buf = (const STDCHAR *) vbuf;
2686 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2690 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2691 if ((SSize_t) count < avail)
2693 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2694 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2714 Copy(buf,b->ptr,avail,STDCHAR);
2721 if (b->ptr >= (b->buf + b->bufsiz))
2724 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2730 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2733 if ((code = PerlIO_flush(f)) == 0)
2735 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2736 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2737 code = PerlIO_seek(PerlIONext(f),offset,whence);
2740 b->posn = PerlIO_tell(PerlIONext(f));
2747 PerlIOBuf_tell(PerlIO *f)
2749 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2750 Off_t posn = b->posn;
2752 posn += (b->ptr - b->buf);
2757 PerlIOBuf_close(PerlIO *f)
2760 IV code = PerlIOBase_close(f);
2761 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2762 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2764 PerlMemShared_free(b->buf);
2767 b->ptr = b->end = b->buf;
2768 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2773 PerlIOBuf_get_ptr(PerlIO *f)
2775 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2782 PerlIOBuf_get_cnt(PerlIO *f)
2784 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2787 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2788 return (b->end - b->ptr);
2793 PerlIOBuf_get_base(PerlIO *f)
2795 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2801 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2804 b->buf = (STDCHAR *)&b->oneword;
2805 b->bufsiz = sizeof(b->oneword);
2814 PerlIOBuf_bufsiz(PerlIO *f)
2816 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2819 return (b->end - b->buf);
2823 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2825 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2829 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2832 assert(PerlIO_get_cnt(f) == cnt);
2833 assert(b->ptr >= b->buf);
2835 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2838 PerlIO_funcs PerlIO_perlio = {
2857 PerlIOBase_clearerr,
2858 PerlIOBase_setlinebuf,
2863 PerlIOBuf_set_ptrcnt,
2866 /*--------------------------------------------------------------------------------------*/
2867 /* Temp layer to hold unread chars when cannot do it any other way */
2870 PerlIOPending_fill(PerlIO *f)
2872 /* Should never happen */
2878 PerlIOPending_close(PerlIO *f)
2880 /* A tad tricky - flush pops us, then we close new top */
2882 return PerlIO_close(f);
2886 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2888 /* A tad tricky - flush pops us, then we seek new top */
2890 return PerlIO_seek(f,offset,whence);
2895 PerlIOPending_flush(PerlIO *f)
2898 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2899 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2901 PerlMemShared_free(b->buf);
2904 PerlIO_pop(aTHX_ f);
2909 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2917 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2922 PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
2924 IV code = PerlIOBase_pushed(f,mode,arg);
2925 PerlIOl *l = PerlIOBase(f);
2926 /* Our PerlIO_fast_gets must match what we are pushed on,
2927 or sv_gets() etc. get muddled when it changes mid-string
2930 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2931 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2936 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2938 SSize_t avail = PerlIO_get_cnt(f);
2943 got = PerlIOBuf_read(f,vbuf,avail);
2944 if (got >= 0 && got < count)
2946 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2947 if (more >= 0 || got == 0)
2953 PerlIO_funcs PerlIO_pending = {
2957 PerlIOPending_pushed,
2967 PerlIOPending_close,
2968 PerlIOPending_flush,
2972 PerlIOBase_clearerr,
2973 PerlIOBase_setlinebuf,
2978 PerlIOPending_set_ptrcnt,
2983 /*--------------------------------------------------------------------------------------*/
2984 /* crlf - translation
2985 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2986 to hand back a line at a time and keeping a record of which nl we "lied" about.
2987 On write translate "\n" to CR,LF
2992 PerlIOBuf base; /* PerlIOBuf stuff */
2993 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2997 PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
3000 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3001 code = PerlIOBuf_pushed(f,mode,arg);
3003 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
3004 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
3005 PerlIOBase(f)->flags);
3012 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3014 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3020 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3021 return PerlIOBuf_unread(f,vbuf,count);
3024 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
3025 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3027 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3033 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3035 b->end = b->ptr = b->buf + b->bufsiz;
3036 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3037 b->posn -= b->bufsiz;
3039 while (count > 0 && b->ptr > b->buf)
3044 if (b->ptr - 2 >= b->buf)
3070 PerlIOCrlf_get_cnt(PerlIO *f)
3072 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3075 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3077 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3078 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
3080 STDCHAR *nl = b->ptr;
3082 while (nl < b->end && *nl != 0xd)
3084 if (nl < b->end && *nl == 0xd)
3096 /* Not CR,LF but just CR */
3103 /* Blast - found CR as last char in buffer */
3106 /* They may not care, defer work as long as possible */
3107 return (nl - b->ptr);
3113 b->ptr++; /* say we have read it as far as flush() is concerned */
3114 b->buf++; /* Leave space an front of buffer */
3115 b->bufsiz--; /* Buffer is thus smaller */
3116 code = PerlIO_fill(f); /* Fetch some more */
3117 b->bufsiz++; /* Restore size for next time */
3118 b->buf--; /* Point at space */
3119 b->ptr = nl = b->buf; /* Which is what we hand off */
3120 b->posn--; /* Buffer starts here */
3121 *nl = 0xd; /* Fill in the CR */
3123 goto test; /* fill() call worked */
3124 /* CR at EOF - just fall through */
3129 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3135 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3137 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3138 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3139 IV flags = PerlIOBase(f)->flags;
3149 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
3156 /* Test code - delete when it works ... */
3163 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
3171 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
3172 ptr, chk, flags, c->nl, b->end, cnt);
3179 /* They have taken what we lied about */
3186 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3190 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3192 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3193 return PerlIOBuf_write(f,vbuf,count);
3196 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3197 const STDCHAR *buf = (const STDCHAR *) vbuf;
3198 const STDCHAR *ebuf = buf+count;
3201 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3205 STDCHAR *eptr = b->buf+b->bufsiz;
3206 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3207 while (buf < ebuf && b->ptr < eptr)
3211 if ((b->ptr + 2) > eptr)
3213 /* Not room for both */
3219 *(b->ptr)++ = 0xd; /* CR */
3220 *(b->ptr)++ = 0xa; /* LF */
3222 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3241 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3243 return (buf - (STDCHAR *) vbuf);
3248 PerlIOCrlf_flush(PerlIO *f)
3250 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3256 return PerlIOBuf_flush(f);
3259 PerlIO_funcs PerlIO_crlf = {
3262 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
3264 PerlIOBase_noop_ok, /* popped */
3268 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3269 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3270 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3278 PerlIOBase_clearerr,
3279 PerlIOBase_setlinebuf,
3284 PerlIOCrlf_set_ptrcnt,
3288 /*--------------------------------------------------------------------------------------*/
3289 /* mmap as "buffer" layer */
3293 PerlIOBuf base; /* PerlIOBuf stuff */
3294 Mmap_t mptr; /* Mapped address */
3295 Size_t len; /* mapped length */
3296 STDCHAR *bbuf; /* malloced buffer if map fails */
3299 static size_t page_size = 0;
3302 PerlIOMmap_map(PerlIO *f)
3305 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3306 PerlIOBuf *b = &m->base;
3307 IV flags = PerlIOBase(f)->flags;
3311 if (flags & PERLIO_F_CANREAD)
3313 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3314 int fd = PerlIO_fileno(f);
3316 code = fstat(fd,&st);
3317 if (code == 0 && S_ISREG(st.st_mode))
3319 SSize_t len = st.st_size - b->posn;
3324 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3326 SETERRNO(0,SS$_NORMAL);
3327 # ifdef _SC_PAGESIZE
3328 page_size = sysconf(_SC_PAGESIZE);
3330 page_size = sysconf(_SC_PAGE_SIZE);
3332 if ((long)page_size < 0) {
3337 (void)SvUPGRADE(error, SVt_PV);
3338 msg = SvPVx(error, n_a);
3339 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3342 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3346 # ifdef HAS_GETPAGESIZE
3347 page_size = getpagesize();
3349 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3350 page_size = PAGESIZE; /* compiletime, bad */
3354 if ((IV)page_size <= 0)
3355 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3359 /* This is a hack - should never happen - open should have set it ! */
3360 b->posn = PerlIO_tell(PerlIONext(f));
3362 posn = (b->posn / page_size) * page_size;
3363 len = st.st_size - posn;
3364 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3365 if (m->mptr && m->mptr != (Mmap_t) -1)
3367 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3368 madvise(m->mptr, len, MADV_SEQUENTIAL);
3370 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3371 madvise(m->mptr, len, MADV_WILLNEED);
3373 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3374 b->end = ((STDCHAR *)m->mptr) + len;
3375 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3386 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3388 b->ptr = b->end = b->ptr;
3397 PerlIOMmap_unmap(PerlIO *f)
3399 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3400 PerlIOBuf *b = &m->base;
3406 code = munmap(m->mptr, m->len);
3410 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3413 b->ptr = b->end = b->buf;
3414 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3420 PerlIOMmap_get_base(PerlIO *f)
3422 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3423 PerlIOBuf *b = &m->base;
3424 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3426 /* Already have a readbuffer in progress */
3431 /* We have a write buffer or flushed PerlIOBuf read buffer */
3432 m->bbuf = b->buf; /* save it in case we need it again */
3433 b->buf = NULL; /* Clear to trigger below */
3437 PerlIOMmap_map(f); /* Try and map it */
3440 /* Map did not work - recover PerlIOBuf buffer if we have one */
3444 b->ptr = b->end = b->buf;
3447 return PerlIOBuf_get_base(f);
3451 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3453 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3454 PerlIOBuf *b = &m->base;
3455 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3457 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3460 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3465 /* Loose the unwritable mapped buffer */
3467 /* If flush took the "buffer" see if we have one from before */
3468 if (!b->buf && m->bbuf)
3472 PerlIOBuf_get_base(f);
3476 return PerlIOBuf_unread(f,vbuf,count);
3480 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3482 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3483 PerlIOBuf *b = &m->base;
3484 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3486 /* No, or wrong sort of, buffer */
3489 if (PerlIOMmap_unmap(f) != 0)
3492 /* If unmap took the "buffer" see if we have one from before */
3493 if (!b->buf && m->bbuf)
3497 PerlIOBuf_get_base(f);
3501 return PerlIOBuf_write(f,vbuf,count);
3505 PerlIOMmap_flush(PerlIO *f)
3507 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3508 PerlIOBuf *b = &m->base;
3509 IV code = PerlIOBuf_flush(f);
3510 /* Now we are "synced" at PerlIOBuf level */
3515 /* Unmap the buffer */
3516 if (PerlIOMmap_unmap(f) != 0)
3521 /* We seem to have a PerlIOBuf buffer which was not mapped
3522 * remember it in case we need one later
3531 PerlIOMmap_fill(PerlIO *f)
3533 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3534 IV code = PerlIO_flush(f);
3535 if (code == 0 && !b->buf)
3537 code = PerlIOMmap_map(f);
3539 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3541 code = PerlIOBuf_fill(f);
3547 PerlIOMmap_close(PerlIO *f)
3549 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3550 PerlIOBuf *b = &m->base;
3551 IV code = PerlIO_flush(f);
3556 b->ptr = b->end = b->buf;
3558 if (PerlIOBuf_close(f) != 0)
3564 PerlIO_funcs PerlIO_mmap = {
3583 PerlIOBase_clearerr,
3584 PerlIOBase_setlinebuf,
3585 PerlIOMmap_get_base,
3589 PerlIOBuf_set_ptrcnt,
3592 #endif /* HAS_MMAP */
3600 atexit(&PerlIO_cleanup);
3612 PerlIO_stdstreams(aTHX);
3617 #undef PerlIO_stdout
3624 PerlIO_stdstreams(aTHX);
3629 #undef PerlIO_stderr
3636 PerlIO_stdstreams(aTHX);
3641 /*--------------------------------------------------------------------------------------*/
3643 #undef PerlIO_getname
3645 PerlIO_getname(PerlIO *f, char *buf)
3648 Perl_croak(aTHX_ "Don't know how to get file name");
3653 /*--------------------------------------------------------------------------------------*/
3654 /* Functions which can be called on any kind of PerlIO implemented
3660 PerlIO_getc(PerlIO *f)
3663 SSize_t count = PerlIO_read(f,buf,1);
3666 return (unsigned char) buf[0];
3671 #undef PerlIO_ungetc
3673 PerlIO_ungetc(PerlIO *f, int ch)
3678 if (PerlIO_unread(f,&buf,1) == 1)
3686 PerlIO_putc(PerlIO *f, int ch)
3689 return PerlIO_write(f,&buf,1);
3694 PerlIO_puts(PerlIO *f, const char *s)
3696 STRLEN len = strlen(s);
3697 return PerlIO_write(f,s,len);
3700 #undef PerlIO_rewind
3702 PerlIO_rewind(PerlIO *f)
3704 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3708 #undef PerlIO_vprintf
3710 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3713 SV *sv = newSVpvn("",0);
3719 Perl_va_copy(ap, apc);
3720 sv_vcatpvf(sv, fmt, &apc);
3722 sv_vcatpvf(sv, fmt, &ap);
3725 wrote = PerlIO_write(f,s,len);
3730 #undef PerlIO_printf
3732 PerlIO_printf(PerlIO *f,const char *fmt,...)
3737 result = PerlIO_vprintf(f,fmt,ap);
3742 #undef PerlIO_stdoutf
3744 PerlIO_stdoutf(const char *fmt,...)
3749 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3754 #undef PerlIO_tmpfile
3756 PerlIO_tmpfile(void)
3758 /* I have no idea how portable mkstemp() is ... */
3759 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3762 FILE *stdio = PerlSIO_tmpfile();
3765 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
3771 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3772 int fd = mkstemp(SvPVX(sv));
3776 f = PerlIO_fdopen(fd,"w+");
3779 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3781 PerlLIO_unlink(SvPVX(sv));
3791 #endif /* USE_SFIO */
3792 #endif /* PERLIO_IS_STDIO */
3794 /*======================================================================================*/
3795 /* Now some functions in terms of above which may be needed even if
3796 we are not in true PerlIO mode
3800 #undef PerlIO_setpos
3802 PerlIO_setpos(PerlIO *f, SV *pos)
3808 Off_t *posn = (Off_t *) SvPV(pos,len);
3809 if (f && len == sizeof(Off_t))
3810 return PerlIO_seek(f,*posn,SEEK_SET);
3812 SETERRNO(EINVAL,SS$_IVCHAN);
3816 #undef PerlIO_setpos
3818 PerlIO_setpos(PerlIO *f, SV *pos)
3824 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3825 if (f && len == sizeof(Fpos_t))
3827 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3828 return fsetpos64(f, fpos);
3830 return fsetpos(f, fpos);
3834 SETERRNO(EINVAL,SS$_IVCHAN);
3840 #undef PerlIO_getpos
3842 PerlIO_getpos(PerlIO *f, SV *pos)
3845 Off_t posn = PerlIO_tell(f);
3846 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3847 return (posn == (Off_t)-1) ? -1 : 0;
3850 #undef PerlIO_getpos
3852 PerlIO_getpos(PerlIO *f, SV *pos)
3857 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3858 code = fgetpos64(f, &fpos);
3860 code = fgetpos(f, &fpos);
3862 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3867 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3870 vprintf(char *pat, char *args)
3872 _doprnt(pat, args, stdout);
3873 return 0; /* wrong, but perl doesn't use the return value */
3877 vfprintf(FILE *fd, char *pat, char *args)
3879 _doprnt(pat, args, fd);
3880 return 0; /* wrong, but perl doesn't use the return value */
3885 #ifndef PerlIO_vsprintf
3887 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3889 int val = vsprintf(s, fmt, ap);
3892 if (strlen(s) >= (STRLEN)n)
3895 (void)PerlIO_puts(Perl_error_log,
3896 "panic: sprintf overflow - memory corrupted!\n");
3904 #ifndef PerlIO_sprintf
3906 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3911 result = PerlIO_vsprintf(s, n, fmt, ap);