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);
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);
287 (*l->tab->Popped)(f);
289 PerlMemShared_free(l);
293 /*--------------------------------------------------------------------------------------*/
294 /* XS Interface for perl code */
300 char *s = GvNAME(gv);
301 STRLEN l = GvNAMELEN(gv);
302 PerlIO_debug("%.*s\n",(int) l,s);
306 XS(XS_perlio_unimport)
310 char *s = GvNAME(gv);
311 STRLEN l = GvNAMELEN(gv);
312 PerlIO_debug("%.*s\n",(int) l,s);
317 PerlIO_find_layer(const char *name, STRLEN len)
322 if ((SSize_t) len <= 0)
324 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
325 if (svp && (sv = *svp) && SvROK(sv))
332 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
336 IO *io = GvIOn((GV *)SvRV(sv));
337 PerlIO *ifp = IoIFP(io);
338 PerlIO *ofp = IoOFP(io);
339 AV *av = (AV *) mg->mg_obj;
340 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
346 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
350 IO *io = GvIOn((GV *)SvRV(sv));
351 PerlIO *ifp = IoIFP(io);
352 PerlIO *ofp = IoOFP(io);
353 AV *av = (AV *) mg->mg_obj;
354 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
360 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
362 Perl_warn(aTHX_ "clear %"SVf,sv);
367 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
369 Perl_warn(aTHX_ "free %"SVf,sv);
373 MGVTBL perlio_vtab = {
381 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
384 SV *sv = SvRV(ST(1));
389 sv_magic(sv, (SV *)av, '~', NULL, 0);
391 mg = mg_find(sv,'~');
392 mg->mg_virtual = &perlio_vtab;
394 Perl_warn(aTHX_ "attrib %"SVf,sv);
395 for (i=2; i < items; i++)
398 const char *name = SvPV(ST(i),len);
399 SV *layer = PerlIO_find_layer(name,len);
402 av_push(av,SvREFCNT_inc(layer));
415 PerlIO_define_layer(PerlIO_funcs *tab)
418 HV *stash = gv_stashpv("perlio::Layer", TRUE);
419 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
420 if (!PerlIO_layer_hv)
422 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
424 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
425 PerlIO_debug("define %s %p\n",tab->name,tab);
429 PerlIO_default_buffer(pTHX)
431 PerlIO_funcs *tab = &PerlIO_perlio;
432 if (O_BINARY != O_TEXT)
438 if (PerlIO_stdio.Set_ptrcnt)
443 PerlIO_debug("Pushing %s\n",tab->name);
444 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0)));
449 PerlIO_default_layer(I32 n)
454 PerlIO_funcs *tab = &PerlIO_stdio;
456 if (!PerlIO_layer_av)
458 const char *s = PerlEnv_getenv("PERLIO");
459 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
460 newXS("perlio::import",XS_perlio_import,__FILE__);
461 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
463 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
465 PerlIO_define_layer(&PerlIO_raw);
466 PerlIO_define_layer(&PerlIO_unix);
467 PerlIO_define_layer(&PerlIO_perlio);
468 PerlIO_define_layer(&PerlIO_stdio);
469 PerlIO_define_layer(&PerlIO_crlf);
471 PerlIO_define_layer(&PerlIO_mmap);
473 PerlIO_define_layer(&PerlIO_utf8);
474 PerlIO_define_layer(&PerlIO_byte);
475 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
481 while (*s && isSPACE((unsigned char)*s))
487 while (*e && !isSPACE((unsigned char)*e))
491 layer = PerlIO_find_layer(s,e-s);
494 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
495 if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED))
498 PerlIO_default_buffer(aTHX);
500 PerlIO_debug("Pushing %.*s\n",(e-s),s);
501 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
502 buffered |= (tab->kind & PERLIO_K_BUFFERED);
505 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
511 len = av_len(PerlIO_layer_av);
514 PerlIO_default_buffer(aTHX);
515 len = av_len(PerlIO_layer_av);
519 svp = av_fetch(PerlIO_layer_av,n,0);
520 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
522 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
524 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
528 #define PerlIO_default_top() PerlIO_default_layer(-1)
529 #define PerlIO_default_btm() PerlIO_default_layer(0)
537 PerlIO_allocate(aTHX);
538 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
539 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
540 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
545 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
549 l = PerlMemShared_calloc(tab->size,sizeof(char));
552 Zero(l,tab->size,char);
556 PerlIO_debug("PerlIO_push f=%p %s %s '%.*s'\n",
557 f,tab->name,(mode) ? mode : "(Null)",(int) len,arg);
558 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
568 PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
581 PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
583 /* Remove the dummy layer */
585 /* Pop back to bottom layer */
590 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
598 /* Nothing bellow - push unix on top then remove it */
599 if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len))
601 PerlIO_pop(PerlIONext(f));
606 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
613 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
617 const char *s = names;
620 while (isSPACE(*s) || *s == ':')
626 const char *as = Nullch;
630 /* Message is consistent with how attribute lists are passed.
631 Even though this means "foo : : bar" is seen as an invalid separator
633 char q = ((*s == '\'') ? '"' : '\'');
634 Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
640 } while (isALNUM(*e));
658 /* It's a nul terminated string, not allowed to \ the terminating null.
659 Anything other character is passed over. */
667 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
677 SV *layer = PerlIO_find_layer(s,llen);
680 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
683 if (!PerlIO_push(f,tab,mode,as,alen))
688 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
701 /*--------------------------------------------------------------------------------------*/
702 /* Given the abstraction above the public API functions */
705 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
707 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
708 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
709 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
715 if (PerlIOBase(top)->tab == &PerlIO_crlf)
718 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
721 top = PerlIONext(top);
724 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
729 PerlIO__close(PerlIO *f)
731 return (*PerlIOBase(f)->tab->Close)(f);
734 #undef PerlIO_fdupopen
736 PerlIO_fdupopen(pTHX_ PerlIO *f)
739 int fd = PerlLIO_dup(PerlIO_fileno(f));
740 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
743 Off_t posn = PerlIO_tell(f);
744 PerlIO_seek(new,posn,SEEK_SET);
751 PerlIO_close(PerlIO *f)
753 int code = (*PerlIOBase(f)->tab->Close)(f);
763 PerlIO_fileno(PerlIO *f)
765 return (*PerlIOBase(f)->tab->Fileno)(f);
772 PerlIO_fdopen(int fd, const char *mode)
774 PerlIO_funcs *tab = PerlIO_default_top();
777 return (*tab->Fdopen)(tab,fd,mode);
782 PerlIO_open(const char *path, const char *mode)
784 PerlIO_funcs *tab = PerlIO_default_top();
787 return (*tab->Open)(tab,path,mode);
792 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
797 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
799 if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
805 return PerlIO_open(path,mode);
810 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
812 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
817 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
819 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
824 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
826 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
831 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
833 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
838 PerlIO_tell(PerlIO *f)
840 return (*PerlIOBase(f)->tab->Tell)(f);
845 PerlIO_flush(PerlIO *f)
849 PerlIO_funcs *tab = PerlIOBase(f)->tab;
850 if (tab && tab->Flush)
852 return (*tab->Flush)(f);
856 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
863 PerlIO **table = &_perlio;
868 table = (PerlIO **)(f++);
869 for (i=1; i < PERLIO_TABLE_SIZE; i++)
871 if (*f && PerlIO_flush(f) != 0)
882 PerlIO_fill(PerlIO *f)
884 return (*PerlIOBase(f)->tab->Fill)(f);
889 PerlIO_isutf8(PerlIO *f)
891 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
896 PerlIO_eof(PerlIO *f)
898 return (*PerlIOBase(f)->tab->Eof)(f);
903 PerlIO_error(PerlIO *f)
905 return (*PerlIOBase(f)->tab->Error)(f);
908 #undef PerlIO_clearerr
910 PerlIO_clearerr(PerlIO *f)
913 (*PerlIOBase(f)->tab->Clearerr)(f);
916 #undef PerlIO_setlinebuf
918 PerlIO_setlinebuf(PerlIO *f)
920 (*PerlIOBase(f)->tab->Setlinebuf)(f);
923 #undef PerlIO_has_base
925 PerlIO_has_base(PerlIO *f)
929 return (PerlIOBase(f)->tab->Get_base != NULL);
934 #undef PerlIO_fast_gets
936 PerlIO_fast_gets(PerlIO *f)
938 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
940 PerlIO_funcs *tab = PerlIOBase(f)->tab;
941 return (tab->Set_ptrcnt != NULL);
946 #undef PerlIO_has_cntptr
948 PerlIO_has_cntptr(PerlIO *f)
952 PerlIO_funcs *tab = PerlIOBase(f)->tab;
953 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
958 #undef PerlIO_canset_cnt
960 PerlIO_canset_cnt(PerlIO *f)
964 PerlIOl *l = PerlIOBase(f);
965 return (l->tab->Set_ptrcnt != NULL);
970 #undef PerlIO_get_base
972 PerlIO_get_base(PerlIO *f)
974 return (*PerlIOBase(f)->tab->Get_base)(f);
977 #undef PerlIO_get_bufsiz
979 PerlIO_get_bufsiz(PerlIO *f)
981 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
984 #undef PerlIO_get_ptr
986 PerlIO_get_ptr(PerlIO *f)
988 PerlIO_funcs *tab = PerlIOBase(f)->tab;
989 if (tab->Get_ptr == NULL)
991 return (*tab->Get_ptr)(f);
994 #undef PerlIO_get_cnt
996 PerlIO_get_cnt(PerlIO *f)
998 PerlIO_funcs *tab = PerlIOBase(f)->tab;
999 if (tab->Get_cnt == NULL)
1001 return (*tab->Get_cnt)(f);
1004 #undef PerlIO_set_cnt
1006 PerlIO_set_cnt(PerlIO *f,int cnt)
1008 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
1011 #undef PerlIO_set_ptrcnt
1013 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
1015 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1016 if (tab->Set_ptrcnt == NULL)
1019 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1021 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1024 /*--------------------------------------------------------------------------------------*/
1025 /* utf8 and raw dummy layers */
1028 PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1032 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1034 if (tab->kind & PERLIO_K_UTF8)
1035 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1037 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1044 PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1046 PerlIO_funcs *tab = PerlIO_default_layer(-2);
1047 PerlIO *f = (*tab->Fdopen)(tab,fd,mode);
1050 PerlIOl *l = PerlIOBase(f);
1051 if (tab->kind & PERLIO_K_UTF8)
1052 l->flags |= PERLIO_F_UTF8;
1054 l->flags &= ~PERLIO_F_UTF8;
1060 PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode)
1062 PerlIO_funcs *tab = PerlIO_default_layer(-2);
1063 PerlIO *f = (*tab->Open)(tab,path,mode);
1066 PerlIOl *l = PerlIOBase(f);
1067 if (tab->kind & PERLIO_K_UTF8)
1068 l->flags |= PERLIO_F_UTF8;
1070 l->flags &= ~PERLIO_F_UTF8;
1075 PerlIO_funcs PerlIO_utf8 = {
1078 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1097 NULL, /* get_base */
1098 NULL, /* get_bufsiz */
1101 NULL, /* set_ptrcnt */
1104 PerlIO_funcs PerlIO_byte = {
1126 NULL, /* get_base */
1127 NULL, /* get_bufsiz */
1130 NULL, /* set_ptrcnt */
1134 PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1136 PerlIO_funcs *tab = PerlIO_default_btm();
1137 return (*tab->Fdopen)(tab,fd,mode);
1141 PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode)
1143 PerlIO_funcs *tab = PerlIO_default_btm();
1144 return (*tab->Open)(tab,path,mode);
1147 PerlIO_funcs PerlIO_raw = {
1169 NULL, /* get_base */
1170 NULL, /* get_bufsiz */
1173 NULL, /* set_ptrcnt */
1175 /*--------------------------------------------------------------------------------------*/
1176 /*--------------------------------------------------------------------------------------*/
1177 /* "Methods" of the "base class" */
1180 PerlIOBase_fileno(PerlIO *f)
1182 return PerlIO_fileno(PerlIONext(f));
1186 PerlIO_modestr(PerlIO *f,char *buf)
1189 IV flags = PerlIOBase(f)->flags;
1190 if (flags & PERLIO_F_APPEND)
1193 if (flags & PERLIO_F_CANREAD)
1198 else if (flags & PERLIO_F_CANREAD)
1201 if (flags & PERLIO_F_CANWRITE)
1204 else if (flags & PERLIO_F_CANWRITE)
1207 if (flags & PERLIO_F_CANREAD)
1212 #if O_TEXT != O_BINARY
1213 if (!(flags & PERLIO_F_CRLF))
1221 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1223 PerlIOl *l = PerlIOBase(f);
1224 const char *omode = mode;
1226 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1227 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1228 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1229 if (tab->Set_ptrcnt != NULL)
1230 l->flags |= PERLIO_F_FASTGETS;
1236 l->flags |= PERLIO_F_CANREAD;
1239 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1242 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1253 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1256 l->flags &= ~PERLIO_F_CRLF;
1259 l->flags |= PERLIO_F_CRLF;
1271 l->flags |= l->next->flags &
1272 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1276 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1277 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1278 l->flags,PerlIO_modestr(f,temp));
1284 PerlIOBase_popped(PerlIO *f)
1290 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1292 Off_t old = PerlIO_tell(f);
1294 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1295 done = PerlIOBuf_unread(f,vbuf,count);
1296 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1301 PerlIOBase_noop_ok(PerlIO *f)
1307 PerlIOBase_noop_fail(PerlIO *f)
1313 PerlIOBase_close(PerlIO *f)
1316 PerlIO *n = PerlIONext(f);
1317 if (PerlIO_flush(f) != 0)
1319 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1321 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1326 PerlIOBase_eof(PerlIO *f)
1330 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1336 PerlIOBase_error(PerlIO *f)
1340 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1346 PerlIOBase_clearerr(PerlIO *f)
1350 PerlIO *n = PerlIONext(f);
1351 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1358 PerlIOBase_setlinebuf(PerlIO *f)
1363 /*--------------------------------------------------------------------------------------*/
1364 /* Bottom-most level for UNIX-like case */
1368 struct _PerlIO base; /* The generic part */
1369 int fd; /* UNIX like file descriptor */
1370 int oflags; /* open/fcntl flags */
1374 PerlIOUnix_oflags(const char *mode)
1389 oflags = O_CREAT|O_TRUNC;
1400 oflags = O_CREAT|O_APPEND;
1416 else if (*mode == 't')
1419 oflags &= ~O_BINARY;
1422 /* Always open in binary mode */
1424 if (*mode || oflags == -1)
1433 PerlIOUnix_fileno(PerlIO *f)
1435 return PerlIOSelf(f,PerlIOUnix)->fd;
1439 PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1441 IV code = PerlIOBase_pushed(f,mode,arg,len);
1444 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1445 s->fd = PerlIO_fileno(PerlIONext(f));
1446 s->oflags = PerlIOUnix_oflags(mode);
1448 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1453 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1461 int oflags = PerlIOUnix_oflags(mode);
1464 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1473 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1477 int oflags = PerlIOUnix_oflags(mode);
1480 int fd = PerlLIO_open3(path,oflags,0666);
1483 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1486 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1493 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1495 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1496 int oflags = PerlIOUnix_oflags(mode);
1497 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1498 (*PerlIOBase(f)->tab->Close)(f);
1502 int fd = PerlLIO_open3(path,oflags,0666);
1507 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1515 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1518 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1519 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1523 SSize_t len = PerlLIO_read(fd,vbuf,count);
1524 if (len >= 0 || errno != EINTR)
1527 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1528 else if (len == 0 && count != 0)
1529 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1537 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1540 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1543 SSize_t len = PerlLIO_write(fd,vbuf,count);
1544 if (len >= 0 || errno != EINTR)
1547 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1555 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1558 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1559 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1560 return (new == (Off_t) -1) ? -1 : 0;
1564 PerlIOUnix_tell(PerlIO *f)
1567 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1568 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1572 PerlIOUnix_close(PerlIO *f)
1575 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1577 while (PerlLIO_close(fd) != 0)
1588 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1593 PerlIO_funcs PerlIO_unix = {
1609 PerlIOBase_noop_ok, /* flush */
1610 PerlIOBase_noop_fail, /* fill */
1613 PerlIOBase_clearerr,
1614 PerlIOBase_setlinebuf,
1615 NULL, /* get_base */
1616 NULL, /* get_bufsiz */
1619 NULL, /* set_ptrcnt */
1622 /*--------------------------------------------------------------------------------------*/
1623 /* stdio as a layer */
1627 struct _PerlIO base;
1628 FILE * stdio; /* The stream */
1632 PerlIOStdio_fileno(PerlIO *f)
1635 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1639 PerlIOStdio_mode(const char *mode,char *tmode)
1646 if (O_BINARY != O_TEXT)
1655 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1674 stdio = PerlSIO_stdin;
1677 stdio = PerlSIO_stdout;
1680 stdio = PerlSIO_stderr;
1686 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1690 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1697 /* This isn't used yet ... */
1699 PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1704 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1706 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1712 return PerlIOBase_pushed(f,mode,arg,len);
1715 #undef PerlIO_importFILE
1717 PerlIO_importFILE(FILE *stdio, int fl)
1723 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1730 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1734 FILE *stdio = PerlSIO_fopen(path,mode);
1738 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1739 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1747 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1750 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1752 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1760 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1763 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1767 STDCHAR *buf = (STDCHAR *) vbuf;
1768 /* Perl is expecting PerlIO_getc() to fill the buffer
1769 * Linux's stdio does not do that for fread()
1771 int ch = PerlSIO_fgetc(s);
1779 got = PerlSIO_fread(vbuf,1,count,s);
1784 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1787 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1788 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1792 int ch = *buf-- & 0xff;
1793 if (PerlSIO_ungetc(ch,s) != ch)
1802 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1805 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1809 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1812 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1813 return PerlSIO_fseek(stdio,offset,whence);
1817 PerlIOStdio_tell(PerlIO *f)
1820 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1821 return PerlSIO_ftell(stdio);
1825 PerlIOStdio_close(PerlIO *f)
1828 #ifdef HAS_SOCKS5_INIT
1829 int optval, optlen = sizeof(int);
1831 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1833 #ifdef HAS_SOCKS5_INIT
1834 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1835 PerlSIO_fclose(stdio) :
1836 close(PerlIO_fileno(f))
1838 PerlSIO_fclose(stdio)
1845 PerlIOStdio_flush(PerlIO *f)
1848 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1849 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1851 return PerlSIO_fflush(stdio);
1856 /* FIXME: This discards ungetc() and pre-read stuff which is
1857 not right if this is just a "sync" from a layer above
1858 Suspect right design is to do _this_ but not have layer above
1859 flush this layer read-to-read
1861 /* Not writeable - sync by attempting a seek */
1863 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1871 PerlIOStdio_fill(PerlIO *f)
1874 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1876 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1877 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1879 if (PerlSIO_fflush(stdio) != 0)
1882 c = PerlSIO_fgetc(stdio);
1883 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1889 PerlIOStdio_eof(PerlIO *f)
1892 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1896 PerlIOStdio_error(PerlIO *f)
1899 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1903 PerlIOStdio_clearerr(PerlIO *f)
1906 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1910 PerlIOStdio_setlinebuf(PerlIO *f)
1913 #ifdef HAS_SETLINEBUF
1914 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1916 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1922 PerlIOStdio_get_base(PerlIO *f)
1925 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1926 return PerlSIO_get_base(stdio);
1930 PerlIOStdio_get_bufsiz(PerlIO *f)
1933 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1934 return PerlSIO_get_bufsiz(stdio);
1938 #ifdef USE_STDIO_PTR
1940 PerlIOStdio_get_ptr(PerlIO *f)
1943 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1944 return PerlSIO_get_ptr(stdio);
1948 PerlIOStdio_get_cnt(PerlIO *f)
1951 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1952 return PerlSIO_get_cnt(stdio);
1956 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1959 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1962 #ifdef STDIO_PTR_LVALUE
1963 PerlSIO_set_ptr(stdio,ptr);
1964 #ifdef STDIO_PTR_LVAL_SETS_CNT
1965 if (PerlSIO_get_cnt(stdio) != (cnt))
1968 assert(PerlSIO_get_cnt(stdio) == (cnt));
1971 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1972 /* Setting ptr _does_ change cnt - we are done */
1975 #else /* STDIO_PTR_LVALUE */
1977 #endif /* STDIO_PTR_LVALUE */
1979 /* Now (or only) set cnt */
1980 #ifdef STDIO_CNT_LVALUE
1981 PerlSIO_set_cnt(stdio,cnt);
1982 #else /* STDIO_CNT_LVALUE */
1983 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1984 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1985 #else /* STDIO_PTR_LVAL_SETS_CNT */
1987 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1988 #endif /* STDIO_CNT_LVALUE */
1993 PerlIO_funcs PerlIO_stdio = {
1995 sizeof(PerlIOStdio),
2013 PerlIOStdio_clearerr,
2014 PerlIOStdio_setlinebuf,
2016 PerlIOStdio_get_base,
2017 PerlIOStdio_get_bufsiz,
2022 #ifdef USE_STDIO_PTR
2023 PerlIOStdio_get_ptr,
2024 PerlIOStdio_get_cnt,
2025 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2026 PerlIOStdio_set_ptrcnt
2027 #else /* STDIO_PTR_LVALUE */
2029 #endif /* STDIO_PTR_LVALUE */
2030 #else /* USE_STDIO_PTR */
2034 #endif /* USE_STDIO_PTR */
2037 #undef PerlIO_exportFILE
2039 PerlIO_exportFILE(PerlIO *f, int fl)
2043 stdio = fdopen(PerlIO_fileno(f),"r+");
2046 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
2052 #undef PerlIO_findFILE
2054 PerlIO_findFILE(PerlIO *f)
2059 if (l->tab == &PerlIO_stdio)
2061 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2064 l = *PerlIONext(&l);
2066 return PerlIO_exportFILE(f,0);
2069 #undef PerlIO_releaseFILE
2071 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2075 /*--------------------------------------------------------------------------------------*/
2076 /* perlio buffer layer */
2079 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
2081 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2082 b->posn = PerlIO_tell(PerlIONext(f));
2083 return PerlIOBase_pushed(f,mode,arg,len);
2087 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
2090 PerlIO_funcs *tab = PerlIO_default_btm();
2098 #if O_BINARY != O_TEXT
2099 /* do something about failing setmode()? --jhi */
2100 PerlLIO_setmode(fd, O_BINARY);
2102 f = (*tab->Fdopen)(tab,fd,mode);
2105 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
2106 if (init && fd == 2)
2108 /* Initial stderr is unbuffered */
2109 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2112 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
2113 self->name,f,fd,mode,PerlIOBase(f)->flags);
2120 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
2122 PerlIO_funcs *tab = PerlIO_default_btm();
2123 PerlIO *f = (*tab->Open)(tab,path,mode);
2126 PerlIO_push(f,self,mode,Nullch,0);
2132 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
2134 PerlIO *next = PerlIONext(f);
2135 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
2137 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
2141 /* This "flush" is akin to sfio's sync in that it handles files in either
2145 PerlIOBuf_flush(PerlIO *f)
2147 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2149 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2151 /* write() the buffer */
2152 STDCHAR *buf = b->buf;
2154 PerlIO *n = PerlIONext(f);
2157 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2162 else if (count < 0 || PerlIO_error(n))
2164 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2169 b->posn += (p - buf);
2171 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2173 STDCHAR *buf = PerlIO_get_base(f);
2174 /* Note position change */
2175 b->posn += (b->ptr - buf);
2176 if (b->ptr < b->end)
2178 /* We did not consume all of it */
2179 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2181 b->posn = PerlIO_tell(PerlIONext(f));
2185 b->ptr = b->end = b->buf;
2186 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2187 /* FIXME: Is this right for read case ? */
2188 if (PerlIO_flush(PerlIONext(f)) != 0)
2194 PerlIOBuf_fill(PerlIO *f)
2196 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2197 PerlIO *n = PerlIONext(f);
2199 /* FIXME: doing the down-stream flush is a bad idea if it causes
2200 pre-read data in stdio buffer to be discarded
2201 but this is too simplistic - as it skips _our_ hosekeeping
2202 and breaks tell tests.
2203 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2207 if (PerlIO_flush(f) != 0)
2211 PerlIO_get_base(f); /* allocate via vtable */
2213 b->ptr = b->end = b->buf;
2214 if (PerlIO_fast_gets(n))
2216 /* Layer below is also buffered
2217 * We do _NOT_ want to call its ->Read() because that will loop
2218 * till it gets what we asked for which may hang on a pipe etc.
2219 * Instead take anything it has to hand, or ask it to fill _once_.
2221 avail = PerlIO_get_cnt(n);
2224 avail = PerlIO_fill(n);
2226 avail = PerlIO_get_cnt(n);
2229 if (!PerlIO_error(n) && PerlIO_eof(n))
2235 STDCHAR *ptr = PerlIO_get_ptr(n);
2236 SSize_t cnt = avail;
2237 if (avail > b->bufsiz)
2239 Copy(ptr,b->buf,avail,STDCHAR);
2240 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2245 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2250 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2252 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2255 b->end = b->buf+avail;
2256 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2261 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2263 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2264 STDCHAR *buf = (STDCHAR *) vbuf;
2269 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2273 SSize_t avail = PerlIO_get_cnt(f);
2274 SSize_t take = (count < avail) ? count : avail;
2277 STDCHAR *ptr = PerlIO_get_ptr(f);
2278 Copy(ptr,buf,take,STDCHAR);
2279 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2283 if (count > 0 && avail <= 0)
2285 if (PerlIO_fill(f) != 0)
2289 return (buf - (STDCHAR *) vbuf);
2295 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2297 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2298 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2301 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2307 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2309 avail = (b->ptr - b->buf);
2314 b->end = b->buf + avail;
2316 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2317 b->posn -= b->bufsiz;
2319 if (avail > (SSize_t) count)
2327 Copy(buf,b->ptr,avail,STDCHAR);
2331 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2338 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2340 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2341 const STDCHAR *buf = (const STDCHAR *) vbuf;
2345 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2349 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2350 if ((SSize_t) count < avail)
2352 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2353 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2373 Copy(buf,b->ptr,avail,STDCHAR);
2380 if (b->ptr >= (b->buf + b->bufsiz))
2383 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2389 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2392 if ((code = PerlIO_flush(f)) == 0)
2394 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2395 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2396 code = PerlIO_seek(PerlIONext(f),offset,whence);
2399 b->posn = PerlIO_tell(PerlIONext(f));
2406 PerlIOBuf_tell(PerlIO *f)
2408 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2409 Off_t posn = b->posn;
2411 posn += (b->ptr - b->buf);
2416 PerlIOBuf_close(PerlIO *f)
2419 IV code = PerlIOBase_close(f);
2420 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2421 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2423 PerlMemShared_free(b->buf);
2426 b->ptr = b->end = b->buf;
2427 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2432 PerlIOBuf_setlinebuf(PerlIO *f)
2436 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2441 PerlIOBuf_get_ptr(PerlIO *f)
2443 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2450 PerlIOBuf_get_cnt(PerlIO *f)
2452 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2455 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2456 return (b->end - b->ptr);
2461 PerlIOBuf_get_base(PerlIO *f)
2463 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2469 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2472 b->buf = (STDCHAR *)&b->oneword;
2473 b->bufsiz = sizeof(b->oneword);
2482 PerlIOBuf_bufsiz(PerlIO *f)
2484 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2487 return (b->end - b->buf);
2491 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2493 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2497 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2500 assert(PerlIO_get_cnt(f) == cnt);
2501 assert(b->ptr >= b->buf);
2503 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2506 PerlIO_funcs PerlIO_perlio = {
2526 PerlIOBase_clearerr,
2527 PerlIOBuf_setlinebuf,
2532 PerlIOBuf_set_ptrcnt,
2535 /*--------------------------------------------------------------------------------------*/
2536 /* Temp layer to hold unread chars when cannot do it any other way */
2539 PerlIOPending_fill(PerlIO *f)
2541 /* Should never happen */
2547 PerlIOPending_close(PerlIO *f)
2549 /* A tad tricky - flush pops us, then we close new top */
2551 return PerlIO_close(f);
2555 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2557 /* A tad tricky - flush pops us, then we seek new top */
2559 return PerlIO_seek(f,offset,whence);
2564 PerlIOPending_flush(PerlIO *f)
2566 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2567 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2570 PerlMemShared_free(b->buf);
2578 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2586 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2591 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2593 IV code = PerlIOBase_pushed(f,mode,arg,len);
2594 PerlIOl *l = PerlIOBase(f);
2595 /* Our PerlIO_fast_gets must match what we are pushed on,
2596 or sv_gets() etc. get muddled when it changes mid-string
2599 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2600 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2605 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2607 SSize_t avail = PerlIO_get_cnt(f);
2612 got = PerlIOBuf_read(f,vbuf,avail);
2614 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2619 PerlIO_funcs PerlIO_pending = {
2627 PerlIOPending_pushed,
2634 PerlIOPending_close,
2635 PerlIOPending_flush,
2639 PerlIOBase_clearerr,
2640 PerlIOBuf_setlinebuf,
2645 PerlIOPending_set_ptrcnt,
2650 /*--------------------------------------------------------------------------------------*/
2651 /* crlf - translation
2652 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2653 to hand back a line at a time and keeping a record of which nl we "lied" about.
2654 On write translate "\n" to CR,LF
2659 PerlIOBuf base; /* PerlIOBuf stuff */
2660 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2664 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2667 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2668 code = PerlIOBuf_pushed(f,mode,arg,len);
2670 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2671 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2672 PerlIOBase(f)->flags);
2679 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2681 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2687 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2688 return PerlIOBuf_unread(f,vbuf,count);
2691 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2692 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2694 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2700 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2702 b->end = b->ptr = b->buf + b->bufsiz;
2703 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2704 b->posn -= b->bufsiz;
2706 while (count > 0 && b->ptr > b->buf)
2711 if (b->ptr - 2 >= b->buf)
2737 PerlIOCrlf_get_cnt(PerlIO *f)
2739 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2742 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2744 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2745 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2747 STDCHAR *nl = b->ptr;
2749 while (nl < b->end && *nl != 0xd)
2751 if (nl < b->end && *nl == 0xd)
2763 /* Not CR,LF but just CR */
2770 /* Blast - found CR as last char in buffer */
2773 /* They may not care, defer work as long as possible */
2774 return (nl - b->ptr);
2780 b->ptr++; /* say we have read it as far as flush() is concerned */
2781 b->buf++; /* Leave space an front of buffer */
2782 b->bufsiz--; /* Buffer is thus smaller */
2783 code = PerlIO_fill(f); /* Fetch some more */
2784 b->bufsiz++; /* Restore size for next time */
2785 b->buf--; /* Point at space */
2786 b->ptr = nl = b->buf; /* Which is what we hand off */
2787 b->posn--; /* Buffer starts here */
2788 *nl = 0xd; /* Fill in the CR */
2790 goto test; /* fill() call worked */
2791 /* CR at EOF - just fall through */
2796 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2802 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2804 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2805 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2806 IV flags = PerlIOBase(f)->flags;
2816 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2823 /* Test code - delete when it works ... */
2830 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2838 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2839 ptr, chk, flags, c->nl, b->end, cnt);
2846 /* They have taken what we lied about */
2853 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2857 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2859 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2860 return PerlIOBuf_write(f,vbuf,count);
2863 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2864 const STDCHAR *buf = (const STDCHAR *) vbuf;
2865 const STDCHAR *ebuf = buf+count;
2868 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2872 STDCHAR *eptr = b->buf+b->bufsiz;
2873 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2874 while (buf < ebuf && b->ptr < eptr)
2878 if ((b->ptr + 2) > eptr)
2880 /* Not room for both */
2886 *(b->ptr)++ = 0xd; /* CR */
2887 *(b->ptr)++ = 0xa; /* LF */
2889 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2908 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2910 return (buf - (STDCHAR *) vbuf);
2915 PerlIOCrlf_flush(PerlIO *f)
2917 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2923 return PerlIOBuf_flush(f);
2926 PerlIO_funcs PerlIO_crlf = {
2929 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2935 PerlIOBase_noop_ok, /* popped */
2936 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2937 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2938 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2946 PerlIOBase_clearerr,
2947 PerlIOBuf_setlinebuf,
2952 PerlIOCrlf_set_ptrcnt,
2956 /*--------------------------------------------------------------------------------------*/
2957 /* mmap as "buffer" layer */
2961 PerlIOBuf base; /* PerlIOBuf stuff */
2962 Mmap_t mptr; /* Mapped address */
2963 Size_t len; /* mapped length */
2964 STDCHAR *bbuf; /* malloced buffer if map fails */
2967 static size_t page_size = 0;
2970 PerlIOMmap_map(PerlIO *f)
2973 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2974 PerlIOBuf *b = &m->base;
2975 IV flags = PerlIOBase(f)->flags;
2979 if (flags & PERLIO_F_CANREAD)
2981 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2982 int fd = PerlIO_fileno(f);
2984 code = fstat(fd,&st);
2985 if (code == 0 && S_ISREG(st.st_mode))
2987 SSize_t len = st.st_size - b->posn;
2992 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2994 SETERRNO(0,SS$_NORMAL);
2995 # ifdef _SC_PAGESIZE
2996 page_size = sysconf(_SC_PAGESIZE);
2998 page_size = sysconf(_SC_PAGE_SIZE);
3000 if ((long)page_size < 0) {
3005 (void)SvUPGRADE(error, SVt_PV);
3006 msg = SvPVx(error, n_a);
3007 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3010 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3014 # ifdef HAS_GETPAGESIZE
3015 page_size = getpagesize();
3017 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3018 page_size = PAGESIZE; /* compiletime, bad */
3022 if ((IV)page_size <= 0)
3023 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3027 /* This is a hack - should never happen - open should have set it ! */
3028 b->posn = PerlIO_tell(PerlIONext(f));
3030 posn = (b->posn / page_size) * page_size;
3031 len = st.st_size - posn;
3032 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3033 if (m->mptr && m->mptr != (Mmap_t) -1)
3035 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3036 madvise(m->mptr, len, MADV_SEQUENTIAL);
3038 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3039 madvise(m->mptr, len, MADV_WILLNEED);
3041 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3042 b->end = ((STDCHAR *)m->mptr) + len;
3043 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3054 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3056 b->ptr = b->end = b->ptr;
3065 PerlIOMmap_unmap(PerlIO *f)
3067 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3068 PerlIOBuf *b = &m->base;
3074 code = munmap(m->mptr, m->len);
3078 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3081 b->ptr = b->end = b->buf;
3082 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3088 PerlIOMmap_get_base(PerlIO *f)
3090 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3091 PerlIOBuf *b = &m->base;
3092 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3094 /* Already have a readbuffer in progress */
3099 /* We have a write buffer or flushed PerlIOBuf read buffer */
3100 m->bbuf = b->buf; /* save it in case we need it again */
3101 b->buf = NULL; /* Clear to trigger below */
3105 PerlIOMmap_map(f); /* Try and map it */
3108 /* Map did not work - recover PerlIOBuf buffer if we have one */
3112 b->ptr = b->end = b->buf;
3115 return PerlIOBuf_get_base(f);
3119 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3121 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3122 PerlIOBuf *b = &m->base;
3123 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3125 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3128 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3133 /* Loose the unwritable mapped buffer */
3135 /* If flush took the "buffer" see if we have one from before */
3136 if (!b->buf && m->bbuf)
3140 PerlIOBuf_get_base(f);
3144 return PerlIOBuf_unread(f,vbuf,count);
3148 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3150 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3151 PerlIOBuf *b = &m->base;
3152 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3154 /* No, or wrong sort of, buffer */
3157 if (PerlIOMmap_unmap(f) != 0)
3160 /* If unmap took the "buffer" see if we have one from before */
3161 if (!b->buf && m->bbuf)
3165 PerlIOBuf_get_base(f);
3169 return PerlIOBuf_write(f,vbuf,count);
3173 PerlIOMmap_flush(PerlIO *f)
3175 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3176 PerlIOBuf *b = &m->base;
3177 IV code = PerlIOBuf_flush(f);
3178 /* Now we are "synced" at PerlIOBuf level */
3183 /* Unmap the buffer */
3184 if (PerlIOMmap_unmap(f) != 0)
3189 /* We seem to have a PerlIOBuf buffer which was not mapped
3190 * remember it in case we need one later
3199 PerlIOMmap_fill(PerlIO *f)
3201 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3202 IV code = PerlIO_flush(f);
3203 if (code == 0 && !b->buf)
3205 code = PerlIOMmap_map(f);
3207 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3209 code = PerlIOBuf_fill(f);
3215 PerlIOMmap_close(PerlIO *f)
3217 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3218 PerlIOBuf *b = &m->base;
3219 IV code = PerlIO_flush(f);
3224 b->ptr = b->end = b->buf;
3226 if (PerlIOBuf_close(f) != 0)
3232 PerlIO_funcs PerlIO_mmap = {
3252 PerlIOBase_clearerr,
3253 PerlIOBuf_setlinebuf,
3254 PerlIOMmap_get_base,
3258 PerlIOBuf_set_ptrcnt,
3261 #endif /* HAS_MMAP */
3269 atexit(&PerlIO_cleanup);
3281 PerlIO_stdstreams();
3285 #undef PerlIO_stdout
3290 PerlIO_stdstreams();
3294 #undef PerlIO_stderr
3299 PerlIO_stdstreams();
3303 /*--------------------------------------------------------------------------------------*/
3305 #undef PerlIO_getname
3307 PerlIO_getname(PerlIO *f, char *buf)
3310 Perl_croak(aTHX_ "Don't know how to get file name");
3315 /*--------------------------------------------------------------------------------------*/
3316 /* Functions which can be called on any kind of PerlIO implemented
3322 PerlIO_getc(PerlIO *f)
3325 SSize_t count = PerlIO_read(f,buf,1);
3328 return (unsigned char) buf[0];
3333 #undef PerlIO_ungetc
3335 PerlIO_ungetc(PerlIO *f, int ch)
3340 if (PerlIO_unread(f,&buf,1) == 1)
3348 PerlIO_putc(PerlIO *f, int ch)
3351 return PerlIO_write(f,&buf,1);
3356 PerlIO_puts(PerlIO *f, const char *s)
3358 STRLEN len = strlen(s);
3359 return PerlIO_write(f,s,len);
3362 #undef PerlIO_rewind
3364 PerlIO_rewind(PerlIO *f)
3366 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3370 #undef PerlIO_vprintf
3372 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3375 SV *sv = newSVpvn("",0);
3381 Perl_va_copy(ap, apc);
3382 sv_vcatpvf(sv, fmt, &apc);
3384 sv_vcatpvf(sv, fmt, &ap);
3387 wrote = PerlIO_write(f,s,len);
3392 #undef PerlIO_printf
3394 PerlIO_printf(PerlIO *f,const char *fmt,...)
3399 result = PerlIO_vprintf(f,fmt,ap);
3404 #undef PerlIO_stdoutf
3406 PerlIO_stdoutf(const char *fmt,...)
3411 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3416 #undef PerlIO_tmpfile
3418 PerlIO_tmpfile(void)
3420 /* I have no idea how portable mkstemp() is ... */
3421 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3424 FILE *stdio = PerlSIO_tmpfile();
3427 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3433 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3434 int fd = mkstemp(SvPVX(sv));
3438 f = PerlIO_fdopen(fd,"w+");
3441 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3443 PerlLIO_unlink(SvPVX(sv));
3453 #endif /* USE_SFIO */
3454 #endif /* PERLIO_IS_STDIO */
3456 /*======================================================================================*/
3457 /* Now some functions in terms of above which may be needed even if
3458 we are not in true PerlIO mode
3462 #undef PerlIO_setpos
3464 PerlIO_setpos(PerlIO *f, SV *pos)
3470 Off_t *posn = (Off_t *) SvPV(pos,len);
3471 if (f && len == sizeof(Off_t))
3472 return PerlIO_seek(f,*posn,SEEK_SET);
3478 #undef PerlIO_setpos
3480 PerlIO_setpos(PerlIO *f, SV *pos)
3486 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3487 if (f && len == sizeof(Fpos_t))
3489 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3490 return fsetpos64(f, fpos);
3492 return fsetpos(f, fpos);
3502 #undef PerlIO_getpos
3504 PerlIO_getpos(PerlIO *f, SV *pos)
3507 Off_t posn = PerlIO_tell(f);
3508 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3509 return (posn == (Off_t)-1) ? -1 : 0;
3512 #undef PerlIO_getpos
3514 PerlIO_getpos(PerlIO *f, SV *pos)
3519 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3520 code = fgetpos64(f, &fpos);
3522 code = fgetpos(f, &fpos);
3524 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3529 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3532 vprintf(char *pat, char *args)
3534 _doprnt(pat, args, stdout);
3535 return 0; /* wrong, but perl doesn't use the return value */
3539 vfprintf(FILE *fd, char *pat, char *args)
3541 _doprnt(pat, args, fd);
3542 return 0; /* wrong, but perl doesn't use the return value */
3547 #ifndef PerlIO_vsprintf
3549 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3551 int val = vsprintf(s, fmt, ap);
3554 if (strlen(s) >= (STRLEN)n)
3557 (void)PerlIO_puts(Perl_error_log,
3558 "panic: sprintf overflow - memory corrupted!\n");
3566 #ifndef PerlIO_sprintf
3568 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3573 result = PerlIO_vsprintf(s, n, fmt, ap);