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)
1053 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1055 Off_t old = PerlIO_tell(f);
1057 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1058 done = PerlIOBuf_unread(f,vbuf,count);
1059 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1064 PerlIOBase_noop_ok(PerlIO *f)
1070 PerlIOBase_noop_fail(PerlIO *f)
1076 PerlIOBase_close(PerlIO *f)
1079 PerlIO *n = PerlIONext(f);
1080 if (PerlIO_flush(f) != 0)
1082 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1084 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1089 PerlIOBase_eof(PerlIO *f)
1093 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1099 PerlIOBase_error(PerlIO *f)
1103 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1109 PerlIOBase_clearerr(PerlIO *f)
1113 PerlIO *n = PerlIONext(f);
1114 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1121 PerlIOBase_setlinebuf(PerlIO *f)
1126 /*--------------------------------------------------------------------------------------*/
1127 /* Bottom-most level for UNIX-like case */
1131 struct _PerlIO base; /* The generic part */
1132 int fd; /* UNIX like file descriptor */
1133 int oflags; /* open/fcntl flags */
1137 PerlIOUnix_oflags(const char *mode)
1152 oflags = O_CREAT|O_TRUNC;
1163 oflags = O_CREAT|O_APPEND;
1179 else if (*mode == 't')
1182 oflags &= ~O_BINARY;
1185 /* Always open in binary mode */
1187 if (*mode || oflags == -1)
1196 PerlIOUnix_fileno(PerlIO *f)
1198 return PerlIOSelf(f,PerlIOUnix)->fd;
1202 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1210 int oflags = PerlIOUnix_oflags(mode);
1213 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1216 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1223 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1227 int oflags = PerlIOUnix_oflags(mode);
1230 int fd = PerlLIO_open3(path,oflags,0666);
1233 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1236 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1243 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1245 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1246 int oflags = PerlIOUnix_oflags(mode);
1247 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1248 (*PerlIOBase(f)->tab->Close)(f);
1252 int fd = PerlLIO_open3(path,oflags,0666);
1257 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1265 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1268 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1269 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1273 SSize_t len = PerlLIO_read(fd,vbuf,count);
1274 if (len >= 0 || errno != EINTR)
1277 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1278 else if (len == 0 && count != 0)
1279 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1286 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1289 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1292 SSize_t len = PerlLIO_write(fd,vbuf,count);
1293 if (len >= 0 || errno != EINTR)
1296 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1303 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1306 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1307 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1308 return (new == (Off_t) -1) ? -1 : 0;
1312 PerlIOUnix_tell(PerlIO *f)
1315 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1316 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1320 PerlIOUnix_close(PerlIO *f)
1323 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1325 while (PerlLIO_close(fd) != 0)
1335 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1340 PerlIO_funcs PerlIO_unix = {
1356 PerlIOBase_noop_ok, /* flush */
1357 PerlIOBase_noop_fail, /* fill */
1360 PerlIOBase_clearerr,
1361 PerlIOBase_setlinebuf,
1362 NULL, /* get_base */
1363 NULL, /* get_bufsiz */
1366 NULL, /* set_ptrcnt */
1369 /*--------------------------------------------------------------------------------------*/
1370 /* stdio as a layer */
1374 struct _PerlIO base;
1375 FILE * stdio; /* The stream */
1379 PerlIOStdio_fileno(PerlIO *f)
1382 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1386 PerlIOStdio_mode(const char *mode,char *tmode)
1393 if (O_BINARY != O_TEXT)
1402 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1421 stdio = PerlSIO_stdin;
1424 stdio = PerlSIO_stdout;
1427 stdio = PerlSIO_stderr;
1433 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1437 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1444 #undef PerlIO_importFILE
1446 PerlIO_importFILE(FILE *stdio, int fl)
1452 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1459 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1463 FILE *stdio = PerlSIO_fopen(path,mode);
1467 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1468 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1476 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1479 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1481 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1489 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1492 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1496 STDCHAR *buf = (STDCHAR *) vbuf;
1497 /* Perl is expecting PerlIO_getc() to fill the buffer
1498 * Linux's stdio does not do that for fread()
1500 int ch = PerlSIO_fgetc(s);
1508 got = PerlSIO_fread(vbuf,1,count,s);
1513 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1516 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1517 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1521 int ch = *buf-- & 0xff;
1522 if (PerlSIO_ungetc(ch,s) != ch)
1531 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1534 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1538 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1541 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1542 return PerlSIO_fseek(stdio,offset,whence);
1546 PerlIOStdio_tell(PerlIO *f)
1549 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1550 return PerlSIO_ftell(stdio);
1554 PerlIOStdio_close(PerlIO *f)
1558 int optval, optlen = sizeof(int);
1560 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1563 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1564 PerlSIO_fclose(stdio) :
1565 close(PerlIO_fileno(f))
1567 PerlSIO_fclose(stdio)
1574 PerlIOStdio_flush(PerlIO *f)
1577 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1578 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1580 return PerlSIO_fflush(stdio);
1585 /* FIXME: This discards ungetc() and pre-read stuff which is
1586 not right if this is just a "sync" from a layer above
1587 Suspect right design is to do _this_ but not have layer above
1588 flush this layer read-to-read
1590 /* Not writeable - sync by attempting a seek */
1592 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1600 PerlIOStdio_fill(PerlIO *f)
1603 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1605 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1606 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1608 if (PerlSIO_fflush(stdio) != 0)
1611 c = PerlSIO_fgetc(stdio);
1612 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1618 PerlIOStdio_eof(PerlIO *f)
1621 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1625 PerlIOStdio_error(PerlIO *f)
1628 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1632 PerlIOStdio_clearerr(PerlIO *f)
1635 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1639 PerlIOStdio_setlinebuf(PerlIO *f)
1642 #ifdef HAS_SETLINEBUF
1643 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1645 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1651 PerlIOStdio_get_base(PerlIO *f)
1654 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1655 return PerlSIO_get_base(stdio);
1659 PerlIOStdio_get_bufsiz(PerlIO *f)
1662 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1663 return PerlSIO_get_bufsiz(stdio);
1667 #ifdef USE_STDIO_PTR
1669 PerlIOStdio_get_ptr(PerlIO *f)
1672 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1673 return PerlSIO_get_ptr(stdio);
1677 PerlIOStdio_get_cnt(PerlIO *f)
1680 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1681 return PerlSIO_get_cnt(stdio);
1685 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1688 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1691 #ifdef STDIO_PTR_LVALUE
1692 PerlSIO_set_ptr(stdio,ptr);
1693 #ifdef STDIO_PTR_LVAL_SETS_CNT
1694 if (PerlSIO_get_cnt(stdio) != (cnt))
1697 assert(PerlSIO_get_cnt(stdio) == (cnt));
1700 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1701 /* Setting ptr _does_ change cnt - we are done */
1704 #else /* STDIO_PTR_LVALUE */
1706 #endif /* STDIO_PTR_LVALUE */
1708 /* Now (or only) set cnt */
1709 #ifdef STDIO_CNT_LVALUE
1710 PerlSIO_set_cnt(stdio,cnt);
1711 #else /* STDIO_CNT_LVALUE */
1712 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1713 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1714 #else /* STDIO_PTR_LVAL_SETS_CNT */
1716 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1717 #endif /* STDIO_CNT_LVALUE */
1722 PerlIO_funcs PerlIO_stdio = {
1724 sizeof(PerlIOStdio),
1742 PerlIOStdio_clearerr,
1743 PerlIOStdio_setlinebuf,
1745 PerlIOStdio_get_base,
1746 PerlIOStdio_get_bufsiz,
1751 #ifdef USE_STDIO_PTR
1752 PerlIOStdio_get_ptr,
1753 PerlIOStdio_get_cnt,
1754 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1755 PerlIOStdio_set_ptrcnt
1756 #else /* STDIO_PTR_LVALUE */
1758 #endif /* STDIO_PTR_LVALUE */
1759 #else /* USE_STDIO_PTR */
1763 #endif /* USE_STDIO_PTR */
1766 #undef PerlIO_exportFILE
1768 PerlIO_exportFILE(PerlIO *f, int fl)
1771 /* Should really push stdio discipline when we have them */
1772 return fdopen(PerlIO_fileno(f),"r+");
1775 #undef PerlIO_findFILE
1777 PerlIO_findFILE(PerlIO *f)
1779 return PerlIO_exportFILE(f,0);
1782 #undef PerlIO_releaseFILE
1784 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1788 /*--------------------------------------------------------------------------------------*/
1789 /* perlio buffer layer */
1792 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1794 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1795 b->posn = PerlIO_tell(PerlIONext(f));
1796 return PerlIOBase_pushed(f,mode,arg,len);
1800 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1803 PerlIO_funcs *tab = PerlIO_default_btm();
1811 #if O_BINARY != O_TEXT
1812 /* do something about failing setmode()? --jhi */
1813 PerlLIO_setmode(fd, O_BINARY);
1815 f = (*tab->Fdopen)(tab,fd,mode);
1818 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1819 if (init && fd == 2)
1821 /* Initial stderr is unbuffered */
1822 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1825 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1826 self->name,f,fd,mode,PerlIOBase(f)->flags);
1833 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1835 PerlIO_funcs *tab = PerlIO_default_btm();
1836 PerlIO *f = (*tab->Open)(tab,path,mode);
1839 PerlIO_push(f,self,mode,Nullch,0);
1845 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1847 PerlIO *next = PerlIONext(f);
1848 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1850 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
1854 /* This "flush" is akin to sfio's sync in that it handles files in either
1858 PerlIOBuf_flush(PerlIO *f)
1860 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1862 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1864 /* write() the buffer */
1865 STDCHAR *buf = b->buf;
1868 PerlIO *n = PerlIONext(f);
1871 count = PerlIO_write(n,p,b->ptr - p);
1876 else if (count < 0 || PerlIO_error(n))
1878 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1883 b->posn += (p - buf);
1885 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1887 STDCHAR *buf = PerlIO_get_base(f);
1888 /* Note position change */
1889 b->posn += (b->ptr - buf);
1890 if (b->ptr < b->end)
1892 /* We did not consume all of it */
1893 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1895 b->posn = PerlIO_tell(PerlIONext(f));
1899 b->ptr = b->end = b->buf;
1900 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1901 /* FIXME: Is this right for read case ? */
1902 if (PerlIO_flush(PerlIONext(f)) != 0)
1908 PerlIOBuf_fill(PerlIO *f)
1910 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1911 PerlIO *n = PerlIONext(f);
1913 /* FIXME: doing the down-stream flush is a bad idea if it causes
1914 pre-read data in stdio buffer to be discarded
1915 but this is too simplistic - as it skips _our_ hosekeeping
1916 and breaks tell tests.
1917 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1921 if (PerlIO_flush(f) != 0)
1925 PerlIO_get_base(f); /* allocate via vtable */
1927 b->ptr = b->end = b->buf;
1928 if (PerlIO_fast_gets(n))
1930 /* Layer below is also buffered
1931 * We do _NOT_ want to call its ->Read() because that will loop
1932 * till it gets what we asked for which may hang on a pipe etc.
1933 * Instead take anything it has to hand, or ask it to fill _once_.
1935 avail = PerlIO_get_cnt(n);
1938 avail = PerlIO_fill(n);
1940 avail = PerlIO_get_cnt(n);
1943 if (!PerlIO_error(n) && PerlIO_eof(n))
1949 STDCHAR *ptr = PerlIO_get_ptr(n);
1950 SSize_t cnt = avail;
1951 if (avail > b->bufsiz)
1953 Copy(ptr,b->buf,avail,STDCHAR);
1954 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1959 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1964 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1966 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1969 b->end = b->buf+avail;
1970 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1975 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1977 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1978 STDCHAR *buf = (STDCHAR *) vbuf;
1983 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1987 SSize_t avail = PerlIO_get_cnt(f);
1988 SSize_t take = (count < avail) ? count : avail;
1991 STDCHAR *ptr = PerlIO_get_ptr(f);
1992 Copy(ptr,buf,take,STDCHAR);
1993 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1997 if (count > 0 && avail <= 0)
1999 if (PerlIO_fill(f) != 0)
2003 return (buf - (STDCHAR *) vbuf);
2009 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2011 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2012 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2015 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2021 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2023 avail = (b->ptr - b->buf);
2028 b->end = b->buf + avail;
2030 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2031 b->posn -= b->bufsiz;
2033 if (avail > (SSize_t) count)
2041 Copy(buf,b->ptr,avail,STDCHAR);
2045 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2052 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2054 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2055 const STDCHAR *buf = (const STDCHAR *) vbuf;
2059 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2063 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2064 if ((SSize_t) count < avail)
2066 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2067 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2087 Copy(buf,b->ptr,avail,STDCHAR);
2094 if (b->ptr >= (b->buf + b->bufsiz))
2097 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2103 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2106 if ((code = PerlIO_flush(f)) == 0)
2108 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2109 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2110 code = PerlIO_seek(PerlIONext(f),offset,whence);
2113 b->posn = PerlIO_tell(PerlIONext(f));
2120 PerlIOBuf_tell(PerlIO *f)
2122 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2123 Off_t posn = b->posn;
2125 posn += (b->ptr - b->buf);
2130 PerlIOBuf_close(PerlIO *f)
2133 IV code = PerlIOBase_close(f);
2134 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2135 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2137 PerlMemShared_free(b->buf);
2140 b->ptr = b->end = b->buf;
2141 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2146 PerlIOBuf_setlinebuf(PerlIO *f)
2150 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2155 PerlIOBuf_get_ptr(PerlIO *f)
2157 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2164 PerlIOBuf_get_cnt(PerlIO *f)
2166 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2169 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2170 return (b->end - b->ptr);
2175 PerlIOBuf_get_base(PerlIO *f)
2177 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2183 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2186 b->buf = (STDCHAR *)&b->oneword;
2187 b->bufsiz = sizeof(b->oneword);
2196 PerlIOBuf_bufsiz(PerlIO *f)
2198 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2201 return (b->end - b->buf);
2205 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2207 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2211 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2214 assert(PerlIO_get_cnt(f) == cnt);
2215 assert(b->ptr >= b->buf);
2217 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2220 PerlIO_funcs PerlIO_perlio = {
2240 PerlIOBase_clearerr,
2241 PerlIOBuf_setlinebuf,
2246 PerlIOBuf_set_ptrcnt,
2249 /*--------------------------------------------------------------------------------------*/
2250 /* Temp layer to hold unread chars when cannot do it any other way */
2253 PerlIOPending_fill(PerlIO *f)
2255 /* Should never happen */
2261 PerlIOPending_close(PerlIO *f)
2263 /* A tad tricky - flush pops us, then we close new top */
2265 return PerlIO_close(f);
2269 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2271 /* A tad tricky - flush pops us, then we seek new top */
2273 return PerlIO_seek(f,offset,whence);
2278 PerlIOPending_flush(PerlIO *f)
2280 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2281 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2284 PerlMemShared_free(b->buf);
2292 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2300 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2305 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2307 IV code = PerlIOBase_pushed(f,mode,arg,len);
2308 PerlIOl *l = PerlIOBase(f);
2309 /* Our PerlIO_fast_gets must match what we are pushed on,
2310 or sv_gets() etc. get muddled when it changes mid-string
2313 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2314 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2319 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2321 SSize_t avail = PerlIO_get_cnt(f);
2326 got = PerlIOBuf_read(f,vbuf,avail);
2328 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2333 PerlIO_funcs PerlIO_pending = {
2341 PerlIOPending_pushed,
2348 PerlIOPending_close,
2349 PerlIOPending_flush,
2353 PerlIOBase_clearerr,
2354 PerlIOBuf_setlinebuf,
2359 PerlIOPending_set_ptrcnt,
2364 /*--------------------------------------------------------------------------------------*/
2365 /* crlf - translation
2366 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2367 to hand back a line at a time and keeping a record of which nl we "lied" about.
2368 On write translate "\n" to CR,LF
2373 PerlIOBuf base; /* PerlIOBuf stuff */
2374 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2378 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2381 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2382 code = PerlIOBuf_pushed(f,mode,arg,len);
2384 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2385 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2386 PerlIOBase(f)->flags);
2393 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2395 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2401 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2402 return PerlIOBuf_unread(f,vbuf,count);
2405 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2406 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2408 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2414 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2416 b->end = b->ptr = b->buf + b->bufsiz;
2417 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2418 b->posn -= b->bufsiz;
2420 while (count > 0 && b->ptr > b->buf)
2425 if (b->ptr - 2 >= b->buf)
2451 PerlIOCrlf_get_cnt(PerlIO *f)
2453 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2456 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2458 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2459 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2461 STDCHAR *nl = b->ptr;
2463 while (nl < b->end && *nl != 0xd)
2465 if (nl < b->end && *nl == 0xd)
2477 /* Not CR,LF but just CR */
2484 /* Blast - found CR as last char in buffer */
2487 /* They may not care, defer work as long as possible */
2488 return (nl - b->ptr);
2494 b->ptr++; /* say we have read it as far as flush() is concerned */
2495 b->buf++; /* Leave space an front of buffer */
2496 b->bufsiz--; /* Buffer is thus smaller */
2497 code = PerlIO_fill(f); /* Fetch some more */
2498 b->bufsiz++; /* Restore size for next time */
2499 b->buf--; /* Point at space */
2500 b->ptr = nl = b->buf; /* Which is what we hand off */
2501 b->posn--; /* Buffer starts here */
2502 *nl = 0xd; /* Fill in the CR */
2504 goto test; /* fill() call worked */
2505 /* CR at EOF - just fall through */
2510 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2516 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2518 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2519 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2520 IV flags = PerlIOBase(f)->flags;
2530 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2537 /* Test code - delete when it works ... */
2544 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2552 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2553 ptr, chk, flags, c->nl, b->end, cnt);
2560 /* They have taken what we lied about */
2567 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2571 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2573 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2574 return PerlIOBuf_write(f,vbuf,count);
2577 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2578 const STDCHAR *buf = (const STDCHAR *) vbuf;
2579 const STDCHAR *ebuf = buf+count;
2582 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2586 STDCHAR *eptr = b->buf+b->bufsiz;
2587 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2588 while (buf < ebuf && b->ptr < eptr)
2592 if ((b->ptr + 2) > eptr)
2594 /* Not room for both */
2600 *(b->ptr)++ = 0xd; /* CR */
2601 *(b->ptr)++ = 0xa; /* LF */
2603 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2622 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2624 return (buf - (STDCHAR *) vbuf);
2629 PerlIOCrlf_flush(PerlIO *f)
2631 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2637 return PerlIOBuf_flush(f);
2640 PerlIO_funcs PerlIO_crlf = {
2643 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2649 PerlIOBase_noop_ok, /* popped */
2650 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2651 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2652 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2660 PerlIOBase_clearerr,
2661 PerlIOBuf_setlinebuf,
2666 PerlIOCrlf_set_ptrcnt,
2670 /*--------------------------------------------------------------------------------------*/
2671 /* mmap as "buffer" layer */
2675 PerlIOBuf base; /* PerlIOBuf stuff */
2676 Mmap_t mptr; /* Mapped address */
2677 Size_t len; /* mapped length */
2678 STDCHAR *bbuf; /* malloced buffer if map fails */
2681 static size_t page_size = 0;
2684 PerlIOMmap_map(PerlIO *f)
2687 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2688 PerlIOBuf *b = &m->base;
2689 IV flags = PerlIOBase(f)->flags;
2693 if (flags & PERLIO_F_CANREAD)
2695 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2696 int fd = PerlIO_fileno(f);
2698 code = fstat(fd,&st);
2699 if (code == 0 && S_ISREG(st.st_mode))
2701 SSize_t len = st.st_size - b->posn;
2706 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2708 SETERRNO(0,SS$_NORMAL);
2709 # ifdef _SC_PAGESIZE
2710 page_size = sysconf(_SC_PAGESIZE);
2712 page_size = sysconf(_SC_PAGE_SIZE);
2714 if ((long)page_size < 0) {
2719 (void)SvUPGRADE(error, SVt_PV);
2720 msg = SvPVx(error, n_a);
2721 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2724 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2728 # ifdef HAS_GETPAGESIZE
2729 page_size = getpagesize();
2731 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2732 page_size = PAGESIZE; /* compiletime, bad */
2736 if ((IV)page_size <= 0)
2737 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2741 /* This is a hack - should never happen - open should have set it ! */
2742 b->posn = PerlIO_tell(PerlIONext(f));
2744 posn = (b->posn / page_size) * page_size;
2745 len = st.st_size - posn;
2746 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2747 if (m->mptr && m->mptr != (Mmap_t) -1)
2749 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2750 madvise(m->mptr, len, MADV_SEQUENTIAL);
2752 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2753 madvise(m->mptr, len, MADV_WILLNEED);
2755 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2756 b->end = ((STDCHAR *)m->mptr) + len;
2757 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2768 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2770 b->ptr = b->end = b->ptr;
2779 PerlIOMmap_unmap(PerlIO *f)
2781 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2782 PerlIOBuf *b = &m->base;
2788 code = munmap(m->mptr, m->len);
2792 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2795 b->ptr = b->end = b->buf;
2796 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2802 PerlIOMmap_get_base(PerlIO *f)
2804 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2805 PerlIOBuf *b = &m->base;
2806 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2808 /* Already have a readbuffer in progress */
2813 /* We have a write buffer or flushed PerlIOBuf read buffer */
2814 m->bbuf = b->buf; /* save it in case we need it again */
2815 b->buf = NULL; /* Clear to trigger below */
2819 PerlIOMmap_map(f); /* Try and map it */
2822 /* Map did not work - recover PerlIOBuf buffer if we have one */
2826 b->ptr = b->end = b->buf;
2829 return PerlIOBuf_get_base(f);
2833 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2835 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2836 PerlIOBuf *b = &m->base;
2837 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2839 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2842 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2847 /* Loose the unwritable mapped buffer */
2849 /* If flush took the "buffer" see if we have one from before */
2850 if (!b->buf && m->bbuf)
2854 PerlIOBuf_get_base(f);
2858 return PerlIOBuf_unread(f,vbuf,count);
2862 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2864 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2865 PerlIOBuf *b = &m->base;
2866 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2868 /* No, or wrong sort of, buffer */
2871 if (PerlIOMmap_unmap(f) != 0)
2874 /* If unmap took the "buffer" see if we have one from before */
2875 if (!b->buf && m->bbuf)
2879 PerlIOBuf_get_base(f);
2883 return PerlIOBuf_write(f,vbuf,count);
2887 PerlIOMmap_flush(PerlIO *f)
2889 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2890 PerlIOBuf *b = &m->base;
2891 IV code = PerlIOBuf_flush(f);
2892 /* Now we are "synced" at PerlIOBuf level */
2897 /* Unmap the buffer */
2898 if (PerlIOMmap_unmap(f) != 0)
2903 /* We seem to have a PerlIOBuf buffer which was not mapped
2904 * remember it in case we need one later
2913 PerlIOMmap_fill(PerlIO *f)
2915 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2916 IV code = PerlIO_flush(f);
2917 if (code == 0 && !b->buf)
2919 code = PerlIOMmap_map(f);
2921 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2923 code = PerlIOBuf_fill(f);
2929 PerlIOMmap_close(PerlIO *f)
2931 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2932 PerlIOBuf *b = &m->base;
2933 IV code = PerlIO_flush(f);
2938 b->ptr = b->end = b->buf;
2940 if (PerlIOBuf_close(f) != 0)
2946 PerlIO_funcs PerlIO_mmap = {
2966 PerlIOBase_clearerr,
2967 PerlIOBuf_setlinebuf,
2968 PerlIOMmap_get_base,
2972 PerlIOBuf_set_ptrcnt,
2975 #endif /* HAS_MMAP */
2983 atexit(&PerlIO_cleanup);
2993 PerlIO_stdstreams();
2997 #undef PerlIO_stdout
3002 PerlIO_stdstreams();
3006 #undef PerlIO_stderr
3011 PerlIO_stdstreams();
3015 /*--------------------------------------------------------------------------------------*/
3017 #undef PerlIO_getname
3019 PerlIO_getname(PerlIO *f, char *buf)
3022 Perl_croak(aTHX_ "Don't know how to get file name");
3027 /*--------------------------------------------------------------------------------------*/
3028 /* Functions which can be called on any kind of PerlIO implemented
3034 PerlIO_getc(PerlIO *f)
3037 SSize_t count = PerlIO_read(f,buf,1);
3040 return (unsigned char) buf[0];
3045 #undef PerlIO_ungetc
3047 PerlIO_ungetc(PerlIO *f, int ch)
3052 if (PerlIO_unread(f,&buf,1) == 1)
3060 PerlIO_putc(PerlIO *f, int ch)
3063 return PerlIO_write(f,&buf,1);
3068 PerlIO_puts(PerlIO *f, const char *s)
3070 STRLEN len = strlen(s);
3071 return PerlIO_write(f,s,len);
3074 #undef PerlIO_rewind
3076 PerlIO_rewind(PerlIO *f)
3078 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3082 #undef PerlIO_vprintf
3084 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3087 SV *sv = newSVpvn("",0);
3092 Perl_va_copy(ap, apc);
3093 sv_vcatpvf(sv, fmt, &apc);
3095 sv_vcatpvf(sv, fmt, &ap);
3098 return PerlIO_write(f,s,len);
3101 #undef PerlIO_printf
3103 PerlIO_printf(PerlIO *f,const char *fmt,...)
3108 result = PerlIO_vprintf(f,fmt,ap);
3113 #undef PerlIO_stdoutf
3115 PerlIO_stdoutf(const char *fmt,...)
3120 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3125 #undef PerlIO_tmpfile
3127 PerlIO_tmpfile(void)
3129 /* I have no idea how portable mkstemp() is ... */
3130 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3133 FILE *stdio = PerlSIO_tmpfile();
3136 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3142 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3143 int fd = mkstemp(SvPVX(sv));
3147 f = PerlIO_fdopen(fd,"w+");
3150 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3152 PerlLIO_unlink(SvPVX(sv));
3162 #endif /* USE_SFIO */
3163 #endif /* PERLIO_IS_STDIO */
3165 /*======================================================================================*/
3166 /* Now some functions in terms of above which may be needed even if
3167 we are not in true PerlIO mode
3171 #undef PerlIO_setpos
3173 PerlIO_setpos(PerlIO *f, SV *pos)
3179 Off_t *posn = (Off_t *) SvPV(pos,len);
3180 if (f && len == sizeof(Off_t))
3181 return PerlIO_seek(f,*posn,SEEK_SET);
3187 #undef PerlIO_setpos
3189 PerlIO_setpos(PerlIO *f, SV *pos)
3195 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3196 if (f && len == sizeof(Fpos_t))
3198 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3199 return fsetpos64(f, fpos);
3201 return fsetpos(f, fpos);
3211 #undef PerlIO_getpos
3213 PerlIO_getpos(PerlIO *f, SV *pos)
3216 Off_t posn = PerlIO_tell(f);
3217 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3218 return (posn == (Off_t)-1) ? -1 : 0;
3221 #undef PerlIO_getpos
3223 PerlIO_getpos(PerlIO *f, SV *pos)
3228 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3229 code = fgetpos64(f, &fpos);
3231 code = fgetpos(f, &fpos);
3233 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3238 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3241 vprintf(char *pat, char *args)
3243 _doprnt(pat, args, stdout);
3244 return 0; /* wrong, but perl doesn't use the return value */
3248 vfprintf(FILE *fd, char *pat, char *args)
3250 _doprnt(pat, args, fd);
3251 return 0; /* wrong, but perl doesn't use the return value */
3256 #ifndef PerlIO_vsprintf
3258 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3260 int val = vsprintf(s, fmt, ap);
3263 if (strlen(s) >= (STRLEN)n)
3266 (void)PerlIO_puts(Perl_error_log,
3267 "panic: sprintf overflow - memory corrupted!\n");
3275 #ifndef PerlIO_sprintf
3277 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3282 result = PerlIO_vsprintf(s, n, fmt, ap);