3 * Copyright (c) 1996-2000, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
39 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
41 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
45 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
51 perlsio_binmode(FILE *fp, int iotype, int mode)
53 /* This used to be contents of do_binmode in doio.c */
55 # if defined(atarist) || defined(__MINT__)
58 ((FILE*)fp)->_flag |= _IOBIN;
60 ((FILE*)fp)->_flag &= ~ _IOBIN;
65 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
66 # if defined(WIN32) && defined(__BORLANDC__)
67 /* The translation mode of the stream is maintained independent
68 * of the translation mode of the fd in the Borland RTL (heavy
69 * digging through their runtime sources reveal). User has to
70 * set the mode explicitly for the stream (though they don't
71 * document this anywhere). GSAR 97-5-24
77 fp->flags &= ~ _F_BIN;
85 # if defined(USEMYBINMODE)
86 if (my_binmode(fp, iotype, mode) != FALSE)
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
105 #ifdef PERLIO_IS_STDIO
110 /* Does nothing (yet) except force this file to be included
111 in perl binary. That allows this file to force inclusion
112 of other functions that may be required by loadable
113 extensions e.g. for FileHandle::tmpfile
117 #undef PerlIO_tmpfile
124 #else /* PERLIO_IS_STDIO */
131 /* This section is just to make sure these functions
132 get pulled in from libsfio.a
135 #undef PerlIO_tmpfile
145 /* Force this file to be included in perl binary. Which allows
146 * this file to force inclusion of other functions that may be
147 * required by loadable extensions e.g. for FileHandle::tmpfile
151 * sfio does its own 'autoflush' on stdout in common cases.
152 * Flush results in a lot of lseek()s to regular files and
153 * lot of small writes to pipes.
155 sfset(sfstdout,SF_SHARE,0);
159 /*======================================================================================*/
160 /* Implement all the PerlIO interface ourselves.
165 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
170 #include <sys/mman.h>
175 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
178 PerlIO_debug(const char *fmt,...)
186 char *s = PerlEnv_getenv("PERLIO_DEBUG");
188 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
195 SV *sv = newSVpvn("",0);
198 s = CopFILE(PL_curcop);
201 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
202 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
205 PerlLIO_write(dbg,s,len);
211 /*--------------------------------------------------------------------------------------*/
213 /* Inner level routines */
215 /* Table of pointers to the PerlIO structs (malloc'ed) */
216 PerlIO *_perlio = NULL;
217 #define PERLIO_TABLE_SIZE 64
220 PerlIO_allocate(pTHX)
222 /* Find a free slot in the table, allocating new table as necessary */
229 last = (PerlIO **)(f);
230 for (i=1; i < PERLIO_TABLE_SIZE; i++)
238 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
248 PerlIO_cleantable(pTHX_ PerlIO **tablep)
250 PerlIO *table = *tablep;
254 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
255 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
263 PerlMemShared_free(table);
275 PerlIO_cleantable(aTHX_ &_perlio);
279 PerlIO_pop(PerlIO *f)
285 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
286 (*l->tab->Popped)(f);
288 PerlMemShared_free(l);
292 /*--------------------------------------------------------------------------------------*/
293 /* XS Interface for perl code */
299 char *s = GvNAME(gv);
300 STRLEN l = GvNAMELEN(gv);
301 PerlIO_debug("%.*s\n",(int) l,s);
305 XS(XS_perlio_unimport)
309 char *s = GvNAME(gv);
310 STRLEN l = GvNAMELEN(gv);
311 PerlIO_debug("%.*s\n",(int) l,s);
316 PerlIO_find_layer(const char *name, STRLEN len)
321 if ((SSize_t) len <= 0)
323 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
324 if (svp && (sv = *svp) && SvROK(sv))
331 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
335 IO *io = GvIOn((GV *)SvRV(sv));
336 PerlIO *ifp = IoIFP(io);
337 PerlIO *ofp = IoOFP(io);
338 AV *av = (AV *) mg->mg_obj;
339 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
345 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
349 IO *io = GvIOn((GV *)SvRV(sv));
350 PerlIO *ifp = IoIFP(io);
351 PerlIO *ofp = IoOFP(io);
352 AV *av = (AV *) mg->mg_obj;
353 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
359 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
361 Perl_warn(aTHX_ "clear %"SVf,sv);
366 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
368 Perl_warn(aTHX_ "free %"SVf,sv);
372 MGVTBL perlio_vtab = {
380 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
383 SV *sv = SvRV(ST(1));
388 sv_magic(sv, (SV *)av, '~', NULL, 0);
390 mg = mg_find(sv,'~');
391 mg->mg_virtual = &perlio_vtab;
393 Perl_warn(aTHX_ "attrib %"SVf,sv);
394 for (i=2; i < items; i++)
397 const char *name = SvPV(ST(i),len);
398 SV *layer = PerlIO_find_layer(name,len);
401 av_push(av,SvREFCNT_inc(layer));
414 PerlIO_define_layer(PerlIO_funcs *tab)
417 HV *stash = gv_stashpv("perlio::Layer", TRUE);
418 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
419 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
423 PerlIO_default_layer(I32 n)
428 PerlIO_funcs *tab = &PerlIO_stdio;
430 if (!PerlIO_layer_hv)
432 const char *s = PerlEnv_getenv("PERLIO");
433 newXS("perlio::import",XS_perlio_import,__FILE__);
434 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
436 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
438 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
439 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
440 PerlIO_define_layer(&PerlIO_unix);
441 PerlIO_define_layer(&PerlIO_perlio);
442 PerlIO_define_layer(&PerlIO_stdio);
443 PerlIO_define_layer(&PerlIO_crlf);
445 PerlIO_define_layer(&PerlIO_mmap);
447 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
452 while (*s && isSPACE((unsigned char)*s))
458 while (*e && !isSPACE((unsigned char)*e))
462 layer = PerlIO_find_layer(s,e-s);
465 PerlIO_debug("Pushing %.*s\n",(e-s),s);
466 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
469 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
475 len = av_len(PerlIO_layer_av);
478 if (O_BINARY != O_TEXT)
480 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
484 if (PerlIO_stdio.Set_ptrcnt)
486 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
490 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
493 len = av_len(PerlIO_layer_av);
497 svp = av_fetch(PerlIO_layer_av,n,0);
498 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
500 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
502 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
506 #define PerlIO_default_top() PerlIO_default_layer(-1)
507 #define PerlIO_default_btm() PerlIO_default_layer(0)
515 PerlIO_allocate(aTHX);
516 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
517 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
518 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
523 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
527 l = PerlMemShared_calloc(tab->size,sizeof(char));
530 Zero(l,tab->size,char);
534 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
535 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
545 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
549 const char *s = names;
559 const char *as = Nullch;
560 const char *ae = Nullch;
562 while (*e && *e != ':' && !isSPACE(*e))
572 if (as && --count == 0)
579 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
581 /* Pop back to bottom layer */
585 while (PerlIONext(f))
591 else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
593 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
595 else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
597 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
601 STRLEN len = ((as) ? as : e)-s;
602 SV *layer = PerlIO_find_layer(s,len);
605 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
608 len = (as) ? (ae-(as++)-1) : 0;
609 if (!PerlIO_push(f,tab,mode,as,len))
614 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
626 /*--------------------------------------------------------------------------------------*/
627 /* Given the abstraction above the public API functions */
630 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
632 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
633 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
634 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
640 if (PerlIOBase(top)->tab == &PerlIO_crlf)
643 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
646 top = PerlIONext(top);
649 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
654 PerlIO__close(PerlIO *f)
656 return (*PerlIOBase(f)->tab->Close)(f);
659 #undef PerlIO_fdupopen
661 PerlIO_fdupopen(pTHX_ PerlIO *f)
664 int fd = PerlLIO_dup(PerlIO_fileno(f));
665 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
668 Off_t posn = PerlIO_tell(f);
669 PerlIO_seek(new,posn,SEEK_SET);
676 PerlIO_close(PerlIO *f)
678 int code = (*PerlIOBase(f)->tab->Close)(f);
688 PerlIO_fileno(PerlIO *f)
690 return (*PerlIOBase(f)->tab->Fileno)(f);
697 PerlIO_fdopen(int fd, const char *mode)
699 PerlIO_funcs *tab = PerlIO_default_top();
702 return (*tab->Fdopen)(tab,fd,mode);
707 PerlIO_open(const char *path, const char *mode)
709 PerlIO_funcs *tab = PerlIO_default_top();
712 return (*tab->Open)(tab,path,mode);
717 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
722 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
724 if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
730 return PerlIO_open(path,mode);
735 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
737 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
742 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
744 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
749 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
751 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
756 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
758 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
763 PerlIO_tell(PerlIO *f)
765 return (*PerlIOBase(f)->tab->Tell)(f);
770 PerlIO_flush(PerlIO *f)
774 return (*PerlIOBase(f)->tab->Flush)(f);
778 PerlIO **table = &_perlio;
783 table = (PerlIO **)(f++);
784 for (i=1; i < PERLIO_TABLE_SIZE; i++)
786 if (*f && PerlIO_flush(f) != 0)
797 PerlIO_fill(PerlIO *f)
799 return (*PerlIOBase(f)->tab->Fill)(f);
804 PerlIO_isutf8(PerlIO *f)
806 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
811 PerlIO_eof(PerlIO *f)
813 return (*PerlIOBase(f)->tab->Eof)(f);
818 PerlIO_error(PerlIO *f)
820 return (*PerlIOBase(f)->tab->Error)(f);
823 #undef PerlIO_clearerr
825 PerlIO_clearerr(PerlIO *f)
828 (*PerlIOBase(f)->tab->Clearerr)(f);
831 #undef PerlIO_setlinebuf
833 PerlIO_setlinebuf(PerlIO *f)
835 (*PerlIOBase(f)->tab->Setlinebuf)(f);
838 #undef PerlIO_has_base
840 PerlIO_has_base(PerlIO *f)
844 return (PerlIOBase(f)->tab->Get_base != NULL);
849 #undef PerlIO_fast_gets
851 PerlIO_fast_gets(PerlIO *f)
853 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
855 PerlIO_funcs *tab = PerlIOBase(f)->tab;
856 return (tab->Set_ptrcnt != NULL);
861 #undef PerlIO_has_cntptr
863 PerlIO_has_cntptr(PerlIO *f)
867 PerlIO_funcs *tab = PerlIOBase(f)->tab;
868 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
873 #undef PerlIO_canset_cnt
875 PerlIO_canset_cnt(PerlIO *f)
879 PerlIOl *l = PerlIOBase(f);
880 return (l->tab->Set_ptrcnt != NULL);
885 #undef PerlIO_get_base
887 PerlIO_get_base(PerlIO *f)
889 return (*PerlIOBase(f)->tab->Get_base)(f);
892 #undef PerlIO_get_bufsiz
894 PerlIO_get_bufsiz(PerlIO *f)
896 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
899 #undef PerlIO_get_ptr
901 PerlIO_get_ptr(PerlIO *f)
903 PerlIO_funcs *tab = PerlIOBase(f)->tab;
904 if (tab->Get_ptr == NULL)
906 return (*tab->Get_ptr)(f);
909 #undef PerlIO_get_cnt
911 PerlIO_get_cnt(PerlIO *f)
913 PerlIO_funcs *tab = PerlIOBase(f)->tab;
914 if (tab->Get_cnt == NULL)
916 return (*tab->Get_cnt)(f);
919 #undef PerlIO_set_cnt
921 PerlIO_set_cnt(PerlIO *f,int cnt)
923 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
926 #undef PerlIO_set_ptrcnt
928 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
930 PerlIO_funcs *tab = PerlIOBase(f)->tab;
931 if (tab->Set_ptrcnt == NULL)
934 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
936 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
939 /*--------------------------------------------------------------------------------------*/
940 /* "Methods" of the "base class" */
943 PerlIOBase_fileno(PerlIO *f)
945 return PerlIO_fileno(PerlIONext(f));
949 PerlIO_modestr(PerlIO *f,char *buf)
952 IV flags = PerlIOBase(f)->flags;
953 if (flags & PERLIO_F_APPEND)
956 if (flags & PERLIO_F_CANREAD)
961 else if (flags & PERLIO_F_CANREAD)
964 if (flags & PERLIO_F_CANWRITE)
967 else if (flags & PERLIO_F_CANWRITE)
970 if (flags & PERLIO_F_CANREAD)
975 #if O_TEXT != O_BINARY
976 if (!(flags & PERLIO_F_CRLF))
984 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
986 PerlIOl *l = PerlIOBase(f);
987 const char *omode = mode;
989 PerlIO_funcs *tab = PerlIOBase(f)->tab;
990 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
991 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
992 if (tab->Set_ptrcnt != NULL)
993 l->flags |= PERLIO_F_FASTGETS;
999 l->flags |= PERLIO_F_CANREAD;
1002 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1005 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1016 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1019 l->flags &= ~PERLIO_F_CRLF;
1022 l->flags |= PERLIO_F_CRLF;
1034 l->flags |= l->next->flags &
1035 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1039 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1040 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1041 l->flags,PerlIO_modestr(f,temp));
1047 PerlIOBase_popped(PerlIO *f)
1052 extern PerlIO_funcs PerlIO_pending;
1055 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1058 Off_t old = PerlIO_tell(f);
1059 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1061 Off_t new = PerlIO_tell(f);
1069 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1070 return PerlIOBuf_unread(f,vbuf,count);
1075 PerlIOBase_noop_ok(PerlIO *f)
1081 PerlIOBase_noop_fail(PerlIO *f)
1087 PerlIOBase_close(PerlIO *f)
1090 PerlIO *n = PerlIONext(f);
1091 if (PerlIO_flush(f) != 0)
1093 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1095 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1100 PerlIOBase_eof(PerlIO *f)
1104 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1110 PerlIOBase_error(PerlIO *f)
1114 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1120 PerlIOBase_clearerr(PerlIO *f)
1124 PerlIO *n = PerlIONext(f);
1125 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1132 PerlIOBase_setlinebuf(PerlIO *f)
1137 /*--------------------------------------------------------------------------------------*/
1138 /* Bottom-most level for UNIX-like case */
1142 struct _PerlIO base; /* The generic part */
1143 int fd; /* UNIX like file descriptor */
1144 int oflags; /* open/fcntl flags */
1148 PerlIOUnix_oflags(const char *mode)
1163 oflags = O_CREAT|O_TRUNC;
1174 oflags = O_CREAT|O_APPEND;
1190 else if (*mode == 't')
1193 oflags &= ~O_BINARY;
1196 /* Always open in binary mode */
1198 if (*mode || oflags == -1)
1207 PerlIOUnix_fileno(PerlIO *f)
1209 return PerlIOSelf(f,PerlIOUnix)->fd;
1213 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1221 int oflags = PerlIOUnix_oflags(mode);
1224 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1227 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1234 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1238 int oflags = PerlIOUnix_oflags(mode);
1241 int fd = PerlLIO_open3(path,oflags,0666);
1244 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1247 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1254 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1256 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1257 int oflags = PerlIOUnix_oflags(mode);
1258 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1259 (*PerlIOBase(f)->tab->Close)(f);
1263 int fd = PerlLIO_open3(path,oflags,0666);
1268 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1276 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1279 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1280 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1284 SSize_t len = PerlLIO_read(fd,vbuf,count);
1285 if (len >= 0 || errno != EINTR)
1288 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1289 else if (len == 0 && count != 0)
1290 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1297 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1300 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1303 SSize_t len = PerlLIO_write(fd,vbuf,count);
1304 if (len >= 0 || errno != EINTR)
1307 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1314 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1317 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1318 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1319 return (new == (Off_t) -1) ? -1 : 0;
1323 PerlIOUnix_tell(PerlIO *f)
1326 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1327 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1331 PerlIOUnix_close(PerlIO *f)
1334 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1336 while (PerlLIO_close(fd) != 0)
1346 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1351 PerlIO_funcs PerlIO_unix = {
1367 PerlIOBase_noop_ok, /* flush */
1368 PerlIOBase_noop_fail, /* fill */
1371 PerlIOBase_clearerr,
1372 PerlIOBase_setlinebuf,
1373 NULL, /* get_base */
1374 NULL, /* get_bufsiz */
1377 NULL, /* set_ptrcnt */
1380 /*--------------------------------------------------------------------------------------*/
1381 /* stdio as a layer */
1385 struct _PerlIO base;
1386 FILE * stdio; /* The stream */
1390 PerlIOStdio_fileno(PerlIO *f)
1393 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1397 PerlIOStdio_mode(const char *mode,char *tmode)
1404 if (O_BINARY != O_TEXT)
1413 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1432 stdio = PerlSIO_stdin;
1435 stdio = PerlSIO_stdout;
1438 stdio = PerlSIO_stderr;
1444 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1448 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1455 #undef PerlIO_importFILE
1457 PerlIO_importFILE(FILE *stdio, int fl)
1463 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1470 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1474 FILE *stdio = PerlSIO_fopen(path,mode);
1478 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1479 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1487 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1490 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1492 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1500 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1503 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1507 STDCHAR *buf = (STDCHAR *) vbuf;
1508 /* Perl is expecting PerlIO_getc() to fill the buffer
1509 * Linux's stdio does not do that for fread()
1511 int ch = PerlSIO_fgetc(s);
1519 got = PerlSIO_fread(vbuf,1,count,s);
1524 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1527 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1528 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1532 int ch = *buf-- & 0xff;
1533 if (PerlSIO_ungetc(ch,s) != ch)
1542 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1545 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1549 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1552 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1553 return PerlSIO_fseek(stdio,offset,whence);
1557 PerlIOStdio_tell(PerlIO *f)
1560 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1561 return PerlSIO_ftell(stdio);
1565 PerlIOStdio_close(PerlIO *f)
1569 int optval, optlen = sizeof(int);
1571 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1574 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1575 PerlSIO_fclose(stdio) :
1576 close(PerlIO_fileno(f))
1578 PerlSIO_fclose(stdio)
1585 PerlIOStdio_flush(PerlIO *f)
1588 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1589 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1591 return PerlSIO_fflush(stdio);
1596 /* FIXME: This discards ungetc() and pre-read stuff which is
1597 not right if this is just a "sync" from a layer above
1598 Suspect right design is to do _this_ but not have layer above
1599 flush this layer read-to-read
1601 /* Not writeable - sync by attempting a seek */
1603 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1611 PerlIOStdio_fill(PerlIO *f)
1614 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1616 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1617 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1619 if (PerlSIO_fflush(stdio) != 0)
1622 c = PerlSIO_fgetc(stdio);
1623 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1629 PerlIOStdio_eof(PerlIO *f)
1632 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1636 PerlIOStdio_error(PerlIO *f)
1639 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1643 PerlIOStdio_clearerr(PerlIO *f)
1646 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1650 PerlIOStdio_setlinebuf(PerlIO *f)
1653 #ifdef HAS_SETLINEBUF
1654 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1656 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1662 PerlIOStdio_get_base(PerlIO *f)
1665 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1666 return PerlSIO_get_base(stdio);
1670 PerlIOStdio_get_bufsiz(PerlIO *f)
1673 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1674 return PerlSIO_get_bufsiz(stdio);
1678 #ifdef USE_STDIO_PTR
1680 PerlIOStdio_get_ptr(PerlIO *f)
1683 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1684 return PerlSIO_get_ptr(stdio);
1688 PerlIOStdio_get_cnt(PerlIO *f)
1691 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1692 return PerlSIO_get_cnt(stdio);
1696 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1699 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1702 #ifdef STDIO_PTR_LVALUE
1703 PerlSIO_set_ptr(stdio,ptr);
1704 #ifdef STDIO_PTR_LVAL_SETS_CNT
1705 if (PerlSIO_get_cnt(stdio) != (cnt))
1708 assert(PerlSIO_get_cnt(stdio) == (cnt));
1711 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1712 /* Setting ptr _does_ change cnt - we are done */
1715 #else /* STDIO_PTR_LVALUE */
1717 #endif /* STDIO_PTR_LVALUE */
1719 /* Now (or only) set cnt */
1720 #ifdef STDIO_CNT_LVALUE
1721 PerlSIO_set_cnt(stdio,cnt);
1722 #else /* STDIO_CNT_LVALUE */
1723 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1724 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1725 #else /* STDIO_PTR_LVAL_SETS_CNT */
1727 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1728 #endif /* STDIO_CNT_LVALUE */
1733 PerlIO_funcs PerlIO_stdio = {
1735 sizeof(PerlIOStdio),
1753 PerlIOStdio_clearerr,
1754 PerlIOStdio_setlinebuf,
1756 PerlIOStdio_get_base,
1757 PerlIOStdio_get_bufsiz,
1762 #ifdef USE_STDIO_PTR
1763 PerlIOStdio_get_ptr,
1764 PerlIOStdio_get_cnt,
1765 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1766 PerlIOStdio_set_ptrcnt
1767 #else /* STDIO_PTR_LVALUE */
1769 #endif /* STDIO_PTR_LVALUE */
1770 #else /* USE_STDIO_PTR */
1774 #endif /* USE_STDIO_PTR */
1777 #undef PerlIO_exportFILE
1779 PerlIO_exportFILE(PerlIO *f, int fl)
1782 /* Should really push stdio discipline when we have them */
1783 return fdopen(PerlIO_fileno(f),"r+");
1786 #undef PerlIO_findFILE
1788 PerlIO_findFILE(PerlIO *f)
1790 return PerlIO_exportFILE(f,0);
1793 #undef PerlIO_releaseFILE
1795 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1799 /*--------------------------------------------------------------------------------------*/
1800 /* perlio buffer layer */
1803 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1805 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1806 b->posn = PerlIO_tell(PerlIONext(f));
1807 return PerlIOBase_pushed(f,mode,arg,len);
1811 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1814 PerlIO_funcs *tab = PerlIO_default_btm();
1822 #if O_BINARY != O_TEXT
1823 /* do something about failing setmode()? --jhi */
1824 PerlLIO_setmode(fd, O_BINARY);
1826 f = (*tab->Fdopen)(tab,fd,mode);
1829 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1830 if (init && fd == 2)
1832 /* Initial stderr is unbuffered */
1833 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1836 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1837 self->name,f,fd,mode,PerlIOBase(f)->flags);
1844 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1846 PerlIO_funcs *tab = PerlIO_default_btm();
1847 PerlIO *f = (*tab->Open)(tab,path,mode);
1850 PerlIO_push(f,self,mode,Nullch,0);
1856 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1858 PerlIO *next = PerlIONext(f);
1859 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1861 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
1865 /* This "flush" is akin to sfio's sync in that it handles files in either
1869 PerlIOBuf_flush(PerlIO *f)
1871 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1873 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1875 /* write() the buffer */
1876 STDCHAR *buf = b->buf;
1879 PerlIO *n = PerlIONext(f);
1882 count = PerlIO_write(n,p,b->ptr - p);
1887 else if (count < 0 || PerlIO_error(n))
1889 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1894 b->posn += (p - buf);
1896 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1898 STDCHAR *buf = PerlIO_get_base(f);
1899 /* Note position change */
1900 b->posn += (b->ptr - buf);
1901 if (b->ptr < b->end)
1903 /* We did not consume all of it */
1904 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1906 b->posn = PerlIO_tell(PerlIONext(f));
1910 b->ptr = b->end = b->buf;
1911 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1912 /* FIXME: Is this right for read case ? */
1913 if (PerlIO_flush(PerlIONext(f)) != 0)
1919 PerlIOBuf_fill(PerlIO *f)
1921 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1922 PerlIO *n = PerlIONext(f);
1924 /* FIXME: doing the down-stream flush is a bad idea if it causes
1925 pre-read data in stdio buffer to be discarded
1926 but this is too simplistic - as it skips _our_ hosekeeping
1927 and breaks tell tests.
1928 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1932 if (PerlIO_flush(f) != 0)
1936 PerlIO_get_base(f); /* allocate via vtable */
1938 b->ptr = b->end = b->buf;
1939 if (PerlIO_fast_gets(n))
1941 /* Layer below is also buffered
1942 * We do _NOT_ want to call its ->Read() because that will loop
1943 * till it gets what we asked for which may hang on a pipe etc.
1944 * Instead take anything it has to hand, or ask it to fill _once_.
1946 avail = PerlIO_get_cnt(n);
1949 avail = PerlIO_fill(n);
1951 avail = PerlIO_get_cnt(n);
1954 if (!PerlIO_error(n) && PerlIO_eof(n))
1960 STDCHAR *ptr = PerlIO_get_ptr(n);
1961 SSize_t cnt = avail;
1962 if (avail > b->bufsiz)
1964 Copy(ptr,b->buf,avail,STDCHAR);
1965 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1970 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1975 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1977 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1980 b->end = b->buf+avail;
1981 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1986 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1988 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1989 STDCHAR *buf = (STDCHAR *) vbuf;
1994 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1998 SSize_t avail = PerlIO_get_cnt(f);
1999 SSize_t take = (count < avail) ? count : avail;
2002 STDCHAR *ptr = PerlIO_get_ptr(f);
2003 Copy(ptr,buf,take,STDCHAR);
2004 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2008 if (count > 0 && avail <= 0)
2010 if (PerlIO_fill(f) != 0)
2014 return (buf - (STDCHAR *) vbuf);
2020 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2022 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2023 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2026 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2032 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2034 avail = (b->ptr - b->buf);
2039 b->end = b->buf + avail;
2041 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2042 b->posn -= b->bufsiz;
2044 if (avail > (SSize_t) count)
2052 Copy(buf,b->ptr,avail,STDCHAR);
2056 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2063 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2065 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2066 const STDCHAR *buf = (const STDCHAR *) vbuf;
2070 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2074 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2075 if ((SSize_t) count < avail)
2077 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2078 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2098 Copy(buf,b->ptr,avail,STDCHAR);
2105 if (b->ptr >= (b->buf + b->bufsiz))
2108 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2114 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2117 if ((code = PerlIO_flush(f)) == 0)
2119 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2120 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2121 code = PerlIO_seek(PerlIONext(f),offset,whence);
2124 b->posn = PerlIO_tell(PerlIONext(f));
2131 PerlIOBuf_tell(PerlIO *f)
2133 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2134 Off_t posn = b->posn;
2136 posn += (b->ptr - b->buf);
2141 PerlIOBuf_close(PerlIO *f)
2144 IV code = PerlIOBase_close(f);
2145 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2146 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2148 PerlMemShared_free(b->buf);
2151 b->ptr = b->end = b->buf;
2152 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2157 PerlIOBuf_setlinebuf(PerlIO *f)
2161 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2166 PerlIOBuf_get_ptr(PerlIO *f)
2168 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2175 PerlIOBuf_get_cnt(PerlIO *f)
2177 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2180 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2181 return (b->end - b->ptr);
2186 PerlIOBuf_get_base(PerlIO *f)
2188 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2194 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2197 b->buf = (STDCHAR *)&b->oneword;
2198 b->bufsiz = sizeof(b->oneword);
2207 PerlIOBuf_bufsiz(PerlIO *f)
2209 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2212 return (b->end - b->buf);
2216 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2218 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2222 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2225 assert(PerlIO_get_cnt(f) == cnt);
2226 assert(b->ptr >= b->buf);
2228 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2231 PerlIO_funcs PerlIO_perlio = {
2251 PerlIOBase_clearerr,
2252 PerlIOBuf_setlinebuf,
2257 PerlIOBuf_set_ptrcnt,
2260 /*--------------------------------------------------------------------------------------*/
2261 /* Temp layer to hold unread chars when cannot do it any other way */
2264 PerlIOPending_fill(PerlIO *f)
2266 /* Should never happen */
2272 PerlIOPending_close(PerlIO *f)
2274 /* A tad tricky - flush pops us, then we close new top */
2276 return PerlIO_close(f);
2280 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2282 /* A tad tricky - flush pops us, then we seek new top */
2284 return PerlIO_seek(f,offset,whence);
2289 PerlIOPending_flush(PerlIO *f)
2291 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2292 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2295 PerlMemShared_free(b->buf);
2303 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2311 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2316 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2318 IV code = PerlIOBuf_pushed(f,mode,arg,len);
2319 PerlIOl *l = PerlIOBase(f);
2320 /* Our PerlIO_fast_gets must match what we are pushed on,
2321 or sv_gets() etc. get muddled when it changes mid-string
2324 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2325 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2330 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2332 SSize_t avail = PerlIO_get_cnt(f);
2337 got = PerlIOBuf_read(f,vbuf,avail);
2339 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2344 PerlIO_funcs PerlIO_pending = {
2352 PerlIOPending_pushed,
2359 PerlIOPending_close,
2360 PerlIOPending_flush,
2364 PerlIOBase_clearerr,
2365 PerlIOBuf_setlinebuf,
2370 PerlIOPending_set_ptrcnt,
2375 /*--------------------------------------------------------------------------------------*/
2376 /* crlf - translation
2377 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2378 to hand back a line at a time and keeping a record of which nl we "lied" about.
2379 On write translate "\n" to CR,LF
2384 PerlIOBuf base; /* PerlIOBuf stuff */
2385 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2389 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2392 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2393 code = PerlIOBuf_pushed(f,mode,arg,len);
2395 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2396 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2397 PerlIOBase(f)->flags);
2404 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2406 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2412 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2413 return PerlIOBuf_unread(f,vbuf,count);
2416 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2417 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2419 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2425 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2427 b->end = b->ptr = b->buf + b->bufsiz;
2428 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2429 b->posn -= b->bufsiz;
2431 while (count > 0 && b->ptr > b->buf)
2436 if (b->ptr - 2 >= b->buf)
2462 PerlIOCrlf_get_cnt(PerlIO *f)
2464 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2467 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2469 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2470 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2472 STDCHAR *nl = b->ptr;
2474 while (nl < b->end && *nl != 0xd)
2476 if (nl < b->end && *nl == 0xd)
2488 /* Not CR,LF but just CR */
2495 /* Blast - found CR as last char in buffer */
2498 /* They may not care, defer work as long as possible */
2499 return (nl - b->ptr);
2505 b->ptr++; /* say we have read it as far as flush() is concerned */
2506 b->buf++; /* Leave space an front of buffer */
2507 b->bufsiz--; /* Buffer is thus smaller */
2508 code = PerlIO_fill(f); /* Fetch some more */
2509 b->bufsiz++; /* Restore size for next time */
2510 b->buf--; /* Point at space */
2511 b->ptr = nl = b->buf; /* Which is what we hand off */
2512 b->posn--; /* Buffer starts here */
2513 *nl = 0xd; /* Fill in the CR */
2515 goto test; /* fill() call worked */
2516 /* CR at EOF - just fall through */
2521 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2527 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2529 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2530 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2531 IV flags = PerlIOBase(f)->flags;
2541 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2548 /* Test code - delete when it works ... */
2555 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2563 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2564 ptr, chk, flags, c->nl, b->end, cnt);
2571 /* They have taken what we lied about */
2578 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2582 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2584 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2585 return PerlIOBuf_write(f,vbuf,count);
2588 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2589 const STDCHAR *buf = (const STDCHAR *) vbuf;
2590 const STDCHAR *ebuf = buf+count;
2593 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2597 STDCHAR *eptr = b->buf+b->bufsiz;
2598 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2599 while (buf < ebuf && b->ptr < eptr)
2603 if ((b->ptr + 2) > eptr)
2605 /* Not room for both */
2611 *(b->ptr)++ = 0xd; /* CR */
2612 *(b->ptr)++ = 0xa; /* LF */
2614 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2633 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2635 return (buf - (STDCHAR *) vbuf);
2640 PerlIOCrlf_flush(PerlIO *f)
2642 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2648 return PerlIOBuf_flush(f);
2651 PerlIO_funcs PerlIO_crlf = {
2654 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2660 PerlIOBase_noop_ok, /* popped */
2661 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2662 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2663 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2671 PerlIOBase_clearerr,
2672 PerlIOBuf_setlinebuf,
2677 PerlIOCrlf_set_ptrcnt,
2681 /*--------------------------------------------------------------------------------------*/
2682 /* mmap as "buffer" layer */
2686 PerlIOBuf base; /* PerlIOBuf stuff */
2687 Mmap_t mptr; /* Mapped address */
2688 Size_t len; /* mapped length */
2689 STDCHAR *bbuf; /* malloced buffer if map fails */
2692 static size_t page_size = 0;
2695 PerlIOMmap_map(PerlIO *f)
2698 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2699 PerlIOBuf *b = &m->base;
2700 IV flags = PerlIOBase(f)->flags;
2704 if (flags & PERLIO_F_CANREAD)
2706 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2707 int fd = PerlIO_fileno(f);
2709 code = fstat(fd,&st);
2710 if (code == 0 && S_ISREG(st.st_mode))
2712 SSize_t len = st.st_size - b->posn;
2717 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2719 SETERRNO(0,SS$_NORMAL);
2720 # ifdef _SC_PAGESIZE
2721 page_size = sysconf(_SC_PAGESIZE);
2723 page_size = sysconf(_SC_PAGE_SIZE);
2725 if ((long)page_size < 0) {
2730 (void)SvUPGRADE(error, SVt_PV);
2731 msg = SvPVx(error, n_a);
2732 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2735 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2739 # ifdef HAS_GETPAGESIZE
2740 page_size = getpagesize();
2742 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2743 page_size = PAGESIZE; /* compiletime, bad */
2747 if ((IV)page_size <= 0)
2748 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2752 /* This is a hack - should never happen - open should have set it ! */
2753 b->posn = PerlIO_tell(PerlIONext(f));
2755 posn = (b->posn / page_size) * page_size;
2756 len = st.st_size - posn;
2757 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2758 if (m->mptr && m->mptr != (Mmap_t) -1)
2760 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2761 madvise(m->mptr, len, MADV_SEQUENTIAL);
2763 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2764 madvise(m->mptr, len, MADV_WILLNEED);
2766 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2767 b->end = ((STDCHAR *)m->mptr) + len;
2768 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2779 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2781 b->ptr = b->end = b->ptr;
2790 PerlIOMmap_unmap(PerlIO *f)
2792 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2793 PerlIOBuf *b = &m->base;
2799 code = munmap(m->mptr, m->len);
2803 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2806 b->ptr = b->end = b->buf;
2807 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2813 PerlIOMmap_get_base(PerlIO *f)
2815 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2816 PerlIOBuf *b = &m->base;
2817 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2819 /* Already have a readbuffer in progress */
2824 /* We have a write buffer or flushed PerlIOBuf read buffer */
2825 m->bbuf = b->buf; /* save it in case we need it again */
2826 b->buf = NULL; /* Clear to trigger below */
2830 PerlIOMmap_map(f); /* Try and map it */
2833 /* Map did not work - recover PerlIOBuf buffer if we have one */
2837 b->ptr = b->end = b->buf;
2840 return PerlIOBuf_get_base(f);
2844 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2846 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2847 PerlIOBuf *b = &m->base;
2848 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2850 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2853 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2858 /* Loose the unwritable mapped buffer */
2860 /* If flush took the "buffer" see if we have one from before */
2861 if (!b->buf && m->bbuf)
2865 PerlIOBuf_get_base(f);
2869 return PerlIOBuf_unread(f,vbuf,count);
2873 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2875 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2876 PerlIOBuf *b = &m->base;
2877 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2879 /* No, or wrong sort of, buffer */
2882 if (PerlIOMmap_unmap(f) != 0)
2885 /* If unmap took the "buffer" see if we have one from before */
2886 if (!b->buf && m->bbuf)
2890 PerlIOBuf_get_base(f);
2894 return PerlIOBuf_write(f,vbuf,count);
2898 PerlIOMmap_flush(PerlIO *f)
2900 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2901 PerlIOBuf *b = &m->base;
2902 IV code = PerlIOBuf_flush(f);
2903 /* Now we are "synced" at PerlIOBuf level */
2908 /* Unmap the buffer */
2909 if (PerlIOMmap_unmap(f) != 0)
2914 /* We seem to have a PerlIOBuf buffer which was not mapped
2915 * remember it in case we need one later
2924 PerlIOMmap_fill(PerlIO *f)
2926 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2927 IV code = PerlIO_flush(f);
2928 if (code == 0 && !b->buf)
2930 code = PerlIOMmap_map(f);
2932 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2934 code = PerlIOBuf_fill(f);
2940 PerlIOMmap_close(PerlIO *f)
2942 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2943 PerlIOBuf *b = &m->base;
2944 IV code = PerlIO_flush(f);
2949 b->ptr = b->end = b->buf;
2951 if (PerlIOBuf_close(f) != 0)
2957 PerlIO_funcs PerlIO_mmap = {
2977 PerlIOBase_clearerr,
2978 PerlIOBuf_setlinebuf,
2979 PerlIOMmap_get_base,
2983 PerlIOBuf_set_ptrcnt,
2986 #endif /* HAS_MMAP */
2994 atexit(&PerlIO_cleanup);
3004 PerlIO_stdstreams();
3008 #undef PerlIO_stdout
3013 PerlIO_stdstreams();
3017 #undef PerlIO_stderr
3022 PerlIO_stdstreams();
3026 /*--------------------------------------------------------------------------------------*/
3028 #undef PerlIO_getname
3030 PerlIO_getname(PerlIO *f, char *buf)
3033 Perl_croak(aTHX_ "Don't know how to get file name");
3038 /*--------------------------------------------------------------------------------------*/
3039 /* Functions which can be called on any kind of PerlIO implemented
3045 PerlIO_getc(PerlIO *f)
3048 SSize_t count = PerlIO_read(f,buf,1);
3051 return (unsigned char) buf[0];
3056 #undef PerlIO_ungetc
3058 PerlIO_ungetc(PerlIO *f, int ch)
3063 if (PerlIO_unread(f,&buf,1) == 1)
3071 PerlIO_putc(PerlIO *f, int ch)
3074 return PerlIO_write(f,&buf,1);
3079 PerlIO_puts(PerlIO *f, const char *s)
3081 STRLEN len = strlen(s);
3082 return PerlIO_write(f,s,len);
3085 #undef PerlIO_rewind
3087 PerlIO_rewind(PerlIO *f)
3089 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3093 #undef PerlIO_vprintf
3095 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3098 SV *sv = newSVpvn("",0);
3103 Perl_va_copy(ap, apc);
3104 sv_vcatpvf(sv, fmt, &apc);
3106 sv_vcatpvf(sv, fmt, &ap);
3109 return PerlIO_write(f,s,len);
3112 #undef PerlIO_printf
3114 PerlIO_printf(PerlIO *f,const char *fmt,...)
3119 result = PerlIO_vprintf(f,fmt,ap);
3124 #undef PerlIO_stdoutf
3126 PerlIO_stdoutf(const char *fmt,...)
3131 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3136 #undef PerlIO_tmpfile
3138 PerlIO_tmpfile(void)
3140 /* I have no idea how portable mkstemp() is ... */
3141 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3144 FILE *stdio = PerlSIO_tmpfile();
3147 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3153 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3154 int fd = mkstemp(SvPVX(sv));
3158 f = PerlIO_fdopen(fd,"w+");
3161 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3163 PerlLIO_unlink(SvPVX(sv));
3173 #endif /* USE_SFIO */
3174 #endif /* PERLIO_IS_STDIO */
3176 /*======================================================================================*/
3177 /* Now some functions in terms of above which may be needed even if
3178 we are not in true PerlIO mode
3182 #undef PerlIO_setpos
3184 PerlIO_setpos(PerlIO *f, SV *pos)
3190 Off_t *posn = (Off_t *) SvPV(pos,len);
3191 if (f && len == sizeof(Off_t))
3192 return PerlIO_seek(f,*posn,SEEK_SET);
3198 #undef PerlIO_setpos
3200 PerlIO_setpos(PerlIO *f, SV *pos)
3206 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3207 if (f && len == sizeof(Fpos_t))
3209 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3210 return fsetpos64(f, fpos);
3212 return fsetpos(f, fpos);
3222 #undef PerlIO_getpos
3224 PerlIO_getpos(PerlIO *f, SV *pos)
3227 Off_t posn = PerlIO_tell(f);
3228 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3229 return (posn == (Off_t)-1) ? -1 : 0;
3232 #undef PerlIO_getpos
3234 PerlIO_getpos(PerlIO *f, SV *pos)
3239 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3240 code = fgetpos64(f, &fpos);
3242 code = fgetpos(f, &fpos);
3244 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3249 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3252 vprintf(char *pat, char *args)
3254 _doprnt(pat, args, stdout);
3255 return 0; /* wrong, but perl doesn't use the return value */
3259 vfprintf(FILE *fd, char *pat, char *args)
3261 _doprnt(pat, args, fd);
3262 return 0; /* wrong, but perl doesn't use the return value */
3267 #ifndef PerlIO_vsprintf
3269 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3271 int val = vsprintf(s, fmt, ap);
3274 if (strlen(s) >= (STRLEN)n)
3277 (void)PerlIO_puts(Perl_error_log,
3278 "panic: sprintf overflow - memory corrupted!\n");
3286 #ifndef PerlIO_sprintf
3288 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3293 result = PerlIO_vsprintf(s, n, fmt, ap);