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\n",f,tab->name,(mode) ? mode : "(Null)");
557 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
567 PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
580 PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
582 /* Remove the dummy layer */
584 /* Pop back to bottom layer */
589 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
597 /* Nothing bellow - push unix on top then remove it */
598 if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len))
600 PerlIO_pop(PerlIONext(f));
605 PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
612 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
616 const char *s = names;
619 while (isSPACE(*s) || *s == ':')
624 const char *as = Nullch;
625 const char *ae = Nullch;
627 while (*e && *e != ':' && !isSPACE(*e))
637 if (as && --count == 0)
644 if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
646 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
648 else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
650 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
654 STRLEN len = ((as) ? as : e)-s;
655 SV *layer = PerlIO_find_layer(s,len);
658 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
661 if (as && (ae == Nullch)) {
663 Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
665 len = (as) ? (ae-(as++)-1) : 0;
666 if (!PerlIO_push(f,tab,mode,as,len))
671 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
683 /*--------------------------------------------------------------------------------------*/
684 /* Given the abstraction above the public API functions */
687 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
689 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
690 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
691 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
697 if (PerlIOBase(top)->tab == &PerlIO_crlf)
700 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
703 top = PerlIONext(top);
706 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
711 PerlIO__close(PerlIO *f)
713 return (*PerlIOBase(f)->tab->Close)(f);
716 #undef PerlIO_fdupopen
718 PerlIO_fdupopen(pTHX_ PerlIO *f)
721 int fd = PerlLIO_dup(PerlIO_fileno(f));
722 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
725 Off_t posn = PerlIO_tell(f);
726 PerlIO_seek(new,posn,SEEK_SET);
733 PerlIO_close(PerlIO *f)
735 int code = (*PerlIOBase(f)->tab->Close)(f);
745 PerlIO_fileno(PerlIO *f)
747 return (*PerlIOBase(f)->tab->Fileno)(f);
754 PerlIO_fdopen(int fd, const char *mode)
756 PerlIO_funcs *tab = PerlIO_default_top();
759 return (*tab->Fdopen)(tab,fd,mode);
764 PerlIO_open(const char *path, const char *mode)
766 PerlIO_funcs *tab = PerlIO_default_top();
769 return (*tab->Open)(tab,path,mode);
774 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
779 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
781 if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
787 return PerlIO_open(path,mode);
792 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
794 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
799 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
801 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
806 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
808 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
813 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
815 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
820 PerlIO_tell(PerlIO *f)
822 return (*PerlIOBase(f)->tab->Tell)(f);
827 PerlIO_flush(PerlIO *f)
831 PerlIO_funcs *tab = PerlIOBase(f)->tab;
832 if (tab && tab->Flush)
834 return (*tab->Flush)(f);
838 PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
845 PerlIO **table = &_perlio;
850 table = (PerlIO **)(f++);
851 for (i=1; i < PERLIO_TABLE_SIZE; i++)
853 if (*f && PerlIO_flush(f) != 0)
864 PerlIO_fill(PerlIO *f)
866 return (*PerlIOBase(f)->tab->Fill)(f);
871 PerlIO_isutf8(PerlIO *f)
873 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
878 PerlIO_eof(PerlIO *f)
880 return (*PerlIOBase(f)->tab->Eof)(f);
885 PerlIO_error(PerlIO *f)
887 return (*PerlIOBase(f)->tab->Error)(f);
890 #undef PerlIO_clearerr
892 PerlIO_clearerr(PerlIO *f)
895 (*PerlIOBase(f)->tab->Clearerr)(f);
898 #undef PerlIO_setlinebuf
900 PerlIO_setlinebuf(PerlIO *f)
902 (*PerlIOBase(f)->tab->Setlinebuf)(f);
905 #undef PerlIO_has_base
907 PerlIO_has_base(PerlIO *f)
911 return (PerlIOBase(f)->tab->Get_base != NULL);
916 #undef PerlIO_fast_gets
918 PerlIO_fast_gets(PerlIO *f)
920 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
922 PerlIO_funcs *tab = PerlIOBase(f)->tab;
923 return (tab->Set_ptrcnt != NULL);
928 #undef PerlIO_has_cntptr
930 PerlIO_has_cntptr(PerlIO *f)
934 PerlIO_funcs *tab = PerlIOBase(f)->tab;
935 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
940 #undef PerlIO_canset_cnt
942 PerlIO_canset_cnt(PerlIO *f)
946 PerlIOl *l = PerlIOBase(f);
947 return (l->tab->Set_ptrcnt != NULL);
952 #undef PerlIO_get_base
954 PerlIO_get_base(PerlIO *f)
956 return (*PerlIOBase(f)->tab->Get_base)(f);
959 #undef PerlIO_get_bufsiz
961 PerlIO_get_bufsiz(PerlIO *f)
963 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
966 #undef PerlIO_get_ptr
968 PerlIO_get_ptr(PerlIO *f)
970 PerlIO_funcs *tab = PerlIOBase(f)->tab;
971 if (tab->Get_ptr == NULL)
973 return (*tab->Get_ptr)(f);
976 #undef PerlIO_get_cnt
978 PerlIO_get_cnt(PerlIO *f)
980 PerlIO_funcs *tab = PerlIOBase(f)->tab;
981 if (tab->Get_cnt == NULL)
983 return (*tab->Get_cnt)(f);
986 #undef PerlIO_set_cnt
988 PerlIO_set_cnt(PerlIO *f,int cnt)
990 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
993 #undef PerlIO_set_ptrcnt
995 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
997 PerlIO_funcs *tab = PerlIOBase(f)->tab;
998 if (tab->Set_ptrcnt == NULL)
1001 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1003 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
1006 /*--------------------------------------------------------------------------------------*/
1007 /* utf8 and raw dummy layers */
1010 PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1014 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1016 if (tab->kind & PERLIO_K_UTF8)
1017 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1019 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1026 PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1028 PerlIO_funcs *tab = PerlIO_default_layer(-2);
1029 PerlIO *f = (*tab->Fdopen)(tab,fd,mode);
1032 PerlIOl *l = PerlIOBase(f);
1033 if (tab->kind & PERLIO_K_UTF8)
1034 l->flags |= PERLIO_F_UTF8;
1036 l->flags &= ~PERLIO_F_UTF8;
1042 PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode)
1044 PerlIO_funcs *tab = PerlIO_default_layer(-2);
1045 PerlIO *f = (*tab->Open)(tab,path,mode);
1048 PerlIOl *l = PerlIOBase(f);
1049 if (tab->kind & PERLIO_K_UTF8)
1050 l->flags |= PERLIO_F_UTF8;
1052 l->flags &= ~PERLIO_F_UTF8;
1057 PerlIO_funcs PerlIO_utf8 = {
1060 PERLIO_K_DUMMY|PERLIO_F_UTF8,
1079 NULL, /* get_base */
1080 NULL, /* get_bufsiz */
1083 NULL, /* set_ptrcnt */
1086 PerlIO_funcs PerlIO_byte = {
1108 NULL, /* get_base */
1109 NULL, /* get_bufsiz */
1112 NULL, /* set_ptrcnt */
1116 PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1118 PerlIO_funcs *tab = PerlIO_default_btm();
1119 return (*tab->Fdopen)(tab,fd,mode);
1123 PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode)
1125 PerlIO_funcs *tab = PerlIO_default_btm();
1126 return (*tab->Open)(tab,path,mode);
1129 PerlIO_funcs PerlIO_raw = {
1151 NULL, /* get_base */
1152 NULL, /* get_bufsiz */
1155 NULL, /* set_ptrcnt */
1157 /*--------------------------------------------------------------------------------------*/
1158 /*--------------------------------------------------------------------------------------*/
1159 /* "Methods" of the "base class" */
1162 PerlIOBase_fileno(PerlIO *f)
1164 return PerlIO_fileno(PerlIONext(f));
1168 PerlIO_modestr(PerlIO *f,char *buf)
1171 IV flags = PerlIOBase(f)->flags;
1172 if (flags & PERLIO_F_APPEND)
1175 if (flags & PERLIO_F_CANREAD)
1180 else if (flags & PERLIO_F_CANREAD)
1183 if (flags & PERLIO_F_CANWRITE)
1186 else if (flags & PERLIO_F_CANWRITE)
1189 if (flags & PERLIO_F_CANREAD)
1194 #if O_TEXT != O_BINARY
1195 if (!(flags & PERLIO_F_CRLF))
1203 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1205 PerlIOl *l = PerlIOBase(f);
1206 const char *omode = mode;
1208 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1209 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1210 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1211 if (tab->Set_ptrcnt != NULL)
1212 l->flags |= PERLIO_F_FASTGETS;
1218 l->flags |= PERLIO_F_CANREAD;
1221 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1224 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1235 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1238 l->flags &= ~PERLIO_F_CRLF;
1241 l->flags |= PERLIO_F_CRLF;
1253 l->flags |= l->next->flags &
1254 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1258 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1259 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1260 l->flags,PerlIO_modestr(f,temp));
1266 PerlIOBase_popped(PerlIO *f)
1272 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1274 Off_t old = PerlIO_tell(f);
1276 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1277 done = PerlIOBuf_unread(f,vbuf,count);
1278 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1283 PerlIOBase_noop_ok(PerlIO *f)
1289 PerlIOBase_noop_fail(PerlIO *f)
1295 PerlIOBase_close(PerlIO *f)
1298 PerlIO *n = PerlIONext(f);
1299 if (PerlIO_flush(f) != 0)
1301 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1303 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1308 PerlIOBase_eof(PerlIO *f)
1312 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1318 PerlIOBase_error(PerlIO *f)
1322 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1328 PerlIOBase_clearerr(PerlIO *f)
1332 PerlIO *n = PerlIONext(f);
1333 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1340 PerlIOBase_setlinebuf(PerlIO *f)
1345 /*--------------------------------------------------------------------------------------*/
1346 /* Bottom-most level for UNIX-like case */
1350 struct _PerlIO base; /* The generic part */
1351 int fd; /* UNIX like file descriptor */
1352 int oflags; /* open/fcntl flags */
1356 PerlIOUnix_oflags(const char *mode)
1371 oflags = O_CREAT|O_TRUNC;
1382 oflags = O_CREAT|O_APPEND;
1398 else if (*mode == 't')
1401 oflags &= ~O_BINARY;
1404 /* Always open in binary mode */
1406 if (*mode || oflags == -1)
1415 PerlIOUnix_fileno(PerlIO *f)
1417 return PerlIOSelf(f,PerlIOUnix)->fd;
1421 PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1423 IV code = PerlIOBase_pushed(f,mode,arg,len);
1426 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1427 s->fd = PerlIO_fileno(PerlIONext(f));
1428 s->oflags = PerlIOUnix_oflags(mode);
1430 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1435 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1443 int oflags = PerlIOUnix_oflags(mode);
1446 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1455 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1459 int oflags = PerlIOUnix_oflags(mode);
1462 int fd = PerlLIO_open3(path,oflags,0666);
1465 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1468 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1475 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1477 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1478 int oflags = PerlIOUnix_oflags(mode);
1479 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1480 (*PerlIOBase(f)->tab->Close)(f);
1484 int fd = PerlLIO_open3(path,oflags,0666);
1489 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1497 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1500 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1501 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1505 SSize_t len = PerlLIO_read(fd,vbuf,count);
1506 if (len >= 0 || errno != EINTR)
1509 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1510 else if (len == 0 && count != 0)
1511 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1519 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1522 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1525 SSize_t len = PerlLIO_write(fd,vbuf,count);
1526 if (len >= 0 || errno != EINTR)
1529 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1537 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1540 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1541 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1542 return (new == (Off_t) -1) ? -1 : 0;
1546 PerlIOUnix_tell(PerlIO *f)
1549 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1550 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1554 PerlIOUnix_close(PerlIO *f)
1557 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1559 while (PerlLIO_close(fd) != 0)
1570 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1575 PerlIO_funcs PerlIO_unix = {
1591 PerlIOBase_noop_ok, /* flush */
1592 PerlIOBase_noop_fail, /* fill */
1595 PerlIOBase_clearerr,
1596 PerlIOBase_setlinebuf,
1597 NULL, /* get_base */
1598 NULL, /* get_bufsiz */
1601 NULL, /* set_ptrcnt */
1604 /*--------------------------------------------------------------------------------------*/
1605 /* stdio as a layer */
1609 struct _PerlIO base;
1610 FILE * stdio; /* The stream */
1614 PerlIOStdio_fileno(PerlIO *f)
1617 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1621 PerlIOStdio_mode(const char *mode,char *tmode)
1628 if (O_BINARY != O_TEXT)
1637 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1656 stdio = PerlSIO_stdin;
1659 stdio = PerlSIO_stdout;
1662 stdio = PerlSIO_stderr;
1668 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1672 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1679 /* This isn't used yet ... */
1681 PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1685 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1687 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
1693 return PerlIOBase_pushed(f,mode,arg,len);
1696 #undef PerlIO_importFILE
1698 PerlIO_importFILE(FILE *stdio, int fl)
1704 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1711 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1715 FILE *stdio = PerlSIO_fopen(path,mode);
1719 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1720 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1728 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1731 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1733 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1741 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1744 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1748 STDCHAR *buf = (STDCHAR *) vbuf;
1749 /* Perl is expecting PerlIO_getc() to fill the buffer
1750 * Linux's stdio does not do that for fread()
1752 int ch = PerlSIO_fgetc(s);
1760 got = PerlSIO_fread(vbuf,1,count,s);
1765 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1768 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1769 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1773 int ch = *buf-- & 0xff;
1774 if (PerlSIO_ungetc(ch,s) != ch)
1783 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1786 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1790 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1793 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1794 return PerlSIO_fseek(stdio,offset,whence);
1798 PerlIOStdio_tell(PerlIO *f)
1801 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1802 return PerlSIO_ftell(stdio);
1806 PerlIOStdio_close(PerlIO *f)
1810 int optval, optlen = sizeof(int);
1812 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1815 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1816 PerlSIO_fclose(stdio) :
1817 close(PerlIO_fileno(f))
1819 PerlSIO_fclose(stdio)
1826 PerlIOStdio_flush(PerlIO *f)
1829 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1830 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1832 return PerlSIO_fflush(stdio);
1837 /* FIXME: This discards ungetc() and pre-read stuff which is
1838 not right if this is just a "sync" from a layer above
1839 Suspect right design is to do _this_ but not have layer above
1840 flush this layer read-to-read
1842 /* Not writeable - sync by attempting a seek */
1844 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1852 PerlIOStdio_fill(PerlIO *f)
1855 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1857 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1858 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1860 if (PerlSIO_fflush(stdio) != 0)
1863 c = PerlSIO_fgetc(stdio);
1864 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1870 PerlIOStdio_eof(PerlIO *f)
1873 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1877 PerlIOStdio_error(PerlIO *f)
1880 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1884 PerlIOStdio_clearerr(PerlIO *f)
1887 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1891 PerlIOStdio_setlinebuf(PerlIO *f)
1894 #ifdef HAS_SETLINEBUF
1895 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1897 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1903 PerlIOStdio_get_base(PerlIO *f)
1906 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1907 return PerlSIO_get_base(stdio);
1911 PerlIOStdio_get_bufsiz(PerlIO *f)
1914 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1915 return PerlSIO_get_bufsiz(stdio);
1919 #ifdef USE_STDIO_PTR
1921 PerlIOStdio_get_ptr(PerlIO *f)
1924 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1925 return PerlSIO_get_ptr(stdio);
1929 PerlIOStdio_get_cnt(PerlIO *f)
1932 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1933 return PerlSIO_get_cnt(stdio);
1937 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1940 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1943 #ifdef STDIO_PTR_LVALUE
1944 PerlSIO_set_ptr(stdio,ptr);
1945 #ifdef STDIO_PTR_LVAL_SETS_CNT
1946 if (PerlSIO_get_cnt(stdio) != (cnt))
1949 assert(PerlSIO_get_cnt(stdio) == (cnt));
1952 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1953 /* Setting ptr _does_ change cnt - we are done */
1956 #else /* STDIO_PTR_LVALUE */
1958 #endif /* STDIO_PTR_LVALUE */
1960 /* Now (or only) set cnt */
1961 #ifdef STDIO_CNT_LVALUE
1962 PerlSIO_set_cnt(stdio,cnt);
1963 #else /* STDIO_CNT_LVALUE */
1964 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1965 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1966 #else /* STDIO_PTR_LVAL_SETS_CNT */
1968 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1969 #endif /* STDIO_CNT_LVALUE */
1974 PerlIO_funcs PerlIO_stdio = {
1976 sizeof(PerlIOStdio),
1994 PerlIOStdio_clearerr,
1995 PerlIOStdio_setlinebuf,
1997 PerlIOStdio_get_base,
1998 PerlIOStdio_get_bufsiz,
2003 #ifdef USE_STDIO_PTR
2004 PerlIOStdio_get_ptr,
2005 PerlIOStdio_get_cnt,
2006 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2007 PerlIOStdio_set_ptrcnt
2008 #else /* STDIO_PTR_LVALUE */
2010 #endif /* STDIO_PTR_LVALUE */
2011 #else /* USE_STDIO_PTR */
2015 #endif /* USE_STDIO_PTR */
2018 #undef PerlIO_exportFILE
2020 PerlIO_exportFILE(PerlIO *f, int fl)
2024 stdio = fdopen(PerlIO_fileno(f),"r+");
2027 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
2033 #undef PerlIO_findFILE
2035 PerlIO_findFILE(PerlIO *f)
2040 if (l->tab == &PerlIO_stdio)
2042 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2045 l = *PerlIONext(&l);
2047 return PerlIO_exportFILE(f,0);
2050 #undef PerlIO_releaseFILE
2052 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2056 /*--------------------------------------------------------------------------------------*/
2057 /* perlio buffer layer */
2060 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
2062 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2063 b->posn = PerlIO_tell(PerlIONext(f));
2064 return PerlIOBase_pushed(f,mode,arg,len);
2068 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
2071 PerlIO_funcs *tab = PerlIO_default_btm();
2079 #if O_BINARY != O_TEXT
2080 /* do something about failing setmode()? --jhi */
2081 PerlLIO_setmode(fd, O_BINARY);
2083 f = (*tab->Fdopen)(tab,fd,mode);
2086 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
2087 if (init && fd == 2)
2089 /* Initial stderr is unbuffered */
2090 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2093 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
2094 self->name,f,fd,mode,PerlIOBase(f)->flags);
2101 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
2103 PerlIO_funcs *tab = PerlIO_default_btm();
2104 PerlIO *f = (*tab->Open)(tab,path,mode);
2107 PerlIO_push(f,self,mode,Nullch,0);
2113 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
2115 PerlIO *next = PerlIONext(f);
2116 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
2118 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
2122 /* This "flush" is akin to sfio's sync in that it handles files in either
2126 PerlIOBuf_flush(PerlIO *f)
2128 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2130 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2132 /* write() the buffer */
2133 STDCHAR *buf = b->buf;
2135 PerlIO *n = PerlIONext(f);
2138 SSize_t count = PerlIO_write(n,p,b->ptr - p);
2143 else if (count < 0 || PerlIO_error(n))
2145 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2150 b->posn += (p - buf);
2152 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2154 STDCHAR *buf = PerlIO_get_base(f);
2155 /* Note position change */
2156 b->posn += (b->ptr - buf);
2157 if (b->ptr < b->end)
2159 /* We did not consume all of it */
2160 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2162 b->posn = PerlIO_tell(PerlIONext(f));
2166 b->ptr = b->end = b->buf;
2167 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2168 /* FIXME: Is this right for read case ? */
2169 if (PerlIO_flush(PerlIONext(f)) != 0)
2175 PerlIOBuf_fill(PerlIO *f)
2177 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2178 PerlIO *n = PerlIONext(f);
2180 /* FIXME: doing the down-stream flush is a bad idea if it causes
2181 pre-read data in stdio buffer to be discarded
2182 but this is too simplistic - as it skips _our_ hosekeeping
2183 and breaks tell tests.
2184 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2188 if (PerlIO_flush(f) != 0)
2192 PerlIO_get_base(f); /* allocate via vtable */
2194 b->ptr = b->end = b->buf;
2195 if (PerlIO_fast_gets(n))
2197 /* Layer below is also buffered
2198 * We do _NOT_ want to call its ->Read() because that will loop
2199 * till it gets what we asked for which may hang on a pipe etc.
2200 * Instead take anything it has to hand, or ask it to fill _once_.
2202 avail = PerlIO_get_cnt(n);
2205 avail = PerlIO_fill(n);
2207 avail = PerlIO_get_cnt(n);
2210 if (!PerlIO_error(n) && PerlIO_eof(n))
2216 STDCHAR *ptr = PerlIO_get_ptr(n);
2217 SSize_t cnt = avail;
2218 if (avail > b->bufsiz)
2220 Copy(ptr,b->buf,avail,STDCHAR);
2221 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2226 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2231 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2233 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2236 b->end = b->buf+avail;
2237 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2242 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2244 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2245 STDCHAR *buf = (STDCHAR *) vbuf;
2250 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2254 SSize_t avail = PerlIO_get_cnt(f);
2255 SSize_t take = (count < avail) ? count : avail;
2258 STDCHAR *ptr = PerlIO_get_ptr(f);
2259 Copy(ptr,buf,take,STDCHAR);
2260 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2264 if (count > 0 && avail <= 0)
2266 if (PerlIO_fill(f) != 0)
2270 return (buf - (STDCHAR *) vbuf);
2276 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2278 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2279 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2282 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2288 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2290 avail = (b->ptr - b->buf);
2295 b->end = b->buf + avail;
2297 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2298 b->posn -= b->bufsiz;
2300 if (avail > (SSize_t) count)
2308 Copy(buf,b->ptr,avail,STDCHAR);
2312 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2319 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2321 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2322 const STDCHAR *buf = (const STDCHAR *) vbuf;
2326 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2330 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2331 if ((SSize_t) count < avail)
2333 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2334 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2354 Copy(buf,b->ptr,avail,STDCHAR);
2361 if (b->ptr >= (b->buf + b->bufsiz))
2364 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2370 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2373 if ((code = PerlIO_flush(f)) == 0)
2375 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2376 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2377 code = PerlIO_seek(PerlIONext(f),offset,whence);
2380 b->posn = PerlIO_tell(PerlIONext(f));
2387 PerlIOBuf_tell(PerlIO *f)
2389 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2390 Off_t posn = b->posn;
2392 posn += (b->ptr - b->buf);
2397 PerlIOBuf_close(PerlIO *f)
2400 IV code = PerlIOBase_close(f);
2401 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2402 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2404 PerlMemShared_free(b->buf);
2407 b->ptr = b->end = b->buf;
2408 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2413 PerlIOBuf_setlinebuf(PerlIO *f)
2417 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2422 PerlIOBuf_get_ptr(PerlIO *f)
2424 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2431 PerlIOBuf_get_cnt(PerlIO *f)
2433 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2436 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2437 return (b->end - b->ptr);
2442 PerlIOBuf_get_base(PerlIO *f)
2444 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2450 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2453 b->buf = (STDCHAR *)&b->oneword;
2454 b->bufsiz = sizeof(b->oneword);
2463 PerlIOBuf_bufsiz(PerlIO *f)
2465 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2468 return (b->end - b->buf);
2472 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2474 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2478 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2481 assert(PerlIO_get_cnt(f) == cnt);
2482 assert(b->ptr >= b->buf);
2484 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2487 PerlIO_funcs PerlIO_perlio = {
2507 PerlIOBase_clearerr,
2508 PerlIOBuf_setlinebuf,
2513 PerlIOBuf_set_ptrcnt,
2516 /*--------------------------------------------------------------------------------------*/
2517 /* Temp layer to hold unread chars when cannot do it any other way */
2520 PerlIOPending_fill(PerlIO *f)
2522 /* Should never happen */
2528 PerlIOPending_close(PerlIO *f)
2530 /* A tad tricky - flush pops us, then we close new top */
2532 return PerlIO_close(f);
2536 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2538 /* A tad tricky - flush pops us, then we seek new top */
2540 return PerlIO_seek(f,offset,whence);
2545 PerlIOPending_flush(PerlIO *f)
2547 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2548 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2551 PerlMemShared_free(b->buf);
2559 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2567 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2572 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2574 IV code = PerlIOBase_pushed(f,mode,arg,len);
2575 PerlIOl *l = PerlIOBase(f);
2576 /* Our PerlIO_fast_gets must match what we are pushed on,
2577 or sv_gets() etc. get muddled when it changes mid-string
2580 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2581 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2586 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2588 SSize_t avail = PerlIO_get_cnt(f);
2593 got = PerlIOBuf_read(f,vbuf,avail);
2595 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2600 PerlIO_funcs PerlIO_pending = {
2608 PerlIOPending_pushed,
2615 PerlIOPending_close,
2616 PerlIOPending_flush,
2620 PerlIOBase_clearerr,
2621 PerlIOBuf_setlinebuf,
2626 PerlIOPending_set_ptrcnt,
2631 /*--------------------------------------------------------------------------------------*/
2632 /* crlf - translation
2633 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2634 to hand back a line at a time and keeping a record of which nl we "lied" about.
2635 On write translate "\n" to CR,LF
2640 PerlIOBuf base; /* PerlIOBuf stuff */
2641 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2645 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2648 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2649 code = PerlIOBuf_pushed(f,mode,arg,len);
2651 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2652 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2653 PerlIOBase(f)->flags);
2660 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2662 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2668 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2669 return PerlIOBuf_unread(f,vbuf,count);
2672 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2673 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2675 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2681 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2683 b->end = b->ptr = b->buf + b->bufsiz;
2684 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2685 b->posn -= b->bufsiz;
2687 while (count > 0 && b->ptr > b->buf)
2692 if (b->ptr - 2 >= b->buf)
2718 PerlIOCrlf_get_cnt(PerlIO *f)
2720 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2723 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2725 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2726 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2728 STDCHAR *nl = b->ptr;
2730 while (nl < b->end && *nl != 0xd)
2732 if (nl < b->end && *nl == 0xd)
2744 /* Not CR,LF but just CR */
2751 /* Blast - found CR as last char in buffer */
2754 /* They may not care, defer work as long as possible */
2755 return (nl - b->ptr);
2761 b->ptr++; /* say we have read it as far as flush() is concerned */
2762 b->buf++; /* Leave space an front of buffer */
2763 b->bufsiz--; /* Buffer is thus smaller */
2764 code = PerlIO_fill(f); /* Fetch some more */
2765 b->bufsiz++; /* Restore size for next time */
2766 b->buf--; /* Point at space */
2767 b->ptr = nl = b->buf; /* Which is what we hand off */
2768 b->posn--; /* Buffer starts here */
2769 *nl = 0xd; /* Fill in the CR */
2771 goto test; /* fill() call worked */
2772 /* CR at EOF - just fall through */
2777 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2783 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2785 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2786 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2787 IV flags = PerlIOBase(f)->flags;
2797 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2804 /* Test code - delete when it works ... */
2811 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2819 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2820 ptr, chk, flags, c->nl, b->end, cnt);
2827 /* They have taken what we lied about */
2834 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2838 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2840 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2841 return PerlIOBuf_write(f,vbuf,count);
2844 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2845 const STDCHAR *buf = (const STDCHAR *) vbuf;
2846 const STDCHAR *ebuf = buf+count;
2849 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2853 STDCHAR *eptr = b->buf+b->bufsiz;
2854 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2855 while (buf < ebuf && b->ptr < eptr)
2859 if ((b->ptr + 2) > eptr)
2861 /* Not room for both */
2867 *(b->ptr)++ = 0xd; /* CR */
2868 *(b->ptr)++ = 0xa; /* LF */
2870 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2889 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2891 return (buf - (STDCHAR *) vbuf);
2896 PerlIOCrlf_flush(PerlIO *f)
2898 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2904 return PerlIOBuf_flush(f);
2907 PerlIO_funcs PerlIO_crlf = {
2910 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2916 PerlIOBase_noop_ok, /* popped */
2917 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2918 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2919 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2927 PerlIOBase_clearerr,
2928 PerlIOBuf_setlinebuf,
2933 PerlIOCrlf_set_ptrcnt,
2937 /*--------------------------------------------------------------------------------------*/
2938 /* mmap as "buffer" layer */
2942 PerlIOBuf base; /* PerlIOBuf stuff */
2943 Mmap_t mptr; /* Mapped address */
2944 Size_t len; /* mapped length */
2945 STDCHAR *bbuf; /* malloced buffer if map fails */
2948 static size_t page_size = 0;
2951 PerlIOMmap_map(PerlIO *f)
2954 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2955 PerlIOBuf *b = &m->base;
2956 IV flags = PerlIOBase(f)->flags;
2960 if (flags & PERLIO_F_CANREAD)
2962 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2963 int fd = PerlIO_fileno(f);
2965 code = fstat(fd,&st);
2966 if (code == 0 && S_ISREG(st.st_mode))
2968 SSize_t len = st.st_size - b->posn;
2973 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2975 SETERRNO(0,SS$_NORMAL);
2976 # ifdef _SC_PAGESIZE
2977 page_size = sysconf(_SC_PAGESIZE);
2979 page_size = sysconf(_SC_PAGE_SIZE);
2981 if ((long)page_size < 0) {
2986 (void)SvUPGRADE(error, SVt_PV);
2987 msg = SvPVx(error, n_a);
2988 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2991 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2995 # ifdef HAS_GETPAGESIZE
2996 page_size = getpagesize();
2998 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2999 page_size = PAGESIZE; /* compiletime, bad */
3003 if ((IV)page_size <= 0)
3004 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
3008 /* This is a hack - should never happen - open should have set it ! */
3009 b->posn = PerlIO_tell(PerlIONext(f));
3011 posn = (b->posn / page_size) * page_size;
3012 len = st.st_size - posn;
3013 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3014 if (m->mptr && m->mptr != (Mmap_t) -1)
3016 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3017 madvise(m->mptr, len, MADV_SEQUENTIAL);
3019 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3020 madvise(m->mptr, len, MADV_WILLNEED);
3022 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3023 b->end = ((STDCHAR *)m->mptr) + len;
3024 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3035 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3037 b->ptr = b->end = b->ptr;
3046 PerlIOMmap_unmap(PerlIO *f)
3048 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3049 PerlIOBuf *b = &m->base;
3055 code = munmap(m->mptr, m->len);
3059 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3062 b->ptr = b->end = b->buf;
3063 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3069 PerlIOMmap_get_base(PerlIO *f)
3071 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3072 PerlIOBuf *b = &m->base;
3073 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3075 /* Already have a readbuffer in progress */
3080 /* We have a write buffer or flushed PerlIOBuf read buffer */
3081 m->bbuf = b->buf; /* save it in case we need it again */
3082 b->buf = NULL; /* Clear to trigger below */
3086 PerlIOMmap_map(f); /* Try and map it */
3089 /* Map did not work - recover PerlIOBuf buffer if we have one */
3093 b->ptr = b->end = b->buf;
3096 return PerlIOBuf_get_base(f);
3100 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3102 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3103 PerlIOBuf *b = &m->base;
3104 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3106 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3109 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3114 /* Loose the unwritable mapped buffer */
3116 /* If flush took the "buffer" see if we have one from before */
3117 if (!b->buf && m->bbuf)
3121 PerlIOBuf_get_base(f);
3125 return PerlIOBuf_unread(f,vbuf,count);
3129 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3131 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3132 PerlIOBuf *b = &m->base;
3133 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3135 /* No, or wrong sort of, buffer */
3138 if (PerlIOMmap_unmap(f) != 0)
3141 /* If unmap took the "buffer" see if we have one from before */
3142 if (!b->buf && m->bbuf)
3146 PerlIOBuf_get_base(f);
3150 return PerlIOBuf_write(f,vbuf,count);
3154 PerlIOMmap_flush(PerlIO *f)
3156 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3157 PerlIOBuf *b = &m->base;
3158 IV code = PerlIOBuf_flush(f);
3159 /* Now we are "synced" at PerlIOBuf level */
3164 /* Unmap the buffer */
3165 if (PerlIOMmap_unmap(f) != 0)
3170 /* We seem to have a PerlIOBuf buffer which was not mapped
3171 * remember it in case we need one later
3180 PerlIOMmap_fill(PerlIO *f)
3182 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3183 IV code = PerlIO_flush(f);
3184 if (code == 0 && !b->buf)
3186 code = PerlIOMmap_map(f);
3188 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3190 code = PerlIOBuf_fill(f);
3196 PerlIOMmap_close(PerlIO *f)
3198 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3199 PerlIOBuf *b = &m->base;
3200 IV code = PerlIO_flush(f);
3205 b->ptr = b->end = b->buf;
3207 if (PerlIOBuf_close(f) != 0)
3213 PerlIO_funcs PerlIO_mmap = {
3233 PerlIOBase_clearerr,
3234 PerlIOBuf_setlinebuf,
3235 PerlIOMmap_get_base,
3239 PerlIOBuf_set_ptrcnt,
3242 #endif /* HAS_MMAP */
3250 atexit(&PerlIO_cleanup);
3262 PerlIO_stdstreams();
3266 #undef PerlIO_stdout
3271 PerlIO_stdstreams();
3275 #undef PerlIO_stderr
3280 PerlIO_stdstreams();
3284 /*--------------------------------------------------------------------------------------*/
3286 #undef PerlIO_getname
3288 PerlIO_getname(PerlIO *f, char *buf)
3291 Perl_croak(aTHX_ "Don't know how to get file name");
3296 /*--------------------------------------------------------------------------------------*/
3297 /* Functions which can be called on any kind of PerlIO implemented
3303 PerlIO_getc(PerlIO *f)
3306 SSize_t count = PerlIO_read(f,buf,1);
3309 return (unsigned char) buf[0];
3314 #undef PerlIO_ungetc
3316 PerlIO_ungetc(PerlIO *f, int ch)
3321 if (PerlIO_unread(f,&buf,1) == 1)
3329 PerlIO_putc(PerlIO *f, int ch)
3332 return PerlIO_write(f,&buf,1);
3337 PerlIO_puts(PerlIO *f, const char *s)
3339 STRLEN len = strlen(s);
3340 return PerlIO_write(f,s,len);
3343 #undef PerlIO_rewind
3345 PerlIO_rewind(PerlIO *f)
3347 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3351 #undef PerlIO_vprintf
3353 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3356 SV *sv = newSVpvn("",0);
3361 Perl_va_copy(ap, apc);
3362 sv_vcatpvf(sv, fmt, &apc);
3364 sv_vcatpvf(sv, fmt, &ap);
3367 return PerlIO_write(f,s,len);
3370 #undef PerlIO_printf
3372 PerlIO_printf(PerlIO *f,const char *fmt,...)
3377 result = PerlIO_vprintf(f,fmt,ap);
3382 #undef PerlIO_stdoutf
3384 PerlIO_stdoutf(const char *fmt,...)
3389 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3394 #undef PerlIO_tmpfile
3396 PerlIO_tmpfile(void)
3398 /* I have no idea how portable mkstemp() is ... */
3399 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3402 FILE *stdio = PerlSIO_tmpfile();
3405 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3411 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3412 int fd = mkstemp(SvPVX(sv));
3416 f = PerlIO_fdopen(fd,"w+");
3419 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3421 PerlLIO_unlink(SvPVX(sv));
3431 #endif /* USE_SFIO */
3432 #endif /* PERLIO_IS_STDIO */
3434 /*======================================================================================*/
3435 /* Now some functions in terms of above which may be needed even if
3436 we are not in true PerlIO mode
3440 #undef PerlIO_setpos
3442 PerlIO_setpos(PerlIO *f, SV *pos)
3448 Off_t *posn = (Off_t *) SvPV(pos,len);
3449 if (f && len == sizeof(Off_t))
3450 return PerlIO_seek(f,*posn,SEEK_SET);
3456 #undef PerlIO_setpos
3458 PerlIO_setpos(PerlIO *f, SV *pos)
3464 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3465 if (f && len == sizeof(Fpos_t))
3467 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3468 return fsetpos64(f, fpos);
3470 return fsetpos(f, fpos);
3480 #undef PerlIO_getpos
3482 PerlIO_getpos(PerlIO *f, SV *pos)
3485 Off_t posn = PerlIO_tell(f);
3486 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3487 return (posn == (Off_t)-1) ? -1 : 0;
3490 #undef PerlIO_getpos
3492 PerlIO_getpos(PerlIO *f, SV *pos)
3497 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3498 code = fgetpos64(f, &fpos);
3500 code = fgetpos(f, &fpos);
3502 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3507 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3510 vprintf(char *pat, char *args)
3512 _doprnt(pat, args, stdout);
3513 return 0; /* wrong, but perl doesn't use the return value */
3517 vfprintf(FILE *fd, char *pat, char *args)
3519 _doprnt(pat, args, fd);
3520 return 0; /* wrong, but perl doesn't use the return value */
3525 #ifndef PerlIO_vsprintf
3527 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3529 int val = vsprintf(s, fmt, ap);
3532 if (strlen(s) >= (STRLEN)n)
3535 (void)PerlIO_puts(Perl_error_log,
3536 "panic: sprintf overflow - memory corrupted!\n");
3544 #ifndef PerlIO_sprintf
3546 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3551 result = PerlIO_vsprintf(s, n, fmt, ap);