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)
37 perlsio_binmode(FILE *fp, int iotype, int mode)
39 /* This used to be contents of do_binmode in doio.c */
41 # if defined(atarist) || defined(__MINT__)
44 ((FILE*)fp)->_flag |= _IOBIN;
46 ((FILE*)fp)->_flag &= ~ _IOBIN;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
53 # if defined(WIN32) && defined(__BORLANDC__)
54 /* The translation mode of the stream is maintained independent
55 * of the translation mode of the fd in the Borland RTL (heavy
56 * digging through their runtime sources reveal). User has to
57 * set the mode explicitly for the stream (though they don't
58 * document this anywhere). GSAR 97-5-24
64 fp->flags &= ~ _F_BIN;
72 # if defined(USEMYBINMODE)
73 if (my_binmode(fp, iotype, mode) != FALSE)
85 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
87 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
91 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
105 #ifdef PERLIO_IS_STDIO
110 /* Does nothing (yet) except force this file to be included
111 in perl binary. That allows this file to force inclusion
112 of other functions that may be required by loadable
113 extensions e.g. for FileHandle::tmpfile
117 #undef PerlIO_tmpfile
124 #else /* PERLIO_IS_STDIO */
131 /* This section is just to make sure these functions
132 get pulled in from libsfio.a
135 #undef PerlIO_tmpfile
145 /* Force this file to be included in perl binary. Which allows
146 * this file to force inclusion of other functions that may be
147 * required by loadable extensions e.g. for FileHandle::tmpfile
151 * sfio does its own 'autoflush' on stdout in common cases.
152 * Flush results in a lot of lseek()s to regular files and
153 * lot of small writes to pipes.
155 sfset(sfstdout,SF_SHARE,0);
159 /*======================================================================================*/
160 /* Implement all the PerlIO interface ourselves.
165 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
170 #include <sys/mman.h>
175 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
178 PerlIO_debug(const char *fmt,...)
186 char *s = PerlEnv_getenv("PERLIO_DEBUG");
188 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
195 SV *sv = newSVpvn("",0);
198 s = CopFILE(PL_curcop);
201 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
202 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
205 PerlLIO_write(dbg,s,len);
211 /*--------------------------------------------------------------------------------------*/
213 /* Inner level routines */
215 /* Table of pointers to the PerlIO structs (malloc'ed) */
216 PerlIO *_perlio = NULL;
217 #define PERLIO_TABLE_SIZE 64
220 PerlIO_allocate(pTHX)
222 /* Find a free slot in the table, allocating new table as necessary */
229 last = (PerlIO **)(f);
230 for (i=1; i < PERLIO_TABLE_SIZE; i++)
238 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
248 PerlIO_cleantable(pTHX_ PerlIO **tablep)
250 PerlIO *table = *tablep;
254 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
255 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
263 PerlMemShared_free(table);
275 PerlIO_cleantable(aTHX_ &_perlio);
279 PerlIO_pop(PerlIO *f)
285 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
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)
1772 stdio = fdopen(PerlIO_fileno(f),"r+");
1775 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1781 #undef PerlIO_findFILE
1783 PerlIO_findFILE(PerlIO *f)
1788 if (l->tab == &PerlIO_stdio)
1790 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
1793 l = *PerlIONext(&l);
1795 return PerlIO_exportFILE(f,0);
1798 #undef PerlIO_releaseFILE
1800 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1804 /*--------------------------------------------------------------------------------------*/
1805 /* perlio buffer layer */
1808 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1810 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1811 b->posn = PerlIO_tell(PerlIONext(f));
1812 return PerlIOBase_pushed(f,mode,arg,len);
1816 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1819 PerlIO_funcs *tab = PerlIO_default_btm();
1827 #if O_BINARY != O_TEXT
1828 /* do something about failing setmode()? --jhi */
1829 PerlLIO_setmode(fd, O_BINARY);
1831 f = (*tab->Fdopen)(tab,fd,mode);
1834 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1835 if (init && fd == 2)
1837 /* Initial stderr is unbuffered */
1838 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1841 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1842 self->name,f,fd,mode,PerlIOBase(f)->flags);
1849 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1851 PerlIO_funcs *tab = PerlIO_default_btm();
1852 PerlIO *f = (*tab->Open)(tab,path,mode);
1855 PerlIO_push(f,self,mode,Nullch,0);
1861 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1863 PerlIO *next = PerlIONext(f);
1864 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1866 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
1870 /* This "flush" is akin to sfio's sync in that it handles files in either
1874 PerlIOBuf_flush(PerlIO *f)
1876 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1878 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1880 /* write() the buffer */
1881 STDCHAR *buf = b->buf;
1884 PerlIO *n = PerlIONext(f);
1887 count = PerlIO_write(n,p,b->ptr - p);
1892 else if (count < 0 || PerlIO_error(n))
1894 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1899 b->posn += (p - buf);
1901 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1903 STDCHAR *buf = PerlIO_get_base(f);
1904 /* Note position change */
1905 b->posn += (b->ptr - buf);
1906 if (b->ptr < b->end)
1908 /* We did not consume all of it */
1909 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1911 b->posn = PerlIO_tell(PerlIONext(f));
1915 b->ptr = b->end = b->buf;
1916 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1917 /* FIXME: Is this right for read case ? */
1918 if (PerlIO_flush(PerlIONext(f)) != 0)
1924 PerlIOBuf_fill(PerlIO *f)
1926 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1927 PerlIO *n = PerlIONext(f);
1929 /* FIXME: doing the down-stream flush is a bad idea if it causes
1930 pre-read data in stdio buffer to be discarded
1931 but this is too simplistic - as it skips _our_ hosekeeping
1932 and breaks tell tests.
1933 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1937 if (PerlIO_flush(f) != 0)
1941 PerlIO_get_base(f); /* allocate via vtable */
1943 b->ptr = b->end = b->buf;
1944 if (PerlIO_fast_gets(n))
1946 /* Layer below is also buffered
1947 * We do _NOT_ want to call its ->Read() because that will loop
1948 * till it gets what we asked for which may hang on a pipe etc.
1949 * Instead take anything it has to hand, or ask it to fill _once_.
1951 avail = PerlIO_get_cnt(n);
1954 avail = PerlIO_fill(n);
1956 avail = PerlIO_get_cnt(n);
1959 if (!PerlIO_error(n) && PerlIO_eof(n))
1965 STDCHAR *ptr = PerlIO_get_ptr(n);
1966 SSize_t cnt = avail;
1967 if (avail > b->bufsiz)
1969 Copy(ptr,b->buf,avail,STDCHAR);
1970 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1975 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1980 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1982 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1985 b->end = b->buf+avail;
1986 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1991 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1993 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1994 STDCHAR *buf = (STDCHAR *) vbuf;
1999 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2003 SSize_t avail = PerlIO_get_cnt(f);
2004 SSize_t take = (count < avail) ? count : avail;
2007 STDCHAR *ptr = PerlIO_get_ptr(f);
2008 Copy(ptr,buf,take,STDCHAR);
2009 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2013 if (count > 0 && avail <= 0)
2015 if (PerlIO_fill(f) != 0)
2019 return (buf - (STDCHAR *) vbuf);
2025 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2027 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2028 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2031 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2037 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2039 avail = (b->ptr - b->buf);
2044 b->end = b->buf + avail;
2046 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2047 b->posn -= b->bufsiz;
2049 if (avail > (SSize_t) count)
2057 Copy(buf,b->ptr,avail,STDCHAR);
2061 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2068 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2070 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2071 const STDCHAR *buf = (const STDCHAR *) vbuf;
2075 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2079 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2080 if ((SSize_t) count < avail)
2082 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2083 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2103 Copy(buf,b->ptr,avail,STDCHAR);
2110 if (b->ptr >= (b->buf + b->bufsiz))
2113 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2119 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2122 if ((code = PerlIO_flush(f)) == 0)
2124 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2125 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2126 code = PerlIO_seek(PerlIONext(f),offset,whence);
2129 b->posn = PerlIO_tell(PerlIONext(f));
2136 PerlIOBuf_tell(PerlIO *f)
2138 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2139 Off_t posn = b->posn;
2141 posn += (b->ptr - b->buf);
2146 PerlIOBuf_close(PerlIO *f)
2149 IV code = PerlIOBase_close(f);
2150 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2151 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2153 PerlMemShared_free(b->buf);
2156 b->ptr = b->end = b->buf;
2157 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2162 PerlIOBuf_setlinebuf(PerlIO *f)
2166 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2171 PerlIOBuf_get_ptr(PerlIO *f)
2173 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2180 PerlIOBuf_get_cnt(PerlIO *f)
2182 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2185 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2186 return (b->end - b->ptr);
2191 PerlIOBuf_get_base(PerlIO *f)
2193 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2199 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2202 b->buf = (STDCHAR *)&b->oneword;
2203 b->bufsiz = sizeof(b->oneword);
2212 PerlIOBuf_bufsiz(PerlIO *f)
2214 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2217 return (b->end - b->buf);
2221 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2223 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2227 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2230 assert(PerlIO_get_cnt(f) == cnt);
2231 assert(b->ptr >= b->buf);
2233 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2236 PerlIO_funcs PerlIO_perlio = {
2256 PerlIOBase_clearerr,
2257 PerlIOBuf_setlinebuf,
2262 PerlIOBuf_set_ptrcnt,
2265 /*--------------------------------------------------------------------------------------*/
2266 /* Temp layer to hold unread chars when cannot do it any other way */
2269 PerlIOPending_fill(PerlIO *f)
2271 /* Should never happen */
2277 PerlIOPending_close(PerlIO *f)
2279 /* A tad tricky - flush pops us, then we close new top */
2281 return PerlIO_close(f);
2285 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2287 /* A tad tricky - flush pops us, then we seek new top */
2289 return PerlIO_seek(f,offset,whence);
2294 PerlIOPending_flush(PerlIO *f)
2296 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2297 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2300 PerlMemShared_free(b->buf);
2308 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2316 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2321 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2323 IV code = PerlIOBase_pushed(f,mode,arg,len);
2324 PerlIOl *l = PerlIOBase(f);
2325 /* Our PerlIO_fast_gets must match what we are pushed on,
2326 or sv_gets() etc. get muddled when it changes mid-string
2329 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2330 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2335 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2337 SSize_t avail = PerlIO_get_cnt(f);
2342 got = PerlIOBuf_read(f,vbuf,avail);
2344 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2349 PerlIO_funcs PerlIO_pending = {
2357 PerlIOPending_pushed,
2364 PerlIOPending_close,
2365 PerlIOPending_flush,
2369 PerlIOBase_clearerr,
2370 PerlIOBuf_setlinebuf,
2375 PerlIOPending_set_ptrcnt,
2380 /*--------------------------------------------------------------------------------------*/
2381 /* crlf - translation
2382 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2383 to hand back a line at a time and keeping a record of which nl we "lied" about.
2384 On write translate "\n" to CR,LF
2389 PerlIOBuf base; /* PerlIOBuf stuff */
2390 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2394 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2397 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2398 code = PerlIOBuf_pushed(f,mode,arg,len);
2400 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2401 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2402 PerlIOBase(f)->flags);
2409 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2411 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2417 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2418 return PerlIOBuf_unread(f,vbuf,count);
2421 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2422 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2424 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2430 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2432 b->end = b->ptr = b->buf + b->bufsiz;
2433 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2434 b->posn -= b->bufsiz;
2436 while (count > 0 && b->ptr > b->buf)
2441 if (b->ptr - 2 >= b->buf)
2467 PerlIOCrlf_get_cnt(PerlIO *f)
2469 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2472 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2474 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2475 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2477 STDCHAR *nl = b->ptr;
2479 while (nl < b->end && *nl != 0xd)
2481 if (nl < b->end && *nl == 0xd)
2493 /* Not CR,LF but just CR */
2500 /* Blast - found CR as last char in buffer */
2503 /* They may not care, defer work as long as possible */
2504 return (nl - b->ptr);
2510 b->ptr++; /* say we have read it as far as flush() is concerned */
2511 b->buf++; /* Leave space an front of buffer */
2512 b->bufsiz--; /* Buffer is thus smaller */
2513 code = PerlIO_fill(f); /* Fetch some more */
2514 b->bufsiz++; /* Restore size for next time */
2515 b->buf--; /* Point at space */
2516 b->ptr = nl = b->buf; /* Which is what we hand off */
2517 b->posn--; /* Buffer starts here */
2518 *nl = 0xd; /* Fill in the CR */
2520 goto test; /* fill() call worked */
2521 /* CR at EOF - just fall through */
2526 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2532 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2534 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2535 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2536 IV flags = PerlIOBase(f)->flags;
2546 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2553 /* Test code - delete when it works ... */
2560 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2568 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2569 ptr, chk, flags, c->nl, b->end, cnt);
2576 /* They have taken what we lied about */
2583 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2587 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2589 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2590 return PerlIOBuf_write(f,vbuf,count);
2593 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2594 const STDCHAR *buf = (const STDCHAR *) vbuf;
2595 const STDCHAR *ebuf = buf+count;
2598 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2602 STDCHAR *eptr = b->buf+b->bufsiz;
2603 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2604 while (buf < ebuf && b->ptr < eptr)
2608 if ((b->ptr + 2) > eptr)
2610 /* Not room for both */
2616 *(b->ptr)++ = 0xd; /* CR */
2617 *(b->ptr)++ = 0xa; /* LF */
2619 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2638 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2640 return (buf - (STDCHAR *) vbuf);
2645 PerlIOCrlf_flush(PerlIO *f)
2647 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2653 return PerlIOBuf_flush(f);
2656 PerlIO_funcs PerlIO_crlf = {
2659 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2665 PerlIOBase_noop_ok, /* popped */
2666 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2667 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2668 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2676 PerlIOBase_clearerr,
2677 PerlIOBuf_setlinebuf,
2682 PerlIOCrlf_set_ptrcnt,
2686 /*--------------------------------------------------------------------------------------*/
2687 /* mmap as "buffer" layer */
2691 PerlIOBuf base; /* PerlIOBuf stuff */
2692 Mmap_t mptr; /* Mapped address */
2693 Size_t len; /* mapped length */
2694 STDCHAR *bbuf; /* malloced buffer if map fails */
2697 static size_t page_size = 0;
2700 PerlIOMmap_map(PerlIO *f)
2703 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2704 PerlIOBuf *b = &m->base;
2705 IV flags = PerlIOBase(f)->flags;
2709 if (flags & PERLIO_F_CANREAD)
2711 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2712 int fd = PerlIO_fileno(f);
2714 code = fstat(fd,&st);
2715 if (code == 0 && S_ISREG(st.st_mode))
2717 SSize_t len = st.st_size - b->posn;
2722 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2724 SETERRNO(0,SS$_NORMAL);
2725 # ifdef _SC_PAGESIZE
2726 page_size = sysconf(_SC_PAGESIZE);
2728 page_size = sysconf(_SC_PAGE_SIZE);
2730 if ((long)page_size < 0) {
2735 (void)SvUPGRADE(error, SVt_PV);
2736 msg = SvPVx(error, n_a);
2737 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2740 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2744 # ifdef HAS_GETPAGESIZE
2745 page_size = getpagesize();
2747 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2748 page_size = PAGESIZE; /* compiletime, bad */
2752 if ((IV)page_size <= 0)
2753 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2757 /* This is a hack - should never happen - open should have set it ! */
2758 b->posn = PerlIO_tell(PerlIONext(f));
2760 posn = (b->posn / page_size) * page_size;
2761 len = st.st_size - posn;
2762 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2763 if (m->mptr && m->mptr != (Mmap_t) -1)
2765 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2766 madvise(m->mptr, len, MADV_SEQUENTIAL);
2768 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2769 madvise(m->mptr, len, MADV_WILLNEED);
2771 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2772 b->end = ((STDCHAR *)m->mptr) + len;
2773 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2784 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2786 b->ptr = b->end = b->ptr;
2795 PerlIOMmap_unmap(PerlIO *f)
2797 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2798 PerlIOBuf *b = &m->base;
2804 code = munmap(m->mptr, m->len);
2808 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2811 b->ptr = b->end = b->buf;
2812 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2818 PerlIOMmap_get_base(PerlIO *f)
2820 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2821 PerlIOBuf *b = &m->base;
2822 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2824 /* Already have a readbuffer in progress */
2829 /* We have a write buffer or flushed PerlIOBuf read buffer */
2830 m->bbuf = b->buf; /* save it in case we need it again */
2831 b->buf = NULL; /* Clear to trigger below */
2835 PerlIOMmap_map(f); /* Try and map it */
2838 /* Map did not work - recover PerlIOBuf buffer if we have one */
2842 b->ptr = b->end = b->buf;
2845 return PerlIOBuf_get_base(f);
2849 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2851 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2852 PerlIOBuf *b = &m->base;
2853 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2855 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2858 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2863 /* Loose the unwritable mapped buffer */
2865 /* If flush took the "buffer" see if we have one from before */
2866 if (!b->buf && m->bbuf)
2870 PerlIOBuf_get_base(f);
2874 return PerlIOBuf_unread(f,vbuf,count);
2878 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2880 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2881 PerlIOBuf *b = &m->base;
2882 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2884 /* No, or wrong sort of, buffer */
2887 if (PerlIOMmap_unmap(f) != 0)
2890 /* If unmap took the "buffer" see if we have one from before */
2891 if (!b->buf && m->bbuf)
2895 PerlIOBuf_get_base(f);
2899 return PerlIOBuf_write(f,vbuf,count);
2903 PerlIOMmap_flush(PerlIO *f)
2905 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2906 PerlIOBuf *b = &m->base;
2907 IV code = PerlIOBuf_flush(f);
2908 /* Now we are "synced" at PerlIOBuf level */
2913 /* Unmap the buffer */
2914 if (PerlIOMmap_unmap(f) != 0)
2919 /* We seem to have a PerlIOBuf buffer which was not mapped
2920 * remember it in case we need one later
2929 PerlIOMmap_fill(PerlIO *f)
2931 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2932 IV code = PerlIO_flush(f);
2933 if (code == 0 && !b->buf)
2935 code = PerlIOMmap_map(f);
2937 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2939 code = PerlIOBuf_fill(f);
2945 PerlIOMmap_close(PerlIO *f)
2947 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2948 PerlIOBuf *b = &m->base;
2949 IV code = PerlIO_flush(f);
2954 b->ptr = b->end = b->buf;
2956 if (PerlIOBuf_close(f) != 0)
2962 PerlIO_funcs PerlIO_mmap = {
2982 PerlIOBase_clearerr,
2983 PerlIOBuf_setlinebuf,
2984 PerlIOMmap_get_base,
2988 PerlIOBuf_set_ptrcnt,
2991 #endif /* HAS_MMAP */
2999 atexit(&PerlIO_cleanup);
3009 PerlIO_stdstreams();
3013 #undef PerlIO_stdout
3018 PerlIO_stdstreams();
3022 #undef PerlIO_stderr
3027 PerlIO_stdstreams();
3031 /*--------------------------------------------------------------------------------------*/
3033 #undef PerlIO_getname
3035 PerlIO_getname(PerlIO *f, char *buf)
3038 Perl_croak(aTHX_ "Don't know how to get file name");
3043 /*--------------------------------------------------------------------------------------*/
3044 /* Functions which can be called on any kind of PerlIO implemented
3050 PerlIO_getc(PerlIO *f)
3053 SSize_t count = PerlIO_read(f,buf,1);
3056 return (unsigned char) buf[0];
3061 #undef PerlIO_ungetc
3063 PerlIO_ungetc(PerlIO *f, int ch)
3068 if (PerlIO_unread(f,&buf,1) == 1)
3076 PerlIO_putc(PerlIO *f, int ch)
3079 return PerlIO_write(f,&buf,1);
3084 PerlIO_puts(PerlIO *f, const char *s)
3086 STRLEN len = strlen(s);
3087 return PerlIO_write(f,s,len);
3090 #undef PerlIO_rewind
3092 PerlIO_rewind(PerlIO *f)
3094 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3098 #undef PerlIO_vprintf
3100 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3103 SV *sv = newSVpvn("",0);
3108 Perl_va_copy(ap, apc);
3109 sv_vcatpvf(sv, fmt, &apc);
3111 sv_vcatpvf(sv, fmt, &ap);
3114 return PerlIO_write(f,s,len);
3117 #undef PerlIO_printf
3119 PerlIO_printf(PerlIO *f,const char *fmt,...)
3124 result = PerlIO_vprintf(f,fmt,ap);
3129 #undef PerlIO_stdoutf
3131 PerlIO_stdoutf(const char *fmt,...)
3136 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3141 #undef PerlIO_tmpfile
3143 PerlIO_tmpfile(void)
3145 /* I have no idea how portable mkstemp() is ... */
3146 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3149 FILE *stdio = PerlSIO_tmpfile();
3152 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3158 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3159 int fd = mkstemp(SvPVX(sv));
3163 f = PerlIO_fdopen(fd,"w+");
3166 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3168 PerlLIO_unlink(SvPVX(sv));
3178 #endif /* USE_SFIO */
3179 #endif /* PERLIO_IS_STDIO */
3181 /*======================================================================================*/
3182 /* Now some functions in terms of above which may be needed even if
3183 we are not in true PerlIO mode
3187 #undef PerlIO_setpos
3189 PerlIO_setpos(PerlIO *f, SV *pos)
3195 Off_t *posn = (Off_t *) SvPV(pos,len);
3196 if (f && len == sizeof(Off_t))
3197 return PerlIO_seek(f,*posn,SEEK_SET);
3203 #undef PerlIO_setpos
3205 PerlIO_setpos(PerlIO *f, SV *pos)
3211 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3212 if (f && len == sizeof(Fpos_t))
3214 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3215 return fsetpos64(f, fpos);
3217 return fsetpos(f, fpos);
3227 #undef PerlIO_getpos
3229 PerlIO_getpos(PerlIO *f, SV *pos)
3232 Off_t posn = PerlIO_tell(f);
3233 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3234 return (posn == (Off_t)-1) ? -1 : 0;
3237 #undef PerlIO_getpos
3239 PerlIO_getpos(PerlIO *f, SV *pos)
3244 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3245 code = fgetpos64(f, &fpos);
3247 code = fgetpos(f, &fpos);
3249 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3254 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3257 vprintf(char *pat, char *args)
3259 _doprnt(pat, args, stdout);
3260 return 0; /* wrong, but perl doesn't use the return value */
3264 vfprintf(FILE *fd, char *pat, char *args)
3266 _doprnt(pat, args, fd);
3267 return 0; /* wrong, but perl doesn't use the return value */
3272 #ifndef PerlIO_vsprintf
3274 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3276 int val = vsprintf(s, fmt, ap);
3279 if (strlen(s) >= (STRLEN)n)
3282 (void)PerlIO_puts(Perl_error_log,
3283 "panic: sprintf overflow - memory corrupted!\n");
3291 #ifndef PerlIO_sprintf
3293 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3298 result = PerlIO_vsprintf(s, n, fmt, ap);