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 = PerlIO_get_base(f);
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);
1925 /* FIXME: doing the down-stream flush is a bad idea if it causes
1926 pre-read data in stdio buffer to be discarded
1927 but this is too simplistic - as it skips _our_ hosekeeping
1928 and breaks tell tests.
1929 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1933 if (PerlIO_flush(f) != 0)
1936 b->ptr = b->end = buf = PerlIO_get_base(f);
1937 if (PerlIO_fast_gets(n))
1939 /* Layer below is also buffered
1940 * We do _NOT_ want to call its ->Read() because that will loop
1941 * till it gets what we asked for which may hang on a pipe etc.
1942 * Instead take anything it has to hand, or ask it to fill _once_.
1944 avail = PerlIO_get_cnt(n);
1947 avail = PerlIO_fill(n);
1949 avail = PerlIO_get_cnt(n);
1952 if (!PerlIO_error(n) && PerlIO_eof(n))
1958 STDCHAR *ptr = PerlIO_get_ptr(n);
1959 SSize_t cnt = avail;
1960 if (avail > b->bufsiz)
1962 Copy(ptr,b->buf,avail,STDCHAR);
1963 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1968 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1973 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1975 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1979 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1984 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1986 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1987 STDCHAR *buf = (STDCHAR *) vbuf;
1992 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1996 SSize_t avail = PerlIO_get_cnt(f);
1997 SSize_t take = (count < avail) ? count : avail;
2000 STDCHAR *ptr = PerlIO_get_ptr(f);
2001 Copy(ptr,buf,take,STDCHAR);
2002 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2006 if (count > 0 && avail <= 0)
2008 if (PerlIO_fill(f) != 0)
2012 return (buf - (STDCHAR *) vbuf);
2018 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2020 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2021 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2024 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2030 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2032 avail = (b->ptr - b->buf);
2037 b->end = b->buf + avail;
2039 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2040 b->posn -= b->bufsiz;
2042 if (avail > (SSize_t) count)
2050 Copy(buf,b->ptr,avail,STDCHAR);
2054 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2061 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2063 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2064 const STDCHAR *buf = (const STDCHAR *) vbuf;
2068 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2072 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2073 if ((SSize_t) count < avail)
2075 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2076 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2096 Copy(buf,b->ptr,avail,STDCHAR);
2103 if (b->ptr >= (b->buf + b->bufsiz))
2106 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2112 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2115 if ((code = PerlIO_flush(f)) == 0)
2117 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2118 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2119 code = PerlIO_seek(PerlIONext(f),offset,whence);
2122 b->posn = PerlIO_tell(PerlIONext(f));
2129 PerlIOBuf_tell(PerlIO *f)
2131 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2132 Off_t posn = b->posn;
2134 posn += (b->ptr - b->buf);
2139 PerlIOBuf_close(PerlIO *f)
2142 IV code = PerlIOBase_close(f);
2143 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2144 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2146 PerlMemShared_free(b->buf);
2149 b->ptr = b->end = b->buf;
2150 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2155 PerlIOBuf_setlinebuf(PerlIO *f)
2159 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2164 PerlIOBuf_get_ptr(PerlIO *f)
2166 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2173 PerlIOBuf_get_cnt(PerlIO *f)
2175 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2178 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2179 return (b->end - b->ptr);
2184 PerlIOBuf_get_base(PerlIO *f)
2186 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2192 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2195 b->buf = (STDCHAR *)&b->oneword;
2196 b->bufsiz = sizeof(b->oneword);
2205 PerlIOBuf_bufsiz(PerlIO *f)
2207 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2210 return (b->end - b->buf);
2214 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2216 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2220 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2223 assert(PerlIO_get_cnt(f) == cnt);
2224 assert(b->ptr >= b->buf);
2226 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2229 PerlIO_funcs PerlIO_perlio = {
2249 PerlIOBase_clearerr,
2250 PerlIOBuf_setlinebuf,
2255 PerlIOBuf_set_ptrcnt,
2258 /*--------------------------------------------------------------------------------------*/
2259 /* Temp layer to hold unread chars when cannot do it any other way */
2262 PerlIOPending_fill(PerlIO *f)
2264 /* Should never happen */
2270 PerlIOPending_close(PerlIO *f)
2272 /* A tad tricky - flush pops us, then we close new top */
2274 return PerlIO_close(f);
2278 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2280 /* A tad tricky - flush pops us, then we seek new top */
2282 return PerlIO_seek(f,offset,whence);
2287 PerlIOPending_flush(PerlIO *f)
2289 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2290 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2293 PerlMemShared_free(b->buf);
2301 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2309 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2314 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2316 IV code = PerlIOBuf_pushed(f,mode,arg,len);
2317 PerlIOl *l = PerlIOBase(f);
2318 /* Our PerlIO_fast_gets must match what we are pushed on,
2319 or sv_gets() etc. get muddled when it changes mid-string
2322 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2323 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2328 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2330 SSize_t avail = PerlIO_get_cnt(f);
2335 got = PerlIOBuf_read(f,vbuf,avail);
2337 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2342 PerlIO_funcs PerlIO_pending = {
2350 PerlIOPending_pushed,
2357 PerlIOPending_close,
2358 PerlIOPending_flush,
2362 PerlIOBase_clearerr,
2363 PerlIOBuf_setlinebuf,
2368 PerlIOPending_set_ptrcnt,
2373 /*--------------------------------------------------------------------------------------*/
2374 /* crlf - translation
2375 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2376 to hand back a line at a time and keeping a record of which nl we "lied" about.
2377 On write translate "\n" to CR,LF
2382 PerlIOBuf base; /* PerlIOBuf stuff */
2383 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2387 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2390 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2391 code = PerlIOBuf_pushed(f,mode,arg,len);
2393 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2394 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2395 PerlIOBase(f)->flags);
2402 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2404 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2410 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2411 return PerlIOBuf_unread(f,vbuf,count);
2414 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2415 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2417 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2423 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2425 b->end = b->ptr = b->buf + b->bufsiz;
2426 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2427 b->posn -= b->bufsiz;
2429 while (count > 0 && b->ptr > b->buf)
2434 if (b->ptr - 2 >= b->buf)
2460 PerlIOCrlf_get_cnt(PerlIO *f)
2462 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2465 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2467 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2468 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2470 STDCHAR *nl = b->ptr;
2472 while (nl < b->end && *nl != 0xd)
2474 if (nl < b->end && *nl == 0xd)
2486 /* Not CR,LF but just CR */
2493 /* Blast - found CR as last char in buffer */
2496 /* They may not care, defer work as long as possible */
2497 return (nl - b->ptr);
2503 b->ptr++; /* say we have read it as far as flush() is concerned */
2504 b->buf++; /* Leave space an front of buffer */
2505 b->bufsiz--; /* Buffer is thus smaller */
2506 code = PerlIO_fill(f); /* Fetch some more */
2507 b->bufsiz++; /* Restore size for next time */
2508 b->buf--; /* Point at space */
2509 b->ptr = nl = b->buf; /* Which is what we hand off */
2510 b->posn--; /* Buffer starts here */
2511 *nl = 0xd; /* Fill in the CR */
2513 goto test; /* fill() call worked */
2514 /* CR at EOF - just fall through */
2519 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2525 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2527 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2528 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2529 IV flags = PerlIOBase(f)->flags;
2539 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2546 /* Test code - delete when it works ... */
2553 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2561 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2562 ptr, chk, flags, c->nl, b->end, cnt);
2569 /* They have taken what we lied about */
2576 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2580 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2582 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2583 return PerlIOBuf_write(f,vbuf,count);
2586 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2587 const STDCHAR *buf = (const STDCHAR *) vbuf;
2588 const STDCHAR *ebuf = buf+count;
2591 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2595 STDCHAR *eptr = b->buf+b->bufsiz;
2596 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2597 while (buf < ebuf && b->ptr < eptr)
2601 if ((b->ptr + 2) > eptr)
2603 /* Not room for both */
2609 *(b->ptr)++ = 0xd; /* CR */
2610 *(b->ptr)++ = 0xa; /* LF */
2612 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2631 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2633 return (buf - (STDCHAR *) vbuf);
2638 PerlIOCrlf_flush(PerlIO *f)
2640 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2646 return PerlIOBuf_flush(f);
2649 PerlIO_funcs PerlIO_crlf = {
2652 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2658 PerlIOBase_noop_ok, /* popped */
2659 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2660 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2661 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2669 PerlIOBase_clearerr,
2670 PerlIOBuf_setlinebuf,
2675 PerlIOCrlf_set_ptrcnt,
2679 /*--------------------------------------------------------------------------------------*/
2680 /* mmap as "buffer" layer */
2684 PerlIOBuf base; /* PerlIOBuf stuff */
2685 Mmap_t mptr; /* Mapped address */
2686 Size_t len; /* mapped length */
2687 STDCHAR *bbuf; /* malloced buffer if map fails */
2690 static size_t page_size = 0;
2693 PerlIOMmap_map(PerlIO *f)
2696 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2697 PerlIOBuf *b = &m->base;
2698 IV flags = PerlIOBase(f)->flags;
2702 if (flags & PERLIO_F_CANREAD)
2704 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2705 int fd = PerlIO_fileno(f);
2707 code = fstat(fd,&st);
2708 if (code == 0 && S_ISREG(st.st_mode))
2710 SSize_t len = st.st_size - b->posn;
2715 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2717 SETERRNO(0,SS$_NORMAL);
2718 # ifdef _SC_PAGESIZE
2719 page_size = sysconf(_SC_PAGESIZE);
2721 page_size = sysconf(_SC_PAGE_SIZE);
2723 if ((long)page_size < 0) {
2728 (void)SvUPGRADE(error, SVt_PV);
2729 msg = SvPVx(error, n_a);
2730 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2733 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2737 # ifdef HAS_GETPAGESIZE
2738 page_size = getpagesize();
2740 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2741 page_size = PAGESIZE; /* compiletime, bad */
2745 if ((IV)page_size <= 0)
2746 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2750 /* This is a hack - should never happen - open should have set it ! */
2751 b->posn = PerlIO_tell(PerlIONext(f));
2753 posn = (b->posn / page_size) * page_size;
2754 len = st.st_size - posn;
2755 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2756 if (m->mptr && m->mptr != (Mmap_t) -1)
2758 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2759 madvise(m->mptr, len, MADV_SEQUENTIAL);
2761 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2762 b->end = ((STDCHAR *)m->mptr) + len;
2763 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2774 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2776 b->ptr = b->end = b->ptr;
2785 PerlIOMmap_unmap(PerlIO *f)
2787 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2788 PerlIOBuf *b = &m->base;
2794 code = munmap(m->mptr, m->len);
2798 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2801 b->ptr = b->end = b->buf;
2802 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2808 PerlIOMmap_get_base(PerlIO *f)
2810 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2811 PerlIOBuf *b = &m->base;
2812 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2814 /* Already have a readbuffer in progress */
2819 /* We have a write buffer or flushed PerlIOBuf read buffer */
2820 m->bbuf = b->buf; /* save it in case we need it again */
2821 b->buf = NULL; /* Clear to trigger below */
2825 PerlIOMmap_map(f); /* Try and map it */
2828 /* Map did not work - recover PerlIOBuf buffer if we have one */
2832 b->ptr = b->end = b->buf;
2835 return PerlIOBuf_get_base(f);
2839 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2841 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2842 PerlIOBuf *b = &m->base;
2843 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2845 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2848 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2853 /* Loose the unwritable mapped buffer */
2855 /* If flush took the "buffer" see if we have one from before */
2856 if (!b->buf && m->bbuf)
2860 PerlIOBuf_get_base(f);
2864 return PerlIOBuf_unread(f,vbuf,count);
2868 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2870 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2871 PerlIOBuf *b = &m->base;
2872 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2874 /* No, or wrong sort of, buffer */
2877 if (PerlIOMmap_unmap(f) != 0)
2880 /* If unmap took the "buffer" see if we have one from before */
2881 if (!b->buf && m->bbuf)
2885 PerlIOBuf_get_base(f);
2889 return PerlIOBuf_write(f,vbuf,count);
2893 PerlIOMmap_flush(PerlIO *f)
2895 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2896 PerlIOBuf *b = &m->base;
2897 IV code = PerlIOBuf_flush(f);
2898 /* Now we are "synced" at PerlIOBuf level */
2903 /* Unmap the buffer */
2904 if (PerlIOMmap_unmap(f) != 0)
2909 /* We seem to have a PerlIOBuf buffer which was not mapped
2910 * remember it in case we need one later
2919 PerlIOMmap_fill(PerlIO *f)
2921 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2922 IV code = PerlIO_flush(f);
2923 if (code == 0 && !b->buf)
2925 code = PerlIOMmap_map(f);
2927 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2929 code = PerlIOBuf_fill(f);
2935 PerlIOMmap_close(PerlIO *f)
2937 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2938 PerlIOBuf *b = &m->base;
2939 IV code = PerlIO_flush(f);
2944 b->ptr = b->end = b->buf;
2946 if (PerlIOBuf_close(f) != 0)
2952 PerlIO_funcs PerlIO_mmap = {
2972 PerlIOBase_clearerr,
2973 PerlIOBuf_setlinebuf,
2974 PerlIOMmap_get_base,
2978 PerlIOBuf_set_ptrcnt,
2981 #endif /* HAS_MMAP */
2989 atexit(&PerlIO_cleanup);
2999 PerlIO_stdstreams();
3003 #undef PerlIO_stdout
3008 PerlIO_stdstreams();
3012 #undef PerlIO_stderr
3017 PerlIO_stdstreams();
3021 /*--------------------------------------------------------------------------------------*/
3023 #undef PerlIO_getname
3025 PerlIO_getname(PerlIO *f, char *buf)
3028 Perl_croak(aTHX_ "Don't know how to get file name");
3033 /*--------------------------------------------------------------------------------------*/
3034 /* Functions which can be called on any kind of PerlIO implemented
3040 PerlIO_getc(PerlIO *f)
3043 SSize_t count = PerlIO_read(f,buf,1);
3046 return (unsigned char) buf[0];
3051 #undef PerlIO_ungetc
3053 PerlIO_ungetc(PerlIO *f, int ch)
3058 if (PerlIO_unread(f,&buf,1) == 1)
3066 PerlIO_putc(PerlIO *f, int ch)
3069 return PerlIO_write(f,&buf,1);
3074 PerlIO_puts(PerlIO *f, const char *s)
3076 STRLEN len = strlen(s);
3077 return PerlIO_write(f,s,len);
3080 #undef PerlIO_rewind
3082 PerlIO_rewind(PerlIO *f)
3084 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3088 #undef PerlIO_vprintf
3090 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3093 SV *sv = newSVpvn("",0);
3098 Perl_va_copy(ap, apc);
3099 sv_vcatpvf(sv, fmt, &apc);
3101 sv_vcatpvf(sv, fmt, &ap);
3104 return PerlIO_write(f,s,len);
3107 #undef PerlIO_printf
3109 PerlIO_printf(PerlIO *f,const char *fmt,...)
3114 result = PerlIO_vprintf(f,fmt,ap);
3119 #undef PerlIO_stdoutf
3121 PerlIO_stdoutf(const char *fmt,...)
3126 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3131 #undef PerlIO_tmpfile
3133 PerlIO_tmpfile(void)
3135 /* I have no idea how portable mkstemp() is ... */
3136 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3139 FILE *stdio = PerlSIO_tmpfile();
3142 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3148 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3149 int fd = mkstemp(SvPVX(sv));
3153 f = PerlIO_fdopen(fd,"w+");
3156 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3158 PerlLIO_unlink(SvPVX(sv));
3168 #endif /* USE_SFIO */
3169 #endif /* PERLIO_IS_STDIO */
3171 /*======================================================================================*/
3172 /* Now some functions in terms of above which may be needed even if
3173 we are not in true PerlIO mode
3177 #undef PerlIO_setpos
3179 PerlIO_setpos(PerlIO *f, SV *pos)
3185 Off_t *posn = (Off_t *) SvPV(pos,len);
3186 if (f && len == sizeof(Off_t))
3187 return PerlIO_seek(f,*posn,SEEK_SET);
3193 #undef PerlIO_setpos
3195 PerlIO_setpos(PerlIO *f, SV *pos)
3201 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3202 if (f && len == sizeof(Fpos_t))
3204 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3205 return fsetpos64(f, fpos);
3207 return fsetpos(f, fpos);
3217 #undef PerlIO_getpos
3219 PerlIO_getpos(PerlIO *f, SV *pos)
3222 Off_t posn = PerlIO_tell(f);
3223 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3224 return (posn == (Off_t)-1) ? -1 : 0;
3227 #undef PerlIO_getpos
3229 PerlIO_getpos(PerlIO *f, SV *pos)
3234 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3235 code = fgetpos64(f, &fpos);
3237 code = fgetpos(f, &fpos);
3239 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3244 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3247 vprintf(char *pat, char *args)
3249 _doprnt(pat, args, stdout);
3250 return 0; /* wrong, but perl doesn't use the return value */
3254 vfprintf(FILE *fd, char *pat, char *args)
3256 _doprnt(pat, args, fd);
3257 return 0; /* wrong, but perl doesn't use the return value */
3262 #ifndef PerlIO_vsprintf
3264 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3266 int val = vsprintf(s, fmt, ap);
3269 if (strlen(s) >= (STRLEN)n)
3272 (void)PerlIO_puts(Perl_error_log,
3273 "panic: sprintf overflow - memory corrupted!\n");
3281 #ifndef PerlIO_sprintf
3283 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3288 result = PerlIO_vsprintf(s, n, fmt, ap);