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);
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
102 /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */
105 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
109 char *name = SvPV_nolen(*args);
112 fd = PerlLIO_open3(name,imode,perm);
114 return PerlIO_fdopen(fd,mode+1);
118 return PerlIO_reopen(name,mode,old);
122 return PerlIO_open(name,mode);
127 return PerlIO_fdopen(fd,mode);
135 #ifdef PERLIO_IS_STDIO
140 /* Does nothing (yet) except force this file to be included
141 in perl binary. That allows this file to force inclusion
142 of other functions that may be required by loadable
143 extensions e.g. for FileHandle::tmpfile
147 #undef PerlIO_tmpfile
154 #else /* PERLIO_IS_STDIO */
161 /* This section is just to make sure these functions
162 get pulled in from libsfio.a
165 #undef PerlIO_tmpfile
175 /* Force this file to be included in perl binary. Which allows
176 * this file to force inclusion of other functions that may be
177 * required by loadable extensions e.g. for FileHandle::tmpfile
181 * sfio does its own 'autoflush' on stdout in common cases.
182 * Flush results in a lot of lseek()s to regular files and
183 * lot of small writes to pipes.
185 sfset(sfstdout,SF_SHARE,0);
189 /*======================================================================================*/
190 /* Implement all the PerlIO interface ourselves.
195 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
200 #include <sys/mman.h>
205 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
208 PerlIO_debug(const char *fmt,...)
216 char *s = PerlEnv_getenv("PERLIO_DEBUG");
218 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
225 SV *sv = newSVpvn("",0);
228 s = CopFILE(PL_curcop);
231 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
232 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
235 PerlLIO_write(dbg,s,len);
241 /*--------------------------------------------------------------------------------------*/
243 /* Inner level routines */
245 /* Table of pointers to the PerlIO structs (malloc'ed) */
246 PerlIO *_perlio = NULL;
247 #define PERLIO_TABLE_SIZE 64
250 PerlIO_allocate(pTHX)
252 /* Find a free slot in the table, allocating new table as necessary */
259 last = (PerlIO **)(f);
260 for (i=1; i < PERLIO_TABLE_SIZE; i++)
268 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
278 PerlIO_cleantable(pTHX_ PerlIO **tablep)
280 PerlIO *table = *tablep;
284 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
285 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
293 PerlMemShared_free(table);
305 PerlIO_cleantable(aTHX_ &_perlio);
309 PerlIO_pop(PerlIO *f)
315 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
317 (*l->tab->Popped)(f);
319 PerlMemShared_free(l);
323 /*--------------------------------------------------------------------------------------*/
324 /* XS Interface for perl code */
330 char *s = GvNAME(gv);
331 STRLEN l = GvNAMELEN(gv);
332 PerlIO_debug("%.*s\n",(int) l,s);
336 XS(XS_perlio_unimport)
340 char *s = GvNAME(gv);
341 STRLEN l = GvNAMELEN(gv);
342 PerlIO_debug("%.*s\n",(int) l,s);
347 PerlIO_find_layer(const char *name, STRLEN len)
352 if ((SSize_t) len <= 0)
354 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
355 if (svp && (sv = *svp) && SvROK(sv))
362 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
366 IO *io = GvIOn((GV *)SvRV(sv));
367 PerlIO *ifp = IoIFP(io);
368 PerlIO *ofp = IoOFP(io);
369 AV *av = (AV *) mg->mg_obj;
370 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
376 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
380 IO *io = GvIOn((GV *)SvRV(sv));
381 PerlIO *ifp = IoIFP(io);
382 PerlIO *ofp = IoOFP(io);
383 AV *av = (AV *) mg->mg_obj;
384 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
390 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
392 Perl_warn(aTHX_ "clear %"SVf,sv);
397 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
399 Perl_warn(aTHX_ "free %"SVf,sv);
403 MGVTBL perlio_vtab = {
411 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
414 SV *sv = SvRV(ST(1));
419 sv_magic(sv, (SV *)av, '~', NULL, 0);
421 mg = mg_find(sv,'~');
422 mg->mg_virtual = &perlio_vtab;
424 Perl_warn(aTHX_ "attrib %"SVf,sv);
425 for (i=2; i < items; i++)
428 const char *name = SvPV(ST(i),len);
429 SV *layer = PerlIO_find_layer(name,len);
432 av_push(av,SvREFCNT_inc(layer));
445 PerlIO_define_layer(PerlIO_funcs *tab)
448 HV *stash = gv_stashpv("perlio::Layer", TRUE);
449 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
450 if (!PerlIO_layer_hv)
452 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
454 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
455 PerlIO_debug("define %s %p\n",tab->name,tab);
459 PerlIO_default_buffer(pTHX)
461 PerlIO_funcs *tab = &PerlIO_perlio;
462 if (O_BINARY != O_TEXT)
468 if (PerlIO_stdio.Set_ptrcnt)
473 PerlIO_debug("Pushing %s\n",tab->name);
474 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0)));
479 PerlIO_default_layer(I32 n)
484 PerlIO_funcs *tab = &PerlIO_stdio;
486 if (!PerlIO_layer_av)
488 const char *s = PerlEnv_getenv("PERLIO");
489 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
490 newXS("perlio::import",XS_perlio_import,__FILE__);
491 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
493 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
495 PerlIO_define_layer(&PerlIO_raw);
496 PerlIO_define_layer(&PerlIO_unix);
497 PerlIO_define_layer(&PerlIO_perlio);
498 PerlIO_define_layer(&PerlIO_stdio);
499 PerlIO_define_layer(&PerlIO_crlf);
501 PerlIO_define_layer(&PerlIO_mmap);
503 PerlIO_define_layer(&PerlIO_utf8);
504 PerlIO_define_layer(&PerlIO_byte);
505 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
511 while (*s && isSPACE((unsigned char)*s))
517 while (*e && !isSPACE((unsigned char)*e))
521 layer = PerlIO_find_layer(s,e-s);
524 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
525 if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED))
528 PerlIO_default_buffer(aTHX);
530 PerlIO_debug("Pushing %.*s\n",(e-s),s);
531 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
532 buffered |= (tab->kind & PERLIO_K_BUFFERED);
535 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
541 len = av_len(PerlIO_layer_av);
544 PerlIO_default_buffer(aTHX);
545 len = av_len(PerlIO_layer_av);
549 svp = av_fetch(PerlIO_layer_av,n,0);
550 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
552 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
554 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
558 #define PerlIO_default_top() PerlIO_default_layer(-1)
559 #define PerlIO_default_btm() PerlIO_default_layer(0)
567 PerlIO_allocate(aTHX);
568 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
569 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
570 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
575 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
579 l = PerlMemShared_calloc(tab->size,sizeof(char));
582 Zero(l,tab->size,char);
586 PerlIO_debug("PerlIO_push f=%p %s %s '%.*s'\n",
587 f,tab->name,(mode) ? mode : "(Null)",(int) len,arg);
588 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
598 PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
611 PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
613 /* Remove the dummy layer */
615 /* Pop back to bottom layer */
620 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
628 /* Nothing bellow - push unix on top then remove it */
629 if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len))
631 PerlIO_pop(PerlIONext(f));
636 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
643 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
647 const char *s = names;
650 while (isSPACE(*s) || *s == ':')
656 const char *as = Nullch;
660 /* Message is consistent with how attribute lists are passed.
661 Even though this means "foo : : bar" is seen as an invalid separator
663 char q = ((*s == '\'') ? '"' : '\'');
664 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
670 } while (isALNUM(*e));
688 /* It's a nul terminated string, not allowed to \ the terminating null.
689 Anything other character is passed over. */
697 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
707 SV *layer = PerlIO_find_layer(s,llen);
710 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
713 if (!PerlIO_push(f,tab,mode,as,alen))
718 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
731 /*--------------------------------------------------------------------------------------*/
732 /* Given the abstraction above the public API functions */
735 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
737 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
738 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
739 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
745 if (PerlIOBase(top)->tab == &PerlIO_crlf)
748 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
751 top = PerlIONext(top);
754 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
759 PerlIO__close(PerlIO *f)
761 return (*PerlIOBase(f)->tab->Close)(f);
764 #undef PerlIO_fdupopen
766 PerlIO_fdupopen(pTHX_ PerlIO *f)
769 int fd = PerlLIO_dup(PerlIO_fileno(f));
770 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
773 Off_t posn = PerlIO_tell(f);
774 PerlIO_seek(new,posn,SEEK_SET);
781 PerlIO_close(PerlIO *f)
783 int code = (*PerlIOBase(f)->tab->Close)(f);
793 PerlIO_fileno(PerlIO *f)
795 return (*PerlIOBase(f)->tab->Fileno)(f);
799 PerlIO_top_layer(pTHX_ const char *layers)
802 return PerlIO_default_top();
806 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
808 PerlIO_funcs *tab = (f && *f) ? PerlIOBase(f)->tab : PerlIO_top_layer(aTHX_ layers);
811 return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,f,narg,args);
817 PerlIO_fdopen(int fd, const char *mode)
820 return PerlIO_openn(aTHX_ Nullch,mode,fd,0,0,NULL,0,NULL);
825 PerlIO_open(const char *path, const char *mode)
828 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
829 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,NULL,1,&name);
834 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
837 SV *name = sv_2mortal(newSVpvn(path,strlen(path)));
838 return PerlIO_openn(aTHX_ Nullch,mode,-1,0,0,f,1,&name);
843 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
845 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
850 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
852 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
857 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
859 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
864 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
866 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
871 PerlIO_tell(PerlIO *f)
873 return (*PerlIOBase(f)->tab->Tell)(f);
878 PerlIO_flush(PerlIO *f)
882 PerlIO_funcs *tab = PerlIOBase(f)->tab;
883 if (tab && tab->Flush)
885 return (*tab->Flush)(f);
889 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
896 PerlIO **table = &_perlio;
901 table = (PerlIO **)(f++);
902 for (i=1; i < PERLIO_TABLE_SIZE; i++)
904 if (*f && PerlIO_flush(f) != 0)
915 PerlIO_fill(PerlIO *f)
917 return (*PerlIOBase(f)->tab->Fill)(f);
922 PerlIO_isutf8(PerlIO *f)
924 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
929 PerlIO_eof(PerlIO *f)
931 return (*PerlIOBase(f)->tab->Eof)(f);
936 PerlIO_error(PerlIO *f)
938 return (*PerlIOBase(f)->tab->Error)(f);
941 #undef PerlIO_clearerr
943 PerlIO_clearerr(PerlIO *f)
946 (*PerlIOBase(f)->tab->Clearerr)(f);
949 #undef PerlIO_setlinebuf
951 PerlIO_setlinebuf(PerlIO *f)
953 (*PerlIOBase(f)->tab->Setlinebuf)(f);
956 #undef PerlIO_has_base
958 PerlIO_has_base(PerlIO *f)
962 return (PerlIOBase(f)->tab->Get_base != NULL);
967 #undef PerlIO_fast_gets
969 PerlIO_fast_gets(PerlIO *f)
971 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
973 PerlIO_funcs *tab = PerlIOBase(f)->tab;
974 return (tab->Set_ptrcnt != NULL);
979 #undef PerlIO_has_cntptr
981 PerlIO_has_cntptr(PerlIO *f)
985 PerlIO_funcs *tab = PerlIOBase(f)->tab;
986 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
991 #undef PerlIO_canset_cnt
993 PerlIO_canset_cnt(PerlIO *f)
997 PerlIOl *l = PerlIOBase(f);
998 return (l->tab->Set_ptrcnt != NULL);
1003 #undef PerlIO_get_base
1005 PerlIO_get_base(PerlIO *f)
1007 return (*PerlIOBase(f)->tab->Get_base)(f);
1010 #undef PerlIO_get_bufsiz
1012 PerlIO_get_bufsiz(PerlIO *f)
1014 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
1017 #undef PerlIO_get_ptr
1019 PerlIO_get_ptr(PerlIO *f)
1021 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1022 if (tab->Get_ptr == NULL)
1024 return (*tab->Get_ptr)(f);
1027 #undef PerlIO_get_cnt
1029 PerlIO_get_cnt(PerlIO *f)
1031 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1032 if (tab->Get_cnt == NULL)
1034 return (*tab->Get_cnt)(f);
1037 #undef PerlIO_set_cnt
1039 PerlIO_set_cnt(PerlIO *f,int cnt)
1041 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1044 #undef PerlIO_set_ptrcnt
1046 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1048 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1049 if (tab->Set_ptrcnt == NULL)
1052 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1054 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1057 /*--------------------------------------------------------------------------------------*/
1058 /* utf8 and raw dummy layers */
1061 PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1065 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1067 if (tab->kind & PERLIO_K_UTF8)
1068 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1070 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1077 PerlIOUtf8_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1079 PerlIO_funcs *tab = PerlIO_default_layer(-2);
1080 PerlIO *f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args);
1083 PerlIOl *l = PerlIOBase(f);
1084 if (tab->kind & PERLIO_K_UTF8)
1085 l->flags |= PERLIO_F_UTF8;
1087 l->flags &= ~PERLIO_F_UTF8;
1092 PerlIO_funcs PerlIO_utf8 = {
1095 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1112 NULL, /* get_base */
1113 NULL, /* get_bufsiz */
1116 NULL, /* set_ptrcnt */
1119 PerlIO_funcs PerlIO_byte = {
1139 NULL, /* get_base */
1140 NULL, /* get_bufsiz */
1143 NULL, /* set_ptrcnt */
1147 PerlIORaw_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args)
1149 PerlIO_funcs *tab = PerlIO_default_btm();
1150 return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args);
1153 PerlIO_funcs PerlIO_raw = {
1173 NULL, /* get_base */
1174 NULL, /* get_bufsiz */
1177 NULL, /* set_ptrcnt */
1179 /*--------------------------------------------------------------------------------------*/
1180 /*--------------------------------------------------------------------------------------*/
1181 /* "Methods" of the "base class" */
1184 PerlIOBase_fileno(PerlIO *f)
1186 return PerlIO_fileno(PerlIONext(f));
1190 PerlIO_modestr(PerlIO *f,char *buf)
1193 IV flags = PerlIOBase(f)->flags;
1194 if (flags & PERLIO_F_APPEND)
1197 if (flags & PERLIO_F_CANREAD)
1202 else if (flags & PERLIO_F_CANREAD)
1205 if (flags & PERLIO_F_CANWRITE)
1208 else if (flags & PERLIO_F_CANWRITE)
1211 if (flags & PERLIO_F_CANREAD)
1216 #if O_TEXT != O_BINARY
1217 if (!(flags & PERLIO_F_CRLF))
1225 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1227 PerlIOl *l = PerlIOBase(f);
1228 const char *omode = mode;
1230 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1231 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1232 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1233 if (tab->Set_ptrcnt != NULL)
1234 l->flags |= PERLIO_F_FASTGETS;
1240 l->flags |= PERLIO_F_CANREAD;
1243 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1246 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1257 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1260 l->flags &= ~PERLIO_F_CRLF;
1263 l->flags |= PERLIO_F_CRLF;
1275 l->flags |= l->next->flags &
1276 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1280 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1281 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1282 l->flags,PerlIO_modestr(f,temp));
1288 PerlIOBase_popped(PerlIO *f)
1294 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1296 Off_t old = PerlIO_tell(f);
1298 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1299 done = PerlIOBuf_unread(f,vbuf,count);
1300 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1305 PerlIOBase_noop_ok(PerlIO *f)
1311 PerlIOBase_noop_fail(PerlIO *f)
1317 PerlIOBase_close(PerlIO *f)
1320 PerlIO *n = PerlIONext(f);
1321 if (PerlIO_flush(f) != 0)
1323 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1325 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1330 PerlIOBase_eof(PerlIO *f)
1334 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1340 PerlIOBase_error(PerlIO *f)
1344 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1350 PerlIOBase_clearerr(PerlIO *f)
1354 PerlIO *n = PerlIONext(f);
1355 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1362 PerlIOBase_setlinebuf(PerlIO *f)
1367 /*--------------------------------------------------------------------------------------*/
1368 /* Bottom-most level for UNIX-like case */
1372 struct _PerlIO base; /* The generic part */
1373 int fd; /* UNIX like file descriptor */
1374 int oflags; /* open/fcntl flags */
1378 PerlIOUnix_oflags(const char *mode)
1393 oflags = O_CREAT|O_TRUNC;
1404 oflags = O_CREAT|O_APPEND;
1420 else if (*mode == 't')
1423 oflags &= ~O_BINARY;
1426 /* Always open in binary mode */
1428 if (*mode || oflags == -1)
1437 PerlIOUnix_fileno(PerlIO *f)
1439 return PerlIOSelf(f,PerlIOUnix)->fd;
1443 PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1445 IV code = PerlIOBase_pushed(f,mode,arg,len);
1448 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1449 s->fd = PerlIO_fileno(PerlIONext(f));
1450 s->oflags = PerlIOUnix_oflags(mode);
1452 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1457 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1465 int oflags = PerlIOUnix_oflags(mode);
1468 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1477 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1481 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1482 (*PerlIOBase(f)->tab->Close)(f);
1486 char *path = SvPV_nolen(*args);
1491 imode = PerlIOUnix_oflags(mode);
1496 fd = PerlLIO_open3(path,imode,perm);
1506 f = PerlIO_allocate(aTHX);
1507 s = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOUnix);
1510 s = PerlIOSelf(f,PerlIOUnix);
1513 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1520 /* FIXME: pop layers ??? */
1527 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1530 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1531 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1535 SSize_t len = PerlLIO_read(fd,vbuf,count);
1536 if (len >= 0 || errno != EINTR)
1539 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1540 else if (len == 0 && count != 0)
1541 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1549 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1552 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1555 SSize_t len = PerlLIO_write(fd,vbuf,count);
1556 if (len >= 0 || errno != EINTR)
1559 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1567 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1570 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1571 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1572 return (new == (Off_t) -1) ? -1 : 0;
1576 PerlIOUnix_tell(PerlIO *f)
1579 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1580 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1584 PerlIOUnix_close(PerlIO *f)
1587 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1589 while (PerlLIO_close(fd) != 0)
1600 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1605 PerlIO_funcs PerlIO_unix = {
1619 PerlIOBase_noop_ok, /* flush */
1620 PerlIOBase_noop_fail, /* fill */
1623 PerlIOBase_clearerr,
1624 PerlIOBase_setlinebuf,
1625 NULL, /* get_base */
1626 NULL, /* get_bufsiz */
1629 NULL, /* set_ptrcnt */
1632 /*--------------------------------------------------------------------------------------*/
1633 /* stdio as a layer */
1637 struct _PerlIO base;
1638 FILE * stdio; /* The stream */
1642 PerlIOStdio_fileno(PerlIO *f)
1645 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1649 PerlIOStdio_mode(const char *mode,char *tmode)
1656 if (O_BINARY != O_TEXT)
1665 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1673 /* This isn't used yet ... */
1675 PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1680 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1682 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1688 return PerlIOBase_pushed(f,mode,arg,len);
1691 #undef PerlIO_importFILE
1693 PerlIO_importFILE(FILE *stdio, int fl)
1699 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1706 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
1711 char *path = SvPV_nolen(*args);
1712 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1713 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1723 char *path = SvPV_nolen(*args);
1727 fd = PerlLIO_open3(path,imode,perm);
1731 FILE *stdio = PerlSIO_fopen(path,mode);
1734 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1735 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1756 stdio = PerlSIO_stdin;
1759 stdio = PerlSIO_stdout;
1762 stdio = PerlSIO_stderr;
1768 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1772 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1782 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1785 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1789 STDCHAR *buf = (STDCHAR *) vbuf;
1790 /* Perl is expecting PerlIO_getc() to fill the buffer
1791 * Linux's stdio does not do that for fread()
1793 int ch = PerlSIO_fgetc(s);
1801 got = PerlSIO_fread(vbuf,1,count,s);
1806 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1809 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1810 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1814 int ch = *buf-- & 0xff;
1815 if (PerlSIO_ungetc(ch,s) != ch)
1824 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1827 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1831 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1834 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1835 return PerlSIO_fseek(stdio,offset,whence);
1839 PerlIOStdio_tell(PerlIO *f)
1842 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1843 return PerlSIO_ftell(stdio);
1847 PerlIOStdio_close(PerlIO *f)
1850 #ifdef HAS_SOCKS5_INIT
1851 int optval, optlen = sizeof(int);
1853 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1855 #ifdef HAS_SOCKS5_INIT
1856 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1857 PerlSIO_fclose(stdio) :
1858 close(PerlIO_fileno(f))
1860 PerlSIO_fclose(stdio)
1867 PerlIOStdio_flush(PerlIO *f)
1870 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1871 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1873 return PerlSIO_fflush(stdio);
1878 /* FIXME: This discards ungetc() and pre-read stuff which is
1879 not right if this is just a "sync" from a layer above
1880 Suspect right design is to do _this_ but not have layer above
1881 flush this layer read-to-read
1883 /* Not writeable - sync by attempting a seek */
1885 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1893 PerlIOStdio_fill(PerlIO *f)
1896 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1898 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1899 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1901 if (PerlSIO_fflush(stdio) != 0)
1904 c = PerlSIO_fgetc(stdio);
1905 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1911 PerlIOStdio_eof(PerlIO *f)
1914 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1918 PerlIOStdio_error(PerlIO *f)
1921 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1925 PerlIOStdio_clearerr(PerlIO *f)
1928 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1932 PerlIOStdio_setlinebuf(PerlIO *f)
1935 #ifdef HAS_SETLINEBUF
1936 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1938 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1944 PerlIOStdio_get_base(PerlIO *f)
1947 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1948 return PerlSIO_get_base(stdio);
1952 PerlIOStdio_get_bufsiz(PerlIO *f)
1955 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1956 return PerlSIO_get_bufsiz(stdio);
1960 #ifdef USE_STDIO_PTR
1962 PerlIOStdio_get_ptr(PerlIO *f)
1965 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1966 return PerlSIO_get_ptr(stdio);
1970 PerlIOStdio_get_cnt(PerlIO *f)
1973 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1974 return PerlSIO_get_cnt(stdio);
1978 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1981 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1984 #ifdef STDIO_PTR_LVALUE
1985 PerlSIO_set_ptr(stdio,ptr);
1986 #ifdef STDIO_PTR_LVAL_SETS_CNT
1987 if (PerlSIO_get_cnt(stdio) != (cnt))
1990 assert(PerlSIO_get_cnt(stdio) == (cnt));
1993 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1994 /* Setting ptr _does_ change cnt - we are done */
1997 #else /* STDIO_PTR_LVALUE */
1999 #endif /* STDIO_PTR_LVALUE */
2001 /* Now (or only) set cnt */
2002 #ifdef STDIO_CNT_LVALUE
2003 PerlSIO_set_cnt(stdio,cnt);
2004 #else /* STDIO_CNT_LVALUE */
2005 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2006 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
2007 #else /* STDIO_PTR_LVAL_SETS_CNT */
2009 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2010 #endif /* STDIO_CNT_LVALUE */
2015 PerlIO_funcs PerlIO_stdio = {
2017 sizeof(PerlIOStdio),
2033 PerlIOStdio_clearerr,
2034 PerlIOStdio_setlinebuf,
2036 PerlIOStdio_get_base,
2037 PerlIOStdio_get_bufsiz,
2042 #ifdef USE_STDIO_PTR
2043 PerlIOStdio_get_ptr,
2044 PerlIOStdio_get_cnt,
2045 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2046 PerlIOStdio_set_ptrcnt
2047 #else /* STDIO_PTR_LVALUE */
2049 #endif /* STDIO_PTR_LVALUE */
2050 #else /* USE_STDIO_PTR */
2054 #endif /* USE_STDIO_PTR */
2057 #undef PerlIO_exportFILE
2059 PerlIO_exportFILE(PerlIO *f, int fl)
2063 stdio = fdopen(PerlIO_fileno(f),"r+");
2066 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
2072 #undef PerlIO_findFILE
2074 PerlIO_findFILE(PerlIO *f)
2079 if (l->tab == &PerlIO_stdio)
2081 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2084 l = *PerlIONext(&l);
2086 return PerlIO_exportFILE(f,0);
2089 #undef PerlIO_releaseFILE
2091 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2095 /*--------------------------------------------------------------------------------------*/
2096 /* perlio buffer layer */
2099 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
2101 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2102 int fd = PerlIO_fileno(f);
2104 if (fd >= 0 && PerlLIO_isatty(fd))
2106 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2108 posn = PerlIO_tell(PerlIONext(f));
2109 if (posn != (Off_t) -1)
2113 return PerlIOBase_pushed(f,mode,arg,len);
2117 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
2121 PerlIO *next = PerlIONext(f);
2122 PerlIO_funcs *tab = PerlIOBase(next)->tab;
2123 next = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,next,narg,args);
2124 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) != 0)
2131 PerlIO_funcs *tab = PerlIO_default_btm();
2138 f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,NULL,narg,args);
2141 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
2142 fd = PerlIO_fileno(f);
2143 #if O_BINARY != O_TEXT
2144 /* do something about failing setmode()? --jhi */
2145 PerlLIO_setmode(fd , O_BINARY);
2147 if (init && fd == 2)
2149 /* Initial stderr is unbuffered */
2150 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2157 /* This "flush" is akin to sfio's sync in that it handles files in either
2161 PerlIOBuf_flush(PerlIO *f)
2163 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2165 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2167 /* write() the buffer */
2168 STDCHAR *buf = b->buf;
2170 PerlIO *n = PerlIONext(f);
2173 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2178 else if (count < 0 || PerlIO_error(n))
2180 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2185 b->posn += (p - buf);
2187 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2189 STDCHAR *buf = PerlIO_get_base(f);
2190 /* Note position change */
2191 b->posn += (b->ptr - buf);
2192 if (b->ptr < b->end)
2194 /* We did not consume all of it */
2195 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2197 b->posn = PerlIO_tell(PerlIONext(f));
2201 b->ptr = b->end = b->buf;
2202 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2203 /* FIXME: Is this right for read case ? */
2204 if (PerlIO_flush(PerlIONext(f)) != 0)
2210 PerlIOBuf_fill(PerlIO *f)
2212 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2213 PerlIO *n = PerlIONext(f);
2215 /* FIXME: doing the down-stream flush is a bad idea if it causes
2216 pre-read data in stdio buffer to be discarded
2217 but this is too simplistic - as it skips _our_ hosekeeping
2218 and breaks tell tests.
2219 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2223 if (PerlIO_flush(f) != 0)
2227 PerlIO_get_base(f); /* allocate via vtable */
2229 b->ptr = b->end = b->buf;
2230 if (PerlIO_fast_gets(n))
2232 /* Layer below is also buffered
2233 * We do _NOT_ want to call its ->Read() because that will loop
2234 * till it gets what we asked for which may hang on a pipe etc.
2235 * Instead take anything it has to hand, or ask it to fill _once_.
2237 avail = PerlIO_get_cnt(n);
2240 avail = PerlIO_fill(n);
2242 avail = PerlIO_get_cnt(n);
2245 if (!PerlIO_error(n) && PerlIO_eof(n))
2251 STDCHAR *ptr = PerlIO_get_ptr(n);
2252 SSize_t cnt = avail;
2253 if (avail > b->bufsiz)
2255 Copy(ptr,b->buf,avail,STDCHAR);
2256 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2261 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2266 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2268 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2271 b->end = b->buf+avail;
2272 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2277 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2279 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2280 STDCHAR *buf = (STDCHAR *) vbuf;
2285 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2289 SSize_t avail = PerlIO_get_cnt(f);
2290 SSize_t take = (count < avail) ? count : avail;
2293 STDCHAR *ptr = PerlIO_get_ptr(f);
2294 Copy(ptr,buf,take,STDCHAR);
2295 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2299 if (count > 0 && avail <= 0)
2301 if (PerlIO_fill(f) != 0)
2305 return (buf - (STDCHAR *) vbuf);
2311 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2313 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2314 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2317 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2323 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2325 avail = (b->ptr - b->buf);
2330 b->end = b->buf + avail;
2332 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2333 b->posn -= b->bufsiz;
2335 if (avail > (SSize_t) count)
2343 Copy(buf,b->ptr,avail,STDCHAR);
2347 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2354 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2356 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2357 const STDCHAR *buf = (const STDCHAR *) vbuf;
2361 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2365 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2366 if ((SSize_t) count < avail)
2368 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2369 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2389 Copy(buf,b->ptr,avail,STDCHAR);
2396 if (b->ptr >= (b->buf + b->bufsiz))
2399 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2405 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2408 if ((code = PerlIO_flush(f)) == 0)
2410 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2411 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2412 code = PerlIO_seek(PerlIONext(f),offset,whence);
2415 b->posn = PerlIO_tell(PerlIONext(f));
2422 PerlIOBuf_tell(PerlIO *f)
2424 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2425 Off_t posn = b->posn;
2427 posn += (b->ptr - b->buf);
2432 PerlIOBuf_close(PerlIO *f)
2435 IV code = PerlIOBase_close(f);
2436 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2437 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2439 PerlMemShared_free(b->buf);
2442 b->ptr = b->end = b->buf;
2443 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2448 PerlIOBuf_setlinebuf(PerlIO *f)
2452 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2457 PerlIOBuf_get_ptr(PerlIO *f)
2459 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2466 PerlIOBuf_get_cnt(PerlIO *f)
2468 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2471 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2472 return (b->end - b->ptr);
2477 PerlIOBuf_get_base(PerlIO *f)
2479 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2485 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2488 b->buf = (STDCHAR *)&b->oneword;
2489 b->bufsiz = sizeof(b->oneword);
2498 PerlIOBuf_bufsiz(PerlIO *f)
2500 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2503 return (b->end - b->buf);
2507 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2509 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2513 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2516 assert(PerlIO_get_cnt(f) == cnt);
2517 assert(b->ptr >= b->buf);
2519 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2522 PerlIO_funcs PerlIO_perlio = {
2540 PerlIOBase_clearerr,
2541 PerlIOBuf_setlinebuf,
2546 PerlIOBuf_set_ptrcnt,
2549 /*--------------------------------------------------------------------------------------*/
2550 /* Temp layer to hold unread chars when cannot do it any other way */
2553 PerlIOPending_fill(PerlIO *f)
2555 /* Should never happen */
2561 PerlIOPending_close(PerlIO *f)
2563 /* A tad tricky - flush pops us, then we close new top */
2565 return PerlIO_close(f);
2569 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2571 /* A tad tricky - flush pops us, then we seek new top */
2573 return PerlIO_seek(f,offset,whence);
2578 PerlIOPending_flush(PerlIO *f)
2580 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2581 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2584 PerlMemShared_free(b->buf);
2592 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2600 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2605 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2607 IV code = PerlIOBase_pushed(f,mode,arg,len);
2608 PerlIOl *l = PerlIOBase(f);
2609 /* Our PerlIO_fast_gets must match what we are pushed on,
2610 or sv_gets() etc. get muddled when it changes mid-string
2613 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2614 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2619 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2621 SSize_t avail = PerlIO_get_cnt(f);
2626 got = PerlIOBuf_read(f,vbuf,avail);
2627 if (got >= 0 && got < count)
2629 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2630 if (more >= 0 || got == 0)
2637 PerlIO_funcs PerlIO_pending = {
2643 PerlIOPending_pushed,
2650 PerlIOPending_close,
2651 PerlIOPending_flush,
2655 PerlIOBase_clearerr,
2656 PerlIOBuf_setlinebuf,
2661 PerlIOPending_set_ptrcnt,
2666 /*--------------------------------------------------------------------------------------*/
2667 /* crlf - translation
2668 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2669 to hand back a line at a time and keeping a record of which nl we "lied" about.
2670 On write translate "\n" to CR,LF
2675 PerlIOBuf base; /* PerlIOBuf stuff */
2676 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2680 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2683 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2684 code = PerlIOBuf_pushed(f,mode,arg,len);
2686 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2687 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2688 PerlIOBase(f)->flags);
2695 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2697 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2703 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2704 return PerlIOBuf_unread(f,vbuf,count);
2707 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2708 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2710 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2716 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2718 b->end = b->ptr = b->buf + b->bufsiz;
2719 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2720 b->posn -= b->bufsiz;
2722 while (count > 0 && b->ptr > b->buf)
2727 if (b->ptr - 2 >= b->buf)
2753 PerlIOCrlf_get_cnt(PerlIO *f)
2755 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2758 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2760 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2761 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2763 STDCHAR *nl = b->ptr;
2765 while (nl < b->end && *nl != 0xd)
2767 if (nl < b->end && *nl == 0xd)
2779 /* Not CR,LF but just CR */
2786 /* Blast - found CR as last char in buffer */
2789 /* They may not care, defer work as long as possible */
2790 return (nl - b->ptr);
2796 b->ptr++; /* say we have read it as far as flush() is concerned */
2797 b->buf++; /* Leave space an front of buffer */
2798 b->bufsiz--; /* Buffer is thus smaller */
2799 code = PerlIO_fill(f); /* Fetch some more */
2800 b->bufsiz++; /* Restore size for next time */
2801 b->buf--; /* Point at space */
2802 b->ptr = nl = b->buf; /* Which is what we hand off */
2803 b->posn--; /* Buffer starts here */
2804 *nl = 0xd; /* Fill in the CR */
2806 goto test; /* fill() call worked */
2807 /* CR at EOF - just fall through */
2812 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2818 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2820 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2821 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2822 IV flags = PerlIOBase(f)->flags;
2832 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2839 /* Test code - delete when it works ... */
2846 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2854 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2855 ptr, chk, flags, c->nl, b->end, cnt);
2862 /* They have taken what we lied about */
2869 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2873 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2875 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2876 return PerlIOBuf_write(f,vbuf,count);
2879 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2880 const STDCHAR *buf = (const STDCHAR *) vbuf;
2881 const STDCHAR *ebuf = buf+count;
2884 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2888 STDCHAR *eptr = b->buf+b->bufsiz;
2889 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2890 while (buf < ebuf && b->ptr < eptr)
2894 if ((b->ptr + 2) > eptr)
2896 /* Not room for both */
2902 *(b->ptr)++ = 0xd; /* CR */
2903 *(b->ptr)++ = 0xa; /* LF */
2905 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2924 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2926 return (buf - (STDCHAR *) vbuf);
2931 PerlIOCrlf_flush(PerlIO *f)
2933 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2939 return PerlIOBuf_flush(f);
2942 PerlIO_funcs PerlIO_crlf = {
2945 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2949 PerlIOBase_noop_ok, /* popped */
2950 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2951 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2952 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2960 PerlIOBase_clearerr,
2961 PerlIOBuf_setlinebuf,
2966 PerlIOCrlf_set_ptrcnt,
2970 /*--------------------------------------------------------------------------------------*/
2971 /* mmap as "buffer" layer */
2975 PerlIOBuf base; /* PerlIOBuf stuff */
2976 Mmap_t mptr; /* Mapped address */
2977 Size_t len; /* mapped length */
2978 STDCHAR *bbuf; /* malloced buffer if map fails */
2981 static size_t page_size = 0;
2984 PerlIOMmap_map(PerlIO *f)
2987 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2988 PerlIOBuf *b = &m->base;
2989 IV flags = PerlIOBase(f)->flags;
2993 if (flags & PERLIO_F_CANREAD)
2995 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2996 int fd = PerlIO_fileno(f);
2998 code = fstat(fd,&st);
2999 if (code == 0 && S_ISREG(st.st_mode))
3001 SSize_t len = st.st_size - b->posn;
3006 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3008 SETERRNO(0,SS$_NORMAL);
3009 # ifdef _SC_PAGESIZE
3010 page_size = sysconf(_SC_PAGESIZE);
3012 page_size = sysconf(_SC_PAGE_SIZE);
3014 if ((long)page_size < 0) {
3019 (void)SvUPGRADE(error, SVt_PV);
3020 msg = SvPVx(error, n_a);
3021 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3024 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3028 # ifdef HAS_GETPAGESIZE
3029 page_size = getpagesize();
3031 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3032 page_size = PAGESIZE; /* compiletime, bad */
3036 if ((IV)page_size <= 0)
3037 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3041 /* This is a hack - should never happen - open should have set it ! */
3042 b->posn = PerlIO_tell(PerlIONext(f));
3044 posn = (b->posn / page_size) * page_size;
3045 len = st.st_size - posn;
3046 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3047 if (m->mptr && m->mptr != (Mmap_t) -1)
3049 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3050 madvise(m->mptr, len, MADV_SEQUENTIAL);
3052 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3053 madvise(m->mptr, len, MADV_WILLNEED);
3055 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3056 b->end = ((STDCHAR *)m->mptr) + len;
3057 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3068 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3070 b->ptr = b->end = b->ptr;
3079 PerlIOMmap_unmap(PerlIO *f)
3081 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3082 PerlIOBuf *b = &m->base;
3088 code = munmap(m->mptr, m->len);
3092 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3095 b->ptr = b->end = b->buf;
3096 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3102 PerlIOMmap_get_base(PerlIO *f)
3104 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3105 PerlIOBuf *b = &m->base;
3106 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3108 /* Already have a readbuffer in progress */
3113 /* We have a write buffer or flushed PerlIOBuf read buffer */
3114 m->bbuf = b->buf; /* save it in case we need it again */
3115 b->buf = NULL; /* Clear to trigger below */
3119 PerlIOMmap_map(f); /* Try and map it */
3122 /* Map did not work - recover PerlIOBuf buffer if we have one */
3126 b->ptr = b->end = b->buf;
3129 return PerlIOBuf_get_base(f);
3133 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3135 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3136 PerlIOBuf *b = &m->base;
3137 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3139 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3142 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3147 /* Loose the unwritable mapped buffer */
3149 /* If flush took the "buffer" see if we have one from before */
3150 if (!b->buf && m->bbuf)
3154 PerlIOBuf_get_base(f);
3158 return PerlIOBuf_unread(f,vbuf,count);
3162 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3164 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3165 PerlIOBuf *b = &m->base;
3166 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3168 /* No, or wrong sort of, buffer */
3171 if (PerlIOMmap_unmap(f) != 0)
3174 /* If unmap took the "buffer" see if we have one from before */
3175 if (!b->buf && m->bbuf)
3179 PerlIOBuf_get_base(f);
3183 return PerlIOBuf_write(f,vbuf,count);
3187 PerlIOMmap_flush(PerlIO *f)
3189 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3190 PerlIOBuf *b = &m->base;
3191 IV code = PerlIOBuf_flush(f);
3192 /* Now we are "synced" at PerlIOBuf level */
3197 /* Unmap the buffer */
3198 if (PerlIOMmap_unmap(f) != 0)
3203 /* We seem to have a PerlIOBuf buffer which was not mapped
3204 * remember it in case we need one later
3213 PerlIOMmap_fill(PerlIO *f)
3215 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3216 IV code = PerlIO_flush(f);
3217 if (code == 0 && !b->buf)
3219 code = PerlIOMmap_map(f);
3221 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3223 code = PerlIOBuf_fill(f);
3229 PerlIOMmap_close(PerlIO *f)
3231 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3232 PerlIOBuf *b = &m->base;
3233 IV code = PerlIO_flush(f);
3238 b->ptr = b->end = b->buf;
3240 if (PerlIOBuf_close(f) != 0)
3246 PerlIO_funcs PerlIO_mmap = {
3264 PerlIOBase_clearerr,
3265 PerlIOBuf_setlinebuf,
3266 PerlIOMmap_get_base,
3270 PerlIOBuf_set_ptrcnt,
3273 #endif /* HAS_MMAP */
3281 atexit(&PerlIO_cleanup);
3293 PerlIO_stdstreams();
3297 #undef PerlIO_stdout
3302 PerlIO_stdstreams();
3306 #undef PerlIO_stderr
3311 PerlIO_stdstreams();
3315 /*--------------------------------------------------------------------------------------*/
3317 #undef PerlIO_getname
3319 PerlIO_getname(PerlIO *f, char *buf)
3322 Perl_croak(aTHX_ "Don't know how to get file name");
3327 /*--------------------------------------------------------------------------------------*/
3328 /* Functions which can be called on any kind of PerlIO implemented
3334 PerlIO_getc(PerlIO *f)
3337 SSize_t count = PerlIO_read(f,buf,1);
3340 return (unsigned char) buf[0];
3345 #undef PerlIO_ungetc
3347 PerlIO_ungetc(PerlIO *f, int ch)
3352 if (PerlIO_unread(f,&buf,1) == 1)
3360 PerlIO_putc(PerlIO *f, int ch)
3363 return PerlIO_write(f,&buf,1);
3368 PerlIO_puts(PerlIO *f, const char *s)
3370 STRLEN len = strlen(s);
3371 return PerlIO_write(f,s,len);
3374 #undef PerlIO_rewind
3376 PerlIO_rewind(PerlIO *f)
3378 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3382 #undef PerlIO_vprintf
3384 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3387 SV *sv = newSVpvn("",0);
3393 Perl_va_copy(ap, apc);
3394 sv_vcatpvf(sv, fmt, &apc);
3396 sv_vcatpvf(sv, fmt, &ap);
3399 wrote = PerlIO_write(f,s,len);
3404 #undef PerlIO_printf
3406 PerlIO_printf(PerlIO *f,const char *fmt,...)
3411 result = PerlIO_vprintf(f,fmt,ap);
3416 #undef PerlIO_stdoutf
3418 PerlIO_stdoutf(const char *fmt,...)
3423 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3428 #undef PerlIO_tmpfile
3430 PerlIO_tmpfile(void)
3432 /* I have no idea how portable mkstemp() is ... */
3433 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3436 FILE *stdio = PerlSIO_tmpfile();
3439 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3445 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3446 int fd = mkstemp(SvPVX(sv));
3450 f = PerlIO_fdopen(fd,"w+");
3453 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3455 PerlLIO_unlink(SvPVX(sv));
3465 #endif /* USE_SFIO */
3466 #endif /* PERLIO_IS_STDIO */
3468 /*======================================================================================*/
3469 /* Now some functions in terms of above which may be needed even if
3470 we are not in true PerlIO mode
3474 #undef PerlIO_setpos
3476 PerlIO_setpos(PerlIO *f, SV *pos)
3482 Off_t *posn = (Off_t *) SvPV(pos,len);
3483 if (f && len == sizeof(Off_t))
3484 return PerlIO_seek(f,*posn,SEEK_SET);
3490 #undef PerlIO_setpos
3492 PerlIO_setpos(PerlIO *f, SV *pos)
3498 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3499 if (f && len == sizeof(Fpos_t))
3501 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3502 return fsetpos64(f, fpos);
3504 return fsetpos(f, fpos);
3514 #undef PerlIO_getpos
3516 PerlIO_getpos(PerlIO *f, SV *pos)
3519 Off_t posn = PerlIO_tell(f);
3520 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3521 return (posn == (Off_t)-1) ? -1 : 0;
3524 #undef PerlIO_getpos
3526 PerlIO_getpos(PerlIO *f, SV *pos)
3531 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3532 code = fgetpos64(f, &fpos);
3534 code = fgetpos(f, &fpos);
3536 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3541 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3544 vprintf(char *pat, char *args)
3546 _doprnt(pat, args, stdout);
3547 return 0; /* wrong, but perl doesn't use the return value */
3551 vfprintf(FILE *fd, char *pat, char *args)
3553 _doprnt(pat, args, fd);
3554 return 0; /* wrong, but perl doesn't use the return value */
3559 #ifndef PerlIO_vsprintf
3561 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3563 int val = vsprintf(s, fmt, ap);
3566 if (strlen(s) >= (STRLEN)n)
3569 (void)PerlIO_puts(Perl_error_log,
3570 "panic: sprintf overflow - memory corrupted!\n");
3578 #ifndef PerlIO_sprintf
3580 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3585 result = PerlIO_vsprintf(s, n, fmt, ap);