3 * Copyright (c) 1996-2000, 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);
105 #ifdef PERLIO_IS_STDIO
110 /* Does nothing (yet) except force this file to be included
111 in perl binary. That allows this file to force inclusion
112 of other functions that may be required by loadable
113 extensions e.g. for FileHandle::tmpfile
117 #undef PerlIO_tmpfile
124 #else /* PERLIO_IS_STDIO */
131 /* This section is just to make sure these functions
132 get pulled in from libsfio.a
135 #undef PerlIO_tmpfile
145 /* Force this file to be included in perl binary. Which allows
146 * this file to force inclusion of other functions that may be
147 * required by loadable extensions e.g. for FileHandle::tmpfile
151 * sfio does its own 'autoflush' on stdout in common cases.
152 * Flush results in a lot of lseek()s to regular files and
153 * lot of small writes to pipes.
155 sfset(sfstdout,SF_SHARE,0);
159 /*======================================================================================*/
160 /* Implement all the PerlIO interface ourselves.
165 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
170 #include <sys/mman.h>
175 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
178 PerlIO_debug(const char *fmt,...)
186 char *s = PerlEnv_getenv("PERLIO_DEBUG");
188 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
195 SV *sv = newSVpvn("",0);
198 s = CopFILE(PL_curcop);
201 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
202 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
205 PerlLIO_write(dbg,s,len);
211 /*--------------------------------------------------------------------------------------*/
213 /* Inner level routines */
215 /* Table of pointers to the PerlIO structs (malloc'ed) */
216 PerlIO *_perlio = NULL;
217 #define PERLIO_TABLE_SIZE 64
220 PerlIO_allocate(pTHX)
222 /* Find a free slot in the table, allocating new table as necessary */
229 last = (PerlIO **)(f);
230 for (i=1; i < PERLIO_TABLE_SIZE; i++)
238 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
248 PerlIO_cleantable(pTHX_ PerlIO **tablep)
250 PerlIO *table = *tablep;
254 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
255 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
263 PerlMemShared_free(table);
275 PerlIO_cleantable(aTHX_ &_perlio);
279 PerlIO_pop(PerlIO *f)
285 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
286 (*l->tab->Popped)(f);
288 PerlMemShared_free(l);
292 /*--------------------------------------------------------------------------------------*/
293 /* XS Interface for perl code */
299 char *s = GvNAME(gv);
300 STRLEN l = GvNAMELEN(gv);
301 PerlIO_debug("%.*s\n",(int) l,s);
305 XS(XS_perlio_unimport)
309 char *s = GvNAME(gv);
310 STRLEN l = GvNAMELEN(gv);
311 PerlIO_debug("%.*s\n",(int) l,s);
316 PerlIO_find_layer(const char *name, STRLEN len)
321 if ((SSize_t) len <= 0)
323 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
324 if (svp && (sv = *svp) && SvROK(sv))
331 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
335 IO *io = GvIOn((GV *)SvRV(sv));
336 PerlIO *ifp = IoIFP(io);
337 PerlIO *ofp = IoOFP(io);
338 AV *av = (AV *) mg->mg_obj;
339 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
345 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
349 IO *io = GvIOn((GV *)SvRV(sv));
350 PerlIO *ifp = IoIFP(io);
351 PerlIO *ofp = IoOFP(io);
352 AV *av = (AV *) mg->mg_obj;
353 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
359 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
361 Perl_warn(aTHX_ "clear %"SVf,sv);
366 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
368 Perl_warn(aTHX_ "free %"SVf,sv);
372 MGVTBL perlio_vtab = {
380 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
383 SV *sv = SvRV(ST(1));
388 sv_magic(sv, (SV *)av, '~', NULL, 0);
390 mg = mg_find(sv,'~');
391 mg->mg_virtual = &perlio_vtab;
393 Perl_warn(aTHX_ "attrib %"SVf,sv);
394 for (i=2; i < items; i++)
397 const char *name = SvPV(ST(i),len);
398 SV *layer = PerlIO_find_layer(name,len);
401 av_push(av,SvREFCNT_inc(layer));
414 PerlIO_define_layer(PerlIO_funcs *tab)
417 HV *stash = gv_stashpv("perlio::Layer", TRUE);
418 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
419 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
420 PerlIO_debug("define %s %p\n",tab->name,tab);
424 PerlIO_default_buffer(pTHX)
426 PerlIO_funcs *tab = &PerlIO_perlio;
427 if (O_BINARY != O_TEXT)
433 if (PerlIO_stdio.Set_ptrcnt)
438 PerlIO_debug("Pushing %s\n",tab->name);
439 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0)));
445 PerlIO_default_layer(I32 n)
450 PerlIO_funcs *tab = &PerlIO_stdio;
452 if (!PerlIO_layer_hv)
454 const char *s = PerlEnv_getenv("PERLIO");
455 newXS("perlio::import",XS_perlio_import,__FILE__);
456 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
458 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
460 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
461 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
462 PerlIO_define_layer(&PerlIO_raw);
463 PerlIO_define_layer(&PerlIO_unix);
464 PerlIO_define_layer(&PerlIO_perlio);
465 PerlIO_define_layer(&PerlIO_stdio);
466 PerlIO_define_layer(&PerlIO_crlf);
468 PerlIO_define_layer(&PerlIO_mmap);
470 PerlIO_define_layer(&PerlIO_utf8);
471 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
477 while (*s && isSPACE((unsigned char)*s))
483 while (*e && !isSPACE((unsigned char)*e))
487 layer = PerlIO_find_layer(s,e-s);
490 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
491 if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED))
494 PerlIO_default_buffer(aTHX);
496 PerlIO_debug("Pushing %.*s\n",(e-s),s);
497 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
498 buffered |= (tab->kind & PERLIO_K_BUFFERED);
501 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
507 len = av_len(PerlIO_layer_av);
510 PerlIO_default_buffer(aTHX);
511 len = av_len(PerlIO_layer_av);
515 svp = av_fetch(PerlIO_layer_av,n,0);
516 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
518 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
520 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
524 #define PerlIO_default_top() PerlIO_default_layer(-1)
525 #define PerlIO_default_btm() PerlIO_default_layer(0)
533 PerlIO_allocate(aTHX);
534 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
535 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
536 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
541 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
545 l = PerlMemShared_calloc(tab->size,sizeof(char));
548 Zero(l,tab->size,char);
552 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
553 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
563 PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
568 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
575 PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
577 /* Pop back to bottom layer */
581 while (PerlIONext(f))
591 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
595 const char *s = names;
605 const char *as = Nullch;
606 const char *ae = Nullch;
608 while (*e && *e != ':' && !isSPACE(*e))
618 if (as && --count == 0)
625 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
627 /* Pop back to bottom layer */
631 while (PerlIONext(f))
637 else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
639 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
641 else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
643 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
647 STRLEN len = ((as) ? as : e)-s;
648 SV *layer = PerlIO_find_layer(s,len);
651 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
654 len = (as) ? (ae-(as++)-1) : 0;
655 if (!PerlIO_push(f,tab,mode,as,len))
660 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
672 /*--------------------------------------------------------------------------------------*/
673 /* Given the abstraction above the public API functions */
676 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
678 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
679 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
680 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
686 if (PerlIOBase(top)->tab == &PerlIO_crlf)
689 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
692 top = PerlIONext(top);
695 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
700 PerlIO__close(PerlIO *f)
702 return (*PerlIOBase(f)->tab->Close)(f);
705 #undef PerlIO_fdupopen
707 PerlIO_fdupopen(pTHX_ PerlIO *f)
710 int fd = PerlLIO_dup(PerlIO_fileno(f));
711 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
714 Off_t posn = PerlIO_tell(f);
715 PerlIO_seek(new,posn,SEEK_SET);
722 PerlIO_close(PerlIO *f)
724 int code = (*PerlIOBase(f)->tab->Close)(f);
734 PerlIO_fileno(PerlIO *f)
736 return (*PerlIOBase(f)->tab->Fileno)(f);
743 PerlIO_fdopen(int fd, const char *mode)
745 PerlIO_funcs *tab = PerlIO_default_top();
748 return (*tab->Fdopen)(tab,fd,mode);
753 PerlIO_open(const char *path, const char *mode)
755 PerlIO_funcs *tab = PerlIO_default_top();
758 return (*tab->Open)(tab,path,mode);
763 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
768 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
770 if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
776 return PerlIO_open(path,mode);
781 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
783 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
788 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
790 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
795 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
797 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
802 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
804 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
809 PerlIO_tell(PerlIO *f)
811 return (*PerlIOBase(f)->tab->Tell)(f);
816 PerlIO_flush(PerlIO *f)
820 return (*PerlIOBase(f)->tab->Flush)(f);
824 PerlIO **table = &_perlio;
829 table = (PerlIO **)(f++);
830 for (i=1; i < PERLIO_TABLE_SIZE; i++)
832 if (*f && PerlIO_flush(f) != 0)
843 PerlIO_fill(PerlIO *f)
845 return (*PerlIOBase(f)->tab->Fill)(f);
850 PerlIO_isutf8(PerlIO *f)
852 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
857 PerlIO_eof(PerlIO *f)
859 return (*PerlIOBase(f)->tab->Eof)(f);
864 PerlIO_error(PerlIO *f)
866 return (*PerlIOBase(f)->tab->Error)(f);
869 #undef PerlIO_clearerr
871 PerlIO_clearerr(PerlIO *f)
874 (*PerlIOBase(f)->tab->Clearerr)(f);
877 #undef PerlIO_setlinebuf
879 PerlIO_setlinebuf(PerlIO *f)
881 (*PerlIOBase(f)->tab->Setlinebuf)(f);
884 #undef PerlIO_has_base
886 PerlIO_has_base(PerlIO *f)
890 return (PerlIOBase(f)->tab->Get_base != NULL);
895 #undef PerlIO_fast_gets
897 PerlIO_fast_gets(PerlIO *f)
899 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
901 PerlIO_funcs *tab = PerlIOBase(f)->tab;
902 return (tab->Set_ptrcnt != NULL);
907 #undef PerlIO_has_cntptr
909 PerlIO_has_cntptr(PerlIO *f)
913 PerlIO_funcs *tab = PerlIOBase(f)->tab;
914 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
919 #undef PerlIO_canset_cnt
921 PerlIO_canset_cnt(PerlIO *f)
925 PerlIOl *l = PerlIOBase(f);
926 return (l->tab->Set_ptrcnt != NULL);
931 #undef PerlIO_get_base
933 PerlIO_get_base(PerlIO *f)
935 return (*PerlIOBase(f)->tab->Get_base)(f);
938 #undef PerlIO_get_bufsiz
940 PerlIO_get_bufsiz(PerlIO *f)
942 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
945 #undef PerlIO_get_ptr
947 PerlIO_get_ptr(PerlIO *f)
949 PerlIO_funcs *tab = PerlIOBase(f)->tab;
950 if (tab->Get_ptr == NULL)
952 return (*tab->Get_ptr)(f);
955 #undef PerlIO_get_cnt
957 PerlIO_get_cnt(PerlIO *f)
959 PerlIO_funcs *tab = PerlIOBase(f)->tab;
960 if (tab->Get_cnt == NULL)
962 return (*tab->Get_cnt)(f);
965 #undef PerlIO_set_cnt
967 PerlIO_set_cnt(PerlIO *f,int cnt)
969 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
972 #undef PerlIO_set_ptrcnt
974 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
976 PerlIO_funcs *tab = PerlIOBase(f)->tab;
977 if (tab->Set_ptrcnt == NULL)
980 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
982 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
985 /*--------------------------------------------------------------------------------------*/
986 /* utf8 and raw dummy layers */
989 PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode)
991 PerlIO_funcs *tab = PerlIO_default_layer(-2);
992 PerlIO *f = (*tab->Fdopen)(tab,fd,mode);
995 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1001 PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode)
1003 PerlIO_funcs *tab = PerlIO_default_layer(-2);
1004 PerlIO *f = (*tab->Open)(tab,path,mode);
1007 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1012 PerlIO_funcs PerlIO_utf8 = {
1015 PERLIO_K_DUMMY|PERLIO_K_BUFFERED,
1034 NULL, /* get_base */
1035 NULL, /* get_bufsiz */
1038 NULL, /* set_ptrcnt */
1042 PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1044 PerlIO_funcs *tab = PerlIO_default_layer(0);
1045 return (*tab->Fdopen)(tab,fd,mode);
1049 PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode)
1051 PerlIO_funcs *tab = PerlIO_default_layer(0);
1052 return (*tab->Open)(tab,path,mode);
1055 PerlIO_funcs PerlIO_raw = {
1058 PERLIO_K_DUMMY|PERLIO_K_RAW,
1077 NULL, /* get_base */
1078 NULL, /* get_bufsiz */
1081 NULL, /* set_ptrcnt */
1083 /*--------------------------------------------------------------------------------------*/
1084 /*--------------------------------------------------------------------------------------*/
1085 /* "Methods" of the "base class" */
1088 PerlIOBase_fileno(PerlIO *f)
1090 return PerlIO_fileno(PerlIONext(f));
1094 PerlIO_modestr(PerlIO *f,char *buf)
1097 IV flags = PerlIOBase(f)->flags;
1098 if (flags & PERLIO_F_APPEND)
1101 if (flags & PERLIO_F_CANREAD)
1106 else if (flags & PERLIO_F_CANREAD)
1109 if (flags & PERLIO_F_CANWRITE)
1112 else if (flags & PERLIO_F_CANWRITE)
1115 if (flags & PERLIO_F_CANREAD)
1120 #if O_TEXT != O_BINARY
1121 if (!(flags & PERLIO_F_CRLF))
1129 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1131 PerlIOl *l = PerlIOBase(f);
1132 const char *omode = mode;
1134 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1135 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1136 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1137 if (tab->Set_ptrcnt != NULL)
1138 l->flags |= PERLIO_F_FASTGETS;
1144 l->flags |= PERLIO_F_CANREAD;
1147 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1150 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1161 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1164 l->flags &= ~PERLIO_F_CRLF;
1167 l->flags |= PERLIO_F_CRLF;
1179 l->flags |= l->next->flags &
1180 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1184 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1185 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1186 l->flags,PerlIO_modestr(f,temp));
1192 PerlIOBase_popped(PerlIO *f)
1198 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1200 Off_t old = PerlIO_tell(f);
1202 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1203 done = PerlIOBuf_unread(f,vbuf,count);
1204 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1209 PerlIOBase_noop_ok(PerlIO *f)
1215 PerlIOBase_noop_fail(PerlIO *f)
1221 PerlIOBase_close(PerlIO *f)
1224 PerlIO *n = PerlIONext(f);
1225 if (PerlIO_flush(f) != 0)
1227 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1229 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1234 PerlIOBase_eof(PerlIO *f)
1238 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1244 PerlIOBase_error(PerlIO *f)
1248 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1254 PerlIOBase_clearerr(PerlIO *f)
1258 PerlIO *n = PerlIONext(f);
1259 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1266 PerlIOBase_setlinebuf(PerlIO *f)
1271 /*--------------------------------------------------------------------------------------*/
1272 /* Bottom-most level for UNIX-like case */
1276 struct _PerlIO base; /* The generic part */
1277 int fd; /* UNIX like file descriptor */
1278 int oflags; /* open/fcntl flags */
1282 PerlIOUnix_oflags(const char *mode)
1297 oflags = O_CREAT|O_TRUNC;
1308 oflags = O_CREAT|O_APPEND;
1324 else if (*mode == 't')
1327 oflags &= ~O_BINARY;
1330 /* Always open in binary mode */
1332 if (*mode || oflags == -1)
1341 PerlIOUnix_fileno(PerlIO *f)
1343 return PerlIOSelf(f,PerlIOUnix)->fd;
1347 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1355 int oflags = PerlIOUnix_oflags(mode);
1358 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1361 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1368 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1372 int oflags = PerlIOUnix_oflags(mode);
1375 int fd = PerlLIO_open3(path,oflags,0666);
1378 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1381 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1388 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1390 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1391 int oflags = PerlIOUnix_oflags(mode);
1392 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1393 (*PerlIOBase(f)->tab->Close)(f);
1397 int fd = PerlLIO_open3(path,oflags,0666);
1402 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1410 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1413 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1414 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1418 SSize_t len = PerlLIO_read(fd,vbuf,count);
1419 if (len >= 0 || errno != EINTR)
1422 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1423 else if (len == 0 && count != 0)
1424 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1432 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1435 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1438 SSize_t len = PerlLIO_write(fd,vbuf,count);
1439 if (len >= 0 || errno != EINTR)
1442 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1450 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1453 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1454 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1455 return (new == (Off_t) -1) ? -1 : 0;
1459 PerlIOUnix_tell(PerlIO *f)
1462 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1463 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1467 PerlIOUnix_close(PerlIO *f)
1470 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1472 while (PerlLIO_close(fd) != 0)
1483 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1488 PerlIO_funcs PerlIO_unix = {
1504 PerlIOBase_noop_ok, /* flush */
1505 PerlIOBase_noop_fail, /* fill */
1508 PerlIOBase_clearerr,
1509 PerlIOBase_setlinebuf,
1510 NULL, /* get_base */
1511 NULL, /* get_bufsiz */
1514 NULL, /* set_ptrcnt */
1517 /*--------------------------------------------------------------------------------------*/
1518 /* stdio as a layer */
1522 struct _PerlIO base;
1523 FILE * stdio; /* The stream */
1527 PerlIOStdio_fileno(PerlIO *f)
1530 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1534 PerlIOStdio_mode(const char *mode,char *tmode)
1541 if (O_BINARY != O_TEXT)
1550 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1569 stdio = PerlSIO_stdin;
1572 stdio = PerlSIO_stdout;
1575 stdio = PerlSIO_stderr;
1581 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1585 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1592 #undef PerlIO_importFILE
1594 PerlIO_importFILE(FILE *stdio, int fl)
1600 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1607 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1611 FILE *stdio = PerlSIO_fopen(path,mode);
1615 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1616 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1624 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1627 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1629 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1637 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1640 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1644 STDCHAR *buf = (STDCHAR *) vbuf;
1645 /* Perl is expecting PerlIO_getc() to fill the buffer
1646 * Linux's stdio does not do that for fread()
1648 int ch = PerlSIO_fgetc(s);
1656 got = PerlSIO_fread(vbuf,1,count,s);
1661 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1664 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1665 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1669 int ch = *buf-- & 0xff;
1670 if (PerlSIO_ungetc(ch,s) != ch)
1679 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1682 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1686 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1689 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1690 return PerlSIO_fseek(stdio,offset,whence);
1694 PerlIOStdio_tell(PerlIO *f)
1697 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1698 return PerlSIO_ftell(stdio);
1702 PerlIOStdio_close(PerlIO *f)
1706 int optval, optlen = sizeof(int);
1708 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1711 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1712 PerlSIO_fclose(stdio) :
1713 close(PerlIO_fileno(f))
1715 PerlSIO_fclose(stdio)
1722 PerlIOStdio_flush(PerlIO *f)
1725 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1726 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1728 return PerlSIO_fflush(stdio);
1733 /* FIXME: This discards ungetc() and pre-read stuff which is
1734 not right if this is just a "sync" from a layer above
1735 Suspect right design is to do _this_ but not have layer above
1736 flush this layer read-to-read
1738 /* Not writeable - sync by attempting a seek */
1740 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1748 PerlIOStdio_fill(PerlIO *f)
1751 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1753 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1754 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1756 if (PerlSIO_fflush(stdio) != 0)
1759 c = PerlSIO_fgetc(stdio);
1760 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1766 PerlIOStdio_eof(PerlIO *f)
1769 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1773 PerlIOStdio_error(PerlIO *f)
1776 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1780 PerlIOStdio_clearerr(PerlIO *f)
1783 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1787 PerlIOStdio_setlinebuf(PerlIO *f)
1790 #ifdef HAS_SETLINEBUF
1791 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1793 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1799 PerlIOStdio_get_base(PerlIO *f)
1802 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1803 return PerlSIO_get_base(stdio);
1807 PerlIOStdio_get_bufsiz(PerlIO *f)
1810 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1811 return PerlSIO_get_bufsiz(stdio);
1815 #ifdef USE_STDIO_PTR
1817 PerlIOStdio_get_ptr(PerlIO *f)
1820 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1821 return PerlSIO_get_ptr(stdio);
1825 PerlIOStdio_get_cnt(PerlIO *f)
1828 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1829 return PerlSIO_get_cnt(stdio);
1833 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1836 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1839 #ifdef STDIO_PTR_LVALUE
1840 PerlSIO_set_ptr(stdio,ptr);
1841 #ifdef STDIO_PTR_LVAL_SETS_CNT
1842 if (PerlSIO_get_cnt(stdio) != (cnt))
1845 assert(PerlSIO_get_cnt(stdio) == (cnt));
1848 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1849 /* Setting ptr _does_ change cnt - we are done */
1852 #else /* STDIO_PTR_LVALUE */
1854 #endif /* STDIO_PTR_LVALUE */
1856 /* Now (or only) set cnt */
1857 #ifdef STDIO_CNT_LVALUE
1858 PerlSIO_set_cnt(stdio,cnt);
1859 #else /* STDIO_CNT_LVALUE */
1860 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1861 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1862 #else /* STDIO_PTR_LVAL_SETS_CNT */
1864 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1865 #endif /* STDIO_CNT_LVALUE */
1870 PerlIO_funcs PerlIO_stdio = {
1872 sizeof(PerlIOStdio),
1890 PerlIOStdio_clearerr,
1891 PerlIOStdio_setlinebuf,
1893 PerlIOStdio_get_base,
1894 PerlIOStdio_get_bufsiz,
1899 #ifdef USE_STDIO_PTR
1900 PerlIOStdio_get_ptr,
1901 PerlIOStdio_get_cnt,
1902 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1903 PerlIOStdio_set_ptrcnt
1904 #else /* STDIO_PTR_LVALUE */
1906 #endif /* STDIO_PTR_LVALUE */
1907 #else /* USE_STDIO_PTR */
1911 #endif /* USE_STDIO_PTR */
1914 #undef PerlIO_exportFILE
1916 PerlIO_exportFILE(PerlIO *f, int fl)
1920 stdio = fdopen(PerlIO_fileno(f),"r+");
1923 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1929 #undef PerlIO_findFILE
1931 PerlIO_findFILE(PerlIO *f)
1936 if (l->tab == &PerlIO_stdio)
1938 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
1941 l = *PerlIONext(&l);
1943 return PerlIO_exportFILE(f,0);
1946 #undef PerlIO_releaseFILE
1948 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1952 /*--------------------------------------------------------------------------------------*/
1953 /* perlio buffer layer */
1956 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1958 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1959 b->posn = PerlIO_tell(PerlIONext(f));
1960 return PerlIOBase_pushed(f,mode,arg,len);
1964 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1967 PerlIO_funcs *tab = PerlIO_default_btm();
1975 #if O_BINARY != O_TEXT
1976 /* do something about failing setmode()? --jhi */
1977 PerlLIO_setmode(fd, O_BINARY);
1979 f = (*tab->Fdopen)(tab,fd,mode);
1982 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1983 if (init && fd == 2)
1985 /* Initial stderr is unbuffered */
1986 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1989 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1990 self->name,f,fd,mode,PerlIOBase(f)->flags);
1997 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1999 PerlIO_funcs *tab = PerlIO_default_btm();
2000 PerlIO *f = (*tab->Open)(tab,path,mode);
2003 PerlIO_push(f,self,mode,Nullch,0);
2009 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
2011 PerlIO *next = PerlIONext(f);
2012 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
2014 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
2018 /* This "flush" is akin to sfio's sync in that it handles files in either
2022 PerlIOBuf_flush(PerlIO *f)
2024 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2026 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2028 /* write() the buffer */
2029 STDCHAR *buf = b->buf;
2032 PerlIO *n = PerlIONext(f);
2035 count = PerlIO_write(n,p,b->ptr - p);
2040 else if (count < 0 || PerlIO_error(n))
2042 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2047 b->posn += (p - buf);
2049 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2051 STDCHAR *buf = PerlIO_get_base(f);
2052 /* Note position change */
2053 b->posn += (b->ptr - buf);
2054 if (b->ptr < b->end)
2056 /* We did not consume all of it */
2057 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2059 b->posn = PerlIO_tell(PerlIONext(f));
2063 b->ptr = b->end = b->buf;
2064 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2065 /* FIXME: Is this right for read case ? */
2066 if (PerlIO_flush(PerlIONext(f)) != 0)
2072 PerlIOBuf_fill(PerlIO *f)
2074 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2075 PerlIO *n = PerlIONext(f);
2077 /* FIXME: doing the down-stream flush is a bad idea if it causes
2078 pre-read data in stdio buffer to be discarded
2079 but this is too simplistic - as it skips _our_ hosekeeping
2080 and breaks tell tests.
2081 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2085 if (PerlIO_flush(f) != 0)
2089 PerlIO_get_base(f); /* allocate via vtable */
2091 b->ptr = b->end = b->buf;
2092 if (PerlIO_fast_gets(n))
2094 /* Layer below is also buffered
2095 * We do _NOT_ want to call its ->Read() because that will loop
2096 * till it gets what we asked for which may hang on a pipe etc.
2097 * Instead take anything it has to hand, or ask it to fill _once_.
2099 avail = PerlIO_get_cnt(n);
2102 avail = PerlIO_fill(n);
2104 avail = PerlIO_get_cnt(n);
2107 if (!PerlIO_error(n) && PerlIO_eof(n))
2113 STDCHAR *ptr = PerlIO_get_ptr(n);
2114 SSize_t cnt = avail;
2115 if (avail > b->bufsiz)
2117 Copy(ptr,b->buf,avail,STDCHAR);
2118 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2123 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2128 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2130 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2133 b->end = b->buf+avail;
2134 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2139 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2141 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2142 STDCHAR *buf = (STDCHAR *) vbuf;
2147 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2151 SSize_t avail = PerlIO_get_cnt(f);
2152 SSize_t take = (count < avail) ? count : avail;
2155 STDCHAR *ptr = PerlIO_get_ptr(f);
2156 Copy(ptr,buf,take,STDCHAR);
2157 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2161 if (count > 0 && avail <= 0)
2163 if (PerlIO_fill(f) != 0)
2167 return (buf - (STDCHAR *) vbuf);
2173 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2175 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2176 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2179 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2185 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2187 avail = (b->ptr - b->buf);
2192 b->end = b->buf + avail;
2194 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2195 b->posn -= b->bufsiz;
2197 if (avail > (SSize_t) count)
2205 Copy(buf,b->ptr,avail,STDCHAR);
2209 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2216 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2218 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2219 const STDCHAR *buf = (const STDCHAR *) vbuf;
2223 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2227 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2228 if ((SSize_t) count < avail)
2230 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2231 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2251 Copy(buf,b->ptr,avail,STDCHAR);
2258 if (b->ptr >= (b->buf + b->bufsiz))
2261 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2267 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2270 if ((code = PerlIO_flush(f)) == 0)
2272 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2273 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2274 code = PerlIO_seek(PerlIONext(f),offset,whence);
2277 b->posn = PerlIO_tell(PerlIONext(f));
2284 PerlIOBuf_tell(PerlIO *f)
2286 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2287 Off_t posn = b->posn;
2289 posn += (b->ptr - b->buf);
2294 PerlIOBuf_close(PerlIO *f)
2297 IV code = PerlIOBase_close(f);
2298 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2299 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2301 PerlMemShared_free(b->buf);
2304 b->ptr = b->end = b->buf;
2305 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2310 PerlIOBuf_setlinebuf(PerlIO *f)
2314 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2319 PerlIOBuf_get_ptr(PerlIO *f)
2321 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2328 PerlIOBuf_get_cnt(PerlIO *f)
2330 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2333 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2334 return (b->end - b->ptr);
2339 PerlIOBuf_get_base(PerlIO *f)
2341 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2347 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2350 b->buf = (STDCHAR *)&b->oneword;
2351 b->bufsiz = sizeof(b->oneword);
2360 PerlIOBuf_bufsiz(PerlIO *f)
2362 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2365 return (b->end - b->buf);
2369 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2371 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2375 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2378 assert(PerlIO_get_cnt(f) == cnt);
2379 assert(b->ptr >= b->buf);
2381 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2384 PerlIO_funcs PerlIO_perlio = {
2404 PerlIOBase_clearerr,
2405 PerlIOBuf_setlinebuf,
2410 PerlIOBuf_set_ptrcnt,
2413 /*--------------------------------------------------------------------------------------*/
2414 /* Temp layer to hold unread chars when cannot do it any other way */
2417 PerlIOPending_fill(PerlIO *f)
2419 /* Should never happen */
2425 PerlIOPending_close(PerlIO *f)
2427 /* A tad tricky - flush pops us, then we close new top */
2429 return PerlIO_close(f);
2433 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2435 /* A tad tricky - flush pops us, then we seek new top */
2437 return PerlIO_seek(f,offset,whence);
2442 PerlIOPending_flush(PerlIO *f)
2444 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2445 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2448 PerlMemShared_free(b->buf);
2456 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2464 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2469 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2471 IV code = PerlIOBase_pushed(f,mode,arg,len);
2472 PerlIOl *l = PerlIOBase(f);
2473 /* Our PerlIO_fast_gets must match what we are pushed on,
2474 or sv_gets() etc. get muddled when it changes mid-string
2477 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2478 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2483 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2485 SSize_t avail = PerlIO_get_cnt(f);
2490 got = PerlIOBuf_read(f,vbuf,avail);
2492 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2497 PerlIO_funcs PerlIO_pending = {
2505 PerlIOPending_pushed,
2512 PerlIOPending_close,
2513 PerlIOPending_flush,
2517 PerlIOBase_clearerr,
2518 PerlIOBuf_setlinebuf,
2523 PerlIOPending_set_ptrcnt,
2528 /*--------------------------------------------------------------------------------------*/
2529 /* crlf - translation
2530 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2531 to hand back a line at a time and keeping a record of which nl we "lied" about.
2532 On write translate "\n" to CR,LF
2537 PerlIOBuf base; /* PerlIOBuf stuff */
2538 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2542 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2545 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2546 code = PerlIOBuf_pushed(f,mode,arg,len);
2548 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2549 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2550 PerlIOBase(f)->flags);
2557 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2559 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2565 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2566 return PerlIOBuf_unread(f,vbuf,count);
2569 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2570 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2572 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2578 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2580 b->end = b->ptr = b->buf + b->bufsiz;
2581 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2582 b->posn -= b->bufsiz;
2584 while (count > 0 && b->ptr > b->buf)
2589 if (b->ptr - 2 >= b->buf)
2615 PerlIOCrlf_get_cnt(PerlIO *f)
2617 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2620 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2622 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2623 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2625 STDCHAR *nl = b->ptr;
2627 while (nl < b->end && *nl != 0xd)
2629 if (nl < b->end && *nl == 0xd)
2641 /* Not CR,LF but just CR */
2648 /* Blast - found CR as last char in buffer */
2651 /* They may not care, defer work as long as possible */
2652 return (nl - b->ptr);
2658 b->ptr++; /* say we have read it as far as flush() is concerned */
2659 b->buf++; /* Leave space an front of buffer */
2660 b->bufsiz--; /* Buffer is thus smaller */
2661 code = PerlIO_fill(f); /* Fetch some more */
2662 b->bufsiz++; /* Restore size for next time */
2663 b->buf--; /* Point at space */
2664 b->ptr = nl = b->buf; /* Which is what we hand off */
2665 b->posn--; /* Buffer starts here */
2666 *nl = 0xd; /* Fill in the CR */
2668 goto test; /* fill() call worked */
2669 /* CR at EOF - just fall through */
2674 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2680 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2682 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2683 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2684 IV flags = PerlIOBase(f)->flags;
2694 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2701 /* Test code - delete when it works ... */
2708 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2716 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2717 ptr, chk, flags, c->nl, b->end, cnt);
2724 /* They have taken what we lied about */
2731 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2735 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2737 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2738 return PerlIOBuf_write(f,vbuf,count);
2741 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2742 const STDCHAR *buf = (const STDCHAR *) vbuf;
2743 const STDCHAR *ebuf = buf+count;
2746 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2750 STDCHAR *eptr = b->buf+b->bufsiz;
2751 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2752 while (buf < ebuf && b->ptr < eptr)
2756 if ((b->ptr + 2) > eptr)
2758 /* Not room for both */
2764 *(b->ptr)++ = 0xd; /* CR */
2765 *(b->ptr)++ = 0xa; /* LF */
2767 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2786 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2788 return (buf - (STDCHAR *) vbuf);
2793 PerlIOCrlf_flush(PerlIO *f)
2795 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2801 return PerlIOBuf_flush(f);
2804 PerlIO_funcs PerlIO_crlf = {
2807 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2813 PerlIOBase_noop_ok, /* popped */
2814 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2815 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2816 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2824 PerlIOBase_clearerr,
2825 PerlIOBuf_setlinebuf,
2830 PerlIOCrlf_set_ptrcnt,
2834 /*--------------------------------------------------------------------------------------*/
2835 /* mmap as "buffer" layer */
2839 PerlIOBuf base; /* PerlIOBuf stuff */
2840 Mmap_t mptr; /* Mapped address */
2841 Size_t len; /* mapped length */
2842 STDCHAR *bbuf; /* malloced buffer if map fails */
2845 static size_t page_size = 0;
2848 PerlIOMmap_map(PerlIO *f)
2851 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2852 PerlIOBuf *b = &m->base;
2853 IV flags = PerlIOBase(f)->flags;
2857 if (flags & PERLIO_F_CANREAD)
2859 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2860 int fd = PerlIO_fileno(f);
2862 code = fstat(fd,&st);
2863 if (code == 0 && S_ISREG(st.st_mode))
2865 SSize_t len = st.st_size - b->posn;
2870 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2872 SETERRNO(0,SS$_NORMAL);
2873 # ifdef _SC_PAGESIZE
2874 page_size = sysconf(_SC_PAGESIZE);
2876 page_size = sysconf(_SC_PAGE_SIZE);
2878 if ((long)page_size < 0) {
2883 (void)SvUPGRADE(error, SVt_PV);
2884 msg = SvPVx(error, n_a);
2885 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2888 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2892 # ifdef HAS_GETPAGESIZE
2893 page_size = getpagesize();
2895 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2896 page_size = PAGESIZE; /* compiletime, bad */
2900 if ((IV)page_size <= 0)
2901 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2905 /* This is a hack - should never happen - open should have set it ! */
2906 b->posn = PerlIO_tell(PerlIONext(f));
2908 posn = (b->posn / page_size) * page_size;
2909 len = st.st_size - posn;
2910 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2911 if (m->mptr && m->mptr != (Mmap_t) -1)
2913 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2914 madvise(m->mptr, len, MADV_SEQUENTIAL);
2916 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2917 madvise(m->mptr, len, MADV_WILLNEED);
2919 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2920 b->end = ((STDCHAR *)m->mptr) + len;
2921 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2932 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2934 b->ptr = b->end = b->ptr;
2943 PerlIOMmap_unmap(PerlIO *f)
2945 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2946 PerlIOBuf *b = &m->base;
2952 code = munmap(m->mptr, m->len);
2956 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2959 b->ptr = b->end = b->buf;
2960 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2966 PerlIOMmap_get_base(PerlIO *f)
2968 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2969 PerlIOBuf *b = &m->base;
2970 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2972 /* Already have a readbuffer in progress */
2977 /* We have a write buffer or flushed PerlIOBuf read buffer */
2978 m->bbuf = b->buf; /* save it in case we need it again */
2979 b->buf = NULL; /* Clear to trigger below */
2983 PerlIOMmap_map(f); /* Try and map it */
2986 /* Map did not work - recover PerlIOBuf buffer if we have one */
2990 b->ptr = b->end = b->buf;
2993 return PerlIOBuf_get_base(f);
2997 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2999 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3000 PerlIOBuf *b = &m->base;
3001 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3003 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3006 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3011 /* Loose the unwritable mapped buffer */
3013 /* If flush took the "buffer" see if we have one from before */
3014 if (!b->buf && m->bbuf)
3018 PerlIOBuf_get_base(f);
3022 return PerlIOBuf_unread(f,vbuf,count);
3026 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3028 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3029 PerlIOBuf *b = &m->base;
3030 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3032 /* No, or wrong sort of, buffer */
3035 if (PerlIOMmap_unmap(f) != 0)
3038 /* If unmap took the "buffer" see if we have one from before */
3039 if (!b->buf && m->bbuf)
3043 PerlIOBuf_get_base(f);
3047 return PerlIOBuf_write(f,vbuf,count);
3051 PerlIOMmap_flush(PerlIO *f)
3053 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3054 PerlIOBuf *b = &m->base;
3055 IV code = PerlIOBuf_flush(f);
3056 /* Now we are "synced" at PerlIOBuf level */
3061 /* Unmap the buffer */
3062 if (PerlIOMmap_unmap(f) != 0)
3067 /* We seem to have a PerlIOBuf buffer which was not mapped
3068 * remember it in case we need one later
3077 PerlIOMmap_fill(PerlIO *f)
3079 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3080 IV code = PerlIO_flush(f);
3081 if (code == 0 && !b->buf)
3083 code = PerlIOMmap_map(f);
3085 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3087 code = PerlIOBuf_fill(f);
3093 PerlIOMmap_close(PerlIO *f)
3095 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3096 PerlIOBuf *b = &m->base;
3097 IV code = PerlIO_flush(f);
3102 b->ptr = b->end = b->buf;
3104 if (PerlIOBuf_close(f) != 0)
3110 PerlIO_funcs PerlIO_mmap = {
3130 PerlIOBase_clearerr,
3131 PerlIOBuf_setlinebuf,
3132 PerlIOMmap_get_base,
3136 PerlIOBuf_set_ptrcnt,
3139 #endif /* HAS_MMAP */
3147 atexit(&PerlIO_cleanup);
3159 PerlIO_stdstreams();
3163 #undef PerlIO_stdout
3168 PerlIO_stdstreams();
3172 #undef PerlIO_stderr
3177 PerlIO_stdstreams();
3181 /*--------------------------------------------------------------------------------------*/
3183 #undef PerlIO_getname
3185 PerlIO_getname(PerlIO *f, char *buf)
3188 Perl_croak(aTHX_ "Don't know how to get file name");
3193 /*--------------------------------------------------------------------------------------*/
3194 /* Functions which can be called on any kind of PerlIO implemented
3200 PerlIO_getc(PerlIO *f)
3203 SSize_t count = PerlIO_read(f,buf,1);
3206 return (unsigned char) buf[0];
3211 #undef PerlIO_ungetc
3213 PerlIO_ungetc(PerlIO *f, int ch)
3218 if (PerlIO_unread(f,&buf,1) == 1)
3226 PerlIO_putc(PerlIO *f, int ch)
3229 return PerlIO_write(f,&buf,1);
3234 PerlIO_puts(PerlIO *f, const char *s)
3236 STRLEN len = strlen(s);
3237 return PerlIO_write(f,s,len);
3240 #undef PerlIO_rewind
3242 PerlIO_rewind(PerlIO *f)
3244 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3248 #undef PerlIO_vprintf
3250 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3253 SV *sv = newSVpvn("",0);
3258 Perl_va_copy(ap, apc);
3259 sv_vcatpvf(sv, fmt, &apc);
3261 sv_vcatpvf(sv, fmt, &ap);
3264 return PerlIO_write(f,s,len);
3267 #undef PerlIO_printf
3269 PerlIO_printf(PerlIO *f,const char *fmt,...)
3274 result = PerlIO_vprintf(f,fmt,ap);
3279 #undef PerlIO_stdoutf
3281 PerlIO_stdoutf(const char *fmt,...)
3286 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3291 #undef PerlIO_tmpfile
3293 PerlIO_tmpfile(void)
3295 /* I have no idea how portable mkstemp() is ... */
3296 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3299 FILE *stdio = PerlSIO_tmpfile();
3302 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3308 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3309 int fd = mkstemp(SvPVX(sv));
3313 f = PerlIO_fdopen(fd,"w+");
3316 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3318 PerlLIO_unlink(SvPVX(sv));
3328 #endif /* USE_SFIO */
3329 #endif /* PERLIO_IS_STDIO */
3331 /*======================================================================================*/
3332 /* Now some functions in terms of above which may be needed even if
3333 we are not in true PerlIO mode
3337 #undef PerlIO_setpos
3339 PerlIO_setpos(PerlIO *f, SV *pos)
3345 Off_t *posn = (Off_t *) SvPV(pos,len);
3346 if (f && len == sizeof(Off_t))
3347 return PerlIO_seek(f,*posn,SEEK_SET);
3353 #undef PerlIO_setpos
3355 PerlIO_setpos(PerlIO *f, SV *pos)
3361 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3362 if (f && len == sizeof(Fpos_t))
3364 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3365 return fsetpos64(f, fpos);
3367 return fsetpos(f, fpos);
3377 #undef PerlIO_getpos
3379 PerlIO_getpos(PerlIO *f, SV *pos)
3382 Off_t posn = PerlIO_tell(f);
3383 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3384 return (posn == (Off_t)-1) ? -1 : 0;
3387 #undef PerlIO_getpos
3389 PerlIO_getpos(PerlIO *f, SV *pos)
3394 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3395 code = fgetpos64(f, &fpos);
3397 code = fgetpos(f, &fpos);
3399 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3404 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3407 vprintf(char *pat, char *args)
3409 _doprnt(pat, args, stdout);
3410 return 0; /* wrong, but perl doesn't use the return value */
3414 vfprintf(FILE *fd, char *pat, char *args)
3416 _doprnt(pat, args, fd);
3417 return 0; /* wrong, but perl doesn't use the return value */
3422 #ifndef PerlIO_vsprintf
3424 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3426 int val = vsprintf(s, fmt, ap);
3429 if (strlen(s) >= (STRLEN)n)
3432 (void)PerlIO_puts(Perl_error_log,
3433 "panic: sprintf overflow - memory corrupted!\n");
3441 #ifndef PerlIO_sprintf
3443 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3448 result = PerlIO_vsprintf(s, n, fmt, ap);