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 int fd = PerlIO_fileno(f);
2084 if (fd >= 0 && PerlLIO_isatty(fd))
2086 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2088 posn = PerlIO_tell(PerlIONext(f));
2089 if (posn != (Off_t) -1)
2093 return PerlIOBase_pushed(f,mode,arg,len);
2097 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
2100 PerlIO_funcs *tab = PerlIO_default_btm();
2108 #if O_BINARY != O_TEXT
2109 /* do something about failing setmode()? --jhi */
2110 PerlLIO_setmode(fd, O_BINARY);
2112 f = (*tab->Fdopen)(tab,fd,mode);
2115 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
2116 if (init && fd == 2)
2118 /* Initial stderr is unbuffered */
2119 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2122 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
2123 self->name,f,fd,mode,PerlIOBase(f)->flags);
2130 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
2132 PerlIO_funcs *tab = PerlIO_default_btm();
2133 PerlIO *f = (*tab->Open)(tab,path,mode);
2136 PerlIO_push(f,self,mode,Nullch,0);
2142 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
2144 PerlIO *next = PerlIONext(f);
2145 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
2147 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
2151 /* This "flush" is akin to sfio's sync in that it handles files in either
2155 PerlIOBuf_flush(PerlIO *f)
2157 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2159 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2161 /* write() the buffer */
2162 STDCHAR *buf = b->buf;
2164 PerlIO *n = PerlIONext(f);
2167 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2172 else if (count < 0 || PerlIO_error(n))
2174 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2179 b->posn += (p - buf);
2181 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2183 STDCHAR *buf = PerlIO_get_base(f);
2184 /* Note position change */
2185 b->posn += (b->ptr - buf);
2186 if (b->ptr < b->end)
2188 /* We did not consume all of it */
2189 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2191 b->posn = PerlIO_tell(PerlIONext(f));
2195 b->ptr = b->end = b->buf;
2196 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2197 /* FIXME: Is this right for read case ? */
2198 if (PerlIO_flush(PerlIONext(f)) != 0)
2204 PerlIOBuf_fill(PerlIO *f)
2206 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2207 PerlIO *n = PerlIONext(f);
2209 /* FIXME: doing the down-stream flush is a bad idea if it causes
2210 pre-read data in stdio buffer to be discarded
2211 but this is too simplistic - as it skips _our_ hosekeeping
2212 and breaks tell tests.
2213 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2217 if (PerlIO_flush(f) != 0)
2221 PerlIO_get_base(f); /* allocate via vtable */
2223 b->ptr = b->end = b->buf;
2224 if (PerlIO_fast_gets(n))
2226 /* Layer below is also buffered
2227 * We do _NOT_ want to call its ->Read() because that will loop
2228 * till it gets what we asked for which may hang on a pipe etc.
2229 * Instead take anything it has to hand, or ask it to fill _once_.
2231 avail = PerlIO_get_cnt(n);
2234 avail = PerlIO_fill(n);
2236 avail = PerlIO_get_cnt(n);
2239 if (!PerlIO_error(n) && PerlIO_eof(n))
2245 STDCHAR *ptr = PerlIO_get_ptr(n);
2246 SSize_t cnt = avail;
2247 if (avail > b->bufsiz)
2249 Copy(ptr,b->buf,avail,STDCHAR);
2250 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2255 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2260 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2262 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2265 b->end = b->buf+avail;
2266 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2271 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2273 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2274 STDCHAR *buf = (STDCHAR *) vbuf;
2279 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2283 SSize_t avail = PerlIO_get_cnt(f);
2284 SSize_t take = (count < avail) ? count : avail;
2287 STDCHAR *ptr = PerlIO_get_ptr(f);
2288 Copy(ptr,buf,take,STDCHAR);
2289 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2293 if (count > 0 && avail <= 0)
2295 if (PerlIO_fill(f) != 0)
2299 return (buf - (STDCHAR *) vbuf);
2305 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2307 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2308 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2311 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2317 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2319 avail = (b->ptr - b->buf);
2324 b->end = b->buf + avail;
2326 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2327 b->posn -= b->bufsiz;
2329 if (avail > (SSize_t) count)
2337 Copy(buf,b->ptr,avail,STDCHAR);
2341 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2348 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2350 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2351 const STDCHAR *buf = (const STDCHAR *) vbuf;
2355 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2359 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2360 if ((SSize_t) count < avail)
2362 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2363 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2383 Copy(buf,b->ptr,avail,STDCHAR);
2390 if (b->ptr >= (b->buf + b->bufsiz))
2393 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2399 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2402 if ((code = PerlIO_flush(f)) == 0)
2404 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2405 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2406 code = PerlIO_seek(PerlIONext(f),offset,whence);
2409 b->posn = PerlIO_tell(PerlIONext(f));
2416 PerlIOBuf_tell(PerlIO *f)
2418 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2419 Off_t posn = b->posn;
2421 posn += (b->ptr - b->buf);
2426 PerlIOBuf_close(PerlIO *f)
2429 IV code = PerlIOBase_close(f);
2430 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2431 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2433 PerlMemShared_free(b->buf);
2436 b->ptr = b->end = b->buf;
2437 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2442 PerlIOBuf_setlinebuf(PerlIO *f)
2446 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2451 PerlIOBuf_get_ptr(PerlIO *f)
2453 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2460 PerlIOBuf_get_cnt(PerlIO *f)
2462 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2465 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2466 return (b->end - b->ptr);
2471 PerlIOBuf_get_base(PerlIO *f)
2473 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2479 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2482 b->buf = (STDCHAR *)&b->oneword;
2483 b->bufsiz = sizeof(b->oneword);
2492 PerlIOBuf_bufsiz(PerlIO *f)
2494 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2497 return (b->end - b->buf);
2501 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2503 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2507 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2510 assert(PerlIO_get_cnt(f) == cnt);
2511 assert(b->ptr >= b->buf);
2513 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2516 PerlIO_funcs PerlIO_perlio = {
2536 PerlIOBase_clearerr,
2537 PerlIOBuf_setlinebuf,
2542 PerlIOBuf_set_ptrcnt,
2545 /*--------------------------------------------------------------------------------------*/
2546 /* Temp layer to hold unread chars when cannot do it any other way */
2549 PerlIOPending_fill(PerlIO *f)
2551 /* Should never happen */
2557 PerlIOPending_close(PerlIO *f)
2559 /* A tad tricky - flush pops us, then we close new top */
2561 return PerlIO_close(f);
2565 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2567 /* A tad tricky - flush pops us, then we seek new top */
2569 return PerlIO_seek(f,offset,whence);
2574 PerlIOPending_flush(PerlIO *f)
2576 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2577 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2580 PerlMemShared_free(b->buf);
2588 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2596 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2601 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2603 IV code = PerlIOBase_pushed(f,mode,arg,len);
2604 PerlIOl *l = PerlIOBase(f);
2605 /* Our PerlIO_fast_gets must match what we are pushed on,
2606 or sv_gets() etc. get muddled when it changes mid-string
2609 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2610 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2615 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2617 SSize_t avail = PerlIO_get_cnt(f);
2622 got = PerlIOBuf_read(f,vbuf,avail);
2623 if (got >= 0 && got < count)
2625 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2626 if (more >= 0 || got == 0)
2633 PerlIO_funcs PerlIO_pending = {
2641 PerlIOPending_pushed,
2648 PerlIOPending_close,
2649 PerlIOPending_flush,
2653 PerlIOBase_clearerr,
2654 PerlIOBuf_setlinebuf,
2659 PerlIOPending_set_ptrcnt,
2664 /*--------------------------------------------------------------------------------------*/
2665 /* crlf - translation
2666 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2667 to hand back a line at a time and keeping a record of which nl we "lied" about.
2668 On write translate "\n" to CR,LF
2673 PerlIOBuf base; /* PerlIOBuf stuff */
2674 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2678 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2681 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2682 code = PerlIOBuf_pushed(f,mode,arg,len);
2684 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2685 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2686 PerlIOBase(f)->flags);
2693 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2695 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2701 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2702 return PerlIOBuf_unread(f,vbuf,count);
2705 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2706 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2708 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2714 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2716 b->end = b->ptr = b->buf + b->bufsiz;
2717 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2718 b->posn -= b->bufsiz;
2720 while (count > 0 && b->ptr > b->buf)
2725 if (b->ptr - 2 >= b->buf)
2751 PerlIOCrlf_get_cnt(PerlIO *f)
2753 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2756 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2758 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2759 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2761 STDCHAR *nl = b->ptr;
2763 while (nl < b->end && *nl != 0xd)
2765 if (nl < b->end && *nl == 0xd)
2777 /* Not CR,LF but just CR */
2784 /* Blast - found CR as last char in buffer */
2787 /* They may not care, defer work as long as possible */
2788 return (nl - b->ptr);
2794 b->ptr++; /* say we have read it as far as flush() is concerned */
2795 b->buf++; /* Leave space an front of buffer */
2796 b->bufsiz--; /* Buffer is thus smaller */
2797 code = PerlIO_fill(f); /* Fetch some more */
2798 b->bufsiz++; /* Restore size for next time */
2799 b->buf--; /* Point at space */
2800 b->ptr = nl = b->buf; /* Which is what we hand off */
2801 b->posn--; /* Buffer starts here */
2802 *nl = 0xd; /* Fill in the CR */
2804 goto test; /* fill() call worked */
2805 /* CR at EOF - just fall through */
2810 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2816 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2818 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2819 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2820 IV flags = PerlIOBase(f)->flags;
2830 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2837 /* Test code - delete when it works ... */
2844 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2852 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2853 ptr, chk, flags, c->nl, b->end, cnt);
2860 /* They have taken what we lied about */
2867 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2871 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2873 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2874 return PerlIOBuf_write(f,vbuf,count);
2877 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2878 const STDCHAR *buf = (const STDCHAR *) vbuf;
2879 const STDCHAR *ebuf = buf+count;
2882 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2886 STDCHAR *eptr = b->buf+b->bufsiz;
2887 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2888 while (buf < ebuf && b->ptr < eptr)
2892 if ((b->ptr + 2) > eptr)
2894 /* Not room for both */
2900 *(b->ptr)++ = 0xd; /* CR */
2901 *(b->ptr)++ = 0xa; /* LF */
2903 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2922 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2924 return (buf - (STDCHAR *) vbuf);
2929 PerlIOCrlf_flush(PerlIO *f)
2931 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2937 return PerlIOBuf_flush(f);
2940 PerlIO_funcs PerlIO_crlf = {
2943 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2949 PerlIOBase_noop_ok, /* popped */
2950 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2951 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2952 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2960 PerlIOBase_clearerr,
2961 PerlIOBuf_setlinebuf,
2966 PerlIOCrlf_set_ptrcnt,
2970 /*--------------------------------------------------------------------------------------*/
2971 /* mmap as "buffer" layer */
2975 PerlIOBuf base; /* PerlIOBuf stuff */
2976 Mmap_t mptr; /* Mapped address */
2977 Size_t len; /* mapped length */
2978 STDCHAR *bbuf; /* malloced buffer if map fails */
2981 static size_t page_size = 0;
2984 PerlIOMmap_map(PerlIO *f)
2987 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2988 PerlIOBuf *b = &m->base;
2989 IV flags = PerlIOBase(f)->flags;
2993 if (flags & PERLIO_F_CANREAD)
2995 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2996 int fd = PerlIO_fileno(f);
2998 code = fstat(fd,&st);
2999 if (code == 0 && S_ISREG(st.st_mode))
3001 SSize_t len = st.st_size - b->posn;
3006 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3008 SETERRNO(0,SS$_NORMAL);
3009 # ifdef _SC_PAGESIZE
3010 page_size = sysconf(_SC_PAGESIZE);
3012 page_size = sysconf(_SC_PAGE_SIZE);
3014 if ((long)page_size < 0) {
3019 (void)SvUPGRADE(error, SVt_PV);
3020 msg = SvPVx(error, n_a);
3021 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
3024 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
3028 # ifdef HAS_GETPAGESIZE
3029 page_size = getpagesize();
3031 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3032 page_size = PAGESIZE; /* compiletime, bad */
3036 if ((IV)page_size <= 0)
3037 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3041 /* This is a hack - should never happen - open should have set it ! */
3042 b->posn = PerlIO_tell(PerlIONext(f));
3044 posn = (b->posn / page_size) * page_size;
3045 len = st.st_size - posn;
3046 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3047 if (m->mptr && m->mptr != (Mmap_t) -1)
3049 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3050 madvise(m->mptr, len, MADV_SEQUENTIAL);
3052 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3053 madvise(m->mptr, len, MADV_WILLNEED);
3055 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3056 b->end = ((STDCHAR *)m->mptr) + len;
3057 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3068 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3070 b->ptr = b->end = b->ptr;
3079 PerlIOMmap_unmap(PerlIO *f)
3081 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3082 PerlIOBuf *b = &m->base;
3088 code = munmap(m->mptr, m->len);
3092 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3095 b->ptr = b->end = b->buf;
3096 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3102 PerlIOMmap_get_base(PerlIO *f)
3104 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3105 PerlIOBuf *b = &m->base;
3106 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3108 /* Already have a readbuffer in progress */
3113 /* We have a write buffer or flushed PerlIOBuf read buffer */
3114 m->bbuf = b->buf; /* save it in case we need it again */
3115 b->buf = NULL; /* Clear to trigger below */
3119 PerlIOMmap_map(f); /* Try and map it */
3122 /* Map did not work - recover PerlIOBuf buffer if we have one */
3126 b->ptr = b->end = b->buf;
3129 return PerlIOBuf_get_base(f);
3133 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3135 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3136 PerlIOBuf *b = &m->base;
3137 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3139 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3142 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3147 /* Loose the unwritable mapped buffer */
3149 /* If flush took the "buffer" see if we have one from before */
3150 if (!b->buf && m->bbuf)
3154 PerlIOBuf_get_base(f);
3158 return PerlIOBuf_unread(f,vbuf,count);
3162 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3164 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3165 PerlIOBuf *b = &m->base;
3166 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3168 /* No, or wrong sort of, buffer */
3171 if (PerlIOMmap_unmap(f) != 0)
3174 /* If unmap took the "buffer" see if we have one from before */
3175 if (!b->buf && m->bbuf)
3179 PerlIOBuf_get_base(f);
3183 return PerlIOBuf_write(f,vbuf,count);
3187 PerlIOMmap_flush(PerlIO *f)
3189 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3190 PerlIOBuf *b = &m->base;
3191 IV code = PerlIOBuf_flush(f);
3192 /* Now we are "synced" at PerlIOBuf level */
3197 /* Unmap the buffer */
3198 if (PerlIOMmap_unmap(f) != 0)
3203 /* We seem to have a PerlIOBuf buffer which was not mapped
3204 * remember it in case we need one later
3213 PerlIOMmap_fill(PerlIO *f)
3215 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3216 IV code = PerlIO_flush(f);
3217 if (code == 0 && !b->buf)
3219 code = PerlIOMmap_map(f);
3221 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3223 code = PerlIOBuf_fill(f);
3229 PerlIOMmap_close(PerlIO *f)
3231 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3232 PerlIOBuf *b = &m->base;
3233 IV code = PerlIO_flush(f);
3238 b->ptr = b->end = b->buf;
3240 if (PerlIOBuf_close(f) != 0)
3246 PerlIO_funcs PerlIO_mmap = {
3266 PerlIOBase_clearerr,
3267 PerlIOBuf_setlinebuf,
3268 PerlIOMmap_get_base,
3272 PerlIOBuf_set_ptrcnt,
3275 #endif /* HAS_MMAP */
3283 atexit(&PerlIO_cleanup);
3295 PerlIO_stdstreams();
3299 #undef PerlIO_stdout
3304 PerlIO_stdstreams();
3308 #undef PerlIO_stderr
3313 PerlIO_stdstreams();
3317 /*--------------------------------------------------------------------------------------*/
3319 #undef PerlIO_getname
3321 PerlIO_getname(PerlIO *f, char *buf)
3324 Perl_croak(aTHX_ "Don't know how to get file name");
3329 /*--------------------------------------------------------------------------------------*/
3330 /* Functions which can be called on any kind of PerlIO implemented
3336 PerlIO_getc(PerlIO *f)
3339 SSize_t count = PerlIO_read(f,buf,1);
3342 return (unsigned char) buf[0];
3347 #undef PerlIO_ungetc
3349 PerlIO_ungetc(PerlIO *f, int ch)
3354 if (PerlIO_unread(f,&buf,1) == 1)
3362 PerlIO_putc(PerlIO *f, int ch)
3365 return PerlIO_write(f,&buf,1);
3370 PerlIO_puts(PerlIO *f, const char *s)
3372 STRLEN len = strlen(s);
3373 return PerlIO_write(f,s,len);
3376 #undef PerlIO_rewind
3378 PerlIO_rewind(PerlIO *f)
3380 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3384 #undef PerlIO_vprintf
3386 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3389 SV *sv = newSVpvn("",0);
3395 Perl_va_copy(ap, apc);
3396 sv_vcatpvf(sv, fmt, &apc);
3398 sv_vcatpvf(sv, fmt, &ap);
3401 wrote = PerlIO_write(f,s,len);
3406 #undef PerlIO_printf
3408 PerlIO_printf(PerlIO *f,const char *fmt,...)
3413 result = PerlIO_vprintf(f,fmt,ap);
3418 #undef PerlIO_stdoutf
3420 PerlIO_stdoutf(const char *fmt,...)
3425 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3430 #undef PerlIO_tmpfile
3432 PerlIO_tmpfile(void)
3434 /* I have no idea how portable mkstemp() is ... */
3435 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3438 FILE *stdio = PerlSIO_tmpfile();
3441 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3447 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3448 int fd = mkstemp(SvPVX(sv));
3452 f = PerlIO_fdopen(fd,"w+");
3455 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3457 PerlLIO_unlink(SvPVX(sv));
3467 #endif /* USE_SFIO */
3468 #endif /* PERLIO_IS_STDIO */
3470 /*======================================================================================*/
3471 /* Now some functions in terms of above which may be needed even if
3472 we are not in true PerlIO mode
3476 #undef PerlIO_setpos
3478 PerlIO_setpos(PerlIO *f, SV *pos)
3484 Off_t *posn = (Off_t *) SvPV(pos,len);
3485 if (f && len == sizeof(Off_t))
3486 return PerlIO_seek(f,*posn,SEEK_SET);
3492 #undef PerlIO_setpos
3494 PerlIO_setpos(PerlIO *f, SV *pos)
3500 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3501 if (f && len == sizeof(Fpos_t))
3503 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3504 return fsetpos64(f, fpos);
3506 return fsetpos(f, fpos);
3516 #undef PerlIO_getpos
3518 PerlIO_getpos(PerlIO *f, SV *pos)
3521 Off_t posn = PerlIO_tell(f);
3522 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3523 return (posn == (Off_t)-1) ? -1 : 0;
3526 #undef PerlIO_getpos
3528 PerlIO_getpos(PerlIO *f, SV *pos)
3533 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3534 code = fgetpos64(f, &fpos);
3536 code = fgetpos(f, &fpos);
3538 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3543 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3546 vprintf(char *pat, char *args)
3548 _doprnt(pat, args, stdout);
3549 return 0; /* wrong, but perl doesn't use the return value */
3553 vfprintf(FILE *fd, char *pat, char *args)
3555 _doprnt(pat, args, fd);
3556 return 0; /* wrong, but perl doesn't use the return value */
3561 #ifndef PerlIO_vsprintf
3563 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3565 int val = vsprintf(s, fmt, ap);
3568 if (strlen(s) >= (STRLEN)n)
3571 (void)PerlIO_puts(Perl_error_log,
3572 "panic: sprintf overflow - memory corrupted!\n");
3580 #ifndef PerlIO_sprintf
3582 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3587 result = PerlIO_vsprintf(s, n, fmt, ap);