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;
1287 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1290 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1293 SSize_t len = PerlLIO_write(fd,vbuf,count);
1294 if (len >= 0 || errno != EINTR)
1297 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1305 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1308 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1309 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1310 return (new == (Off_t) -1) ? -1 : 0;
1314 PerlIOUnix_tell(PerlIO *f)
1317 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1318 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1322 PerlIOUnix_close(PerlIO *f)
1325 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1327 while (PerlLIO_close(fd) != 0)
1338 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1343 PerlIO_funcs PerlIO_unix = {
1359 PerlIOBase_noop_ok, /* flush */
1360 PerlIOBase_noop_fail, /* fill */
1363 PerlIOBase_clearerr,
1364 PerlIOBase_setlinebuf,
1365 NULL, /* get_base */
1366 NULL, /* get_bufsiz */
1369 NULL, /* set_ptrcnt */
1372 /*--------------------------------------------------------------------------------------*/
1373 /* stdio as a layer */
1377 struct _PerlIO base;
1378 FILE * stdio; /* The stream */
1382 PerlIOStdio_fileno(PerlIO *f)
1385 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1389 PerlIOStdio_mode(const char *mode,char *tmode)
1396 if (O_BINARY != O_TEXT)
1405 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1424 stdio = PerlSIO_stdin;
1427 stdio = PerlSIO_stdout;
1430 stdio = PerlSIO_stderr;
1436 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1440 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1447 #undef PerlIO_importFILE
1449 PerlIO_importFILE(FILE *stdio, int fl)
1455 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1462 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1466 FILE *stdio = PerlSIO_fopen(path,mode);
1470 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1471 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1479 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1482 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1484 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1492 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1495 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1499 STDCHAR *buf = (STDCHAR *) vbuf;
1500 /* Perl is expecting PerlIO_getc() to fill the buffer
1501 * Linux's stdio does not do that for fread()
1503 int ch = PerlSIO_fgetc(s);
1511 got = PerlSIO_fread(vbuf,1,count,s);
1516 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1519 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1520 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1524 int ch = *buf-- & 0xff;
1525 if (PerlSIO_ungetc(ch,s) != ch)
1534 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1537 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1541 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1544 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1545 return PerlSIO_fseek(stdio,offset,whence);
1549 PerlIOStdio_tell(PerlIO *f)
1552 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1553 return PerlSIO_ftell(stdio);
1557 PerlIOStdio_close(PerlIO *f)
1561 int optval, optlen = sizeof(int);
1563 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1566 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1567 PerlSIO_fclose(stdio) :
1568 close(PerlIO_fileno(f))
1570 PerlSIO_fclose(stdio)
1577 PerlIOStdio_flush(PerlIO *f)
1580 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1581 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1583 return PerlSIO_fflush(stdio);
1588 /* FIXME: This discards ungetc() and pre-read stuff which is
1589 not right if this is just a "sync" from a layer above
1590 Suspect right design is to do _this_ but not have layer above
1591 flush this layer read-to-read
1593 /* Not writeable - sync by attempting a seek */
1595 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1603 PerlIOStdio_fill(PerlIO *f)
1606 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1608 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1609 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1611 if (PerlSIO_fflush(stdio) != 0)
1614 c = PerlSIO_fgetc(stdio);
1615 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1621 PerlIOStdio_eof(PerlIO *f)
1624 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1628 PerlIOStdio_error(PerlIO *f)
1631 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1635 PerlIOStdio_clearerr(PerlIO *f)
1638 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1642 PerlIOStdio_setlinebuf(PerlIO *f)
1645 #ifdef HAS_SETLINEBUF
1646 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1648 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1654 PerlIOStdio_get_base(PerlIO *f)
1657 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1658 return PerlSIO_get_base(stdio);
1662 PerlIOStdio_get_bufsiz(PerlIO *f)
1665 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1666 return PerlSIO_get_bufsiz(stdio);
1670 #ifdef USE_STDIO_PTR
1672 PerlIOStdio_get_ptr(PerlIO *f)
1675 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1676 return PerlSIO_get_ptr(stdio);
1680 PerlIOStdio_get_cnt(PerlIO *f)
1683 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1684 return PerlSIO_get_cnt(stdio);
1688 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1691 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1694 #ifdef STDIO_PTR_LVALUE
1695 PerlSIO_set_ptr(stdio,ptr);
1696 #ifdef STDIO_PTR_LVAL_SETS_CNT
1697 if (PerlSIO_get_cnt(stdio) != (cnt))
1700 assert(PerlSIO_get_cnt(stdio) == (cnt));
1703 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1704 /* Setting ptr _does_ change cnt - we are done */
1707 #else /* STDIO_PTR_LVALUE */
1709 #endif /* STDIO_PTR_LVALUE */
1711 /* Now (or only) set cnt */
1712 #ifdef STDIO_CNT_LVALUE
1713 PerlSIO_set_cnt(stdio,cnt);
1714 #else /* STDIO_CNT_LVALUE */
1715 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1716 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1717 #else /* STDIO_PTR_LVAL_SETS_CNT */
1719 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1720 #endif /* STDIO_CNT_LVALUE */
1725 PerlIO_funcs PerlIO_stdio = {
1727 sizeof(PerlIOStdio),
1745 PerlIOStdio_clearerr,
1746 PerlIOStdio_setlinebuf,
1748 PerlIOStdio_get_base,
1749 PerlIOStdio_get_bufsiz,
1754 #ifdef USE_STDIO_PTR
1755 PerlIOStdio_get_ptr,
1756 PerlIOStdio_get_cnt,
1757 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1758 PerlIOStdio_set_ptrcnt
1759 #else /* STDIO_PTR_LVALUE */
1761 #endif /* STDIO_PTR_LVALUE */
1762 #else /* USE_STDIO_PTR */
1766 #endif /* USE_STDIO_PTR */
1769 #undef PerlIO_exportFILE
1771 PerlIO_exportFILE(PerlIO *f, int fl)
1775 stdio = fdopen(PerlIO_fileno(f),"r+");
1778 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1784 #undef PerlIO_findFILE
1786 PerlIO_findFILE(PerlIO *f)
1791 if (l->tab == &PerlIO_stdio)
1793 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
1796 l = *PerlIONext(&l);
1798 return PerlIO_exportFILE(f,0);
1801 #undef PerlIO_releaseFILE
1803 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1807 /*--------------------------------------------------------------------------------------*/
1808 /* perlio buffer layer */
1811 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1813 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1814 b->posn = PerlIO_tell(PerlIONext(f));
1815 return PerlIOBase_pushed(f,mode,arg,len);
1819 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1822 PerlIO_funcs *tab = PerlIO_default_btm();
1830 #if O_BINARY != O_TEXT
1831 /* do something about failing setmode()? --jhi */
1832 PerlLIO_setmode(fd, O_BINARY);
1834 f = (*tab->Fdopen)(tab,fd,mode);
1837 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1838 if (init && fd == 2)
1840 /* Initial stderr is unbuffered */
1841 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1844 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1845 self->name,f,fd,mode,PerlIOBase(f)->flags);
1852 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1854 PerlIO_funcs *tab = PerlIO_default_btm();
1855 PerlIO *f = (*tab->Open)(tab,path,mode);
1858 PerlIO_push(f,self,mode,Nullch,0);
1864 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1866 PerlIO *next = PerlIONext(f);
1867 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1869 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
1873 /* This "flush" is akin to sfio's sync in that it handles files in either
1877 PerlIOBuf_flush(PerlIO *f)
1879 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1881 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1883 /* write() the buffer */
1884 STDCHAR *buf = b->buf;
1887 PerlIO *n = PerlIONext(f);
1890 count = PerlIO_write(n,p,b->ptr - p);
1895 else if (count < 0 || PerlIO_error(n))
1897 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1902 b->posn += (p - buf);
1904 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1906 STDCHAR *buf = PerlIO_get_base(f);
1907 /* Note position change */
1908 b->posn += (b->ptr - buf);
1909 if (b->ptr < b->end)
1911 /* We did not consume all of it */
1912 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1914 b->posn = PerlIO_tell(PerlIONext(f));
1918 b->ptr = b->end = b->buf;
1919 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1920 /* FIXME: Is this right for read case ? */
1921 if (PerlIO_flush(PerlIONext(f)) != 0)
1927 PerlIOBuf_fill(PerlIO *f)
1929 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1930 PerlIO *n = PerlIONext(f);
1932 /* FIXME: doing the down-stream flush is a bad idea if it causes
1933 pre-read data in stdio buffer to be discarded
1934 but this is too simplistic - as it skips _our_ hosekeeping
1935 and breaks tell tests.
1936 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1940 if (PerlIO_flush(f) != 0)
1944 PerlIO_get_base(f); /* allocate via vtable */
1946 b->ptr = b->end = b->buf;
1947 if (PerlIO_fast_gets(n))
1949 /* Layer below is also buffered
1950 * We do _NOT_ want to call its ->Read() because that will loop
1951 * till it gets what we asked for which may hang on a pipe etc.
1952 * Instead take anything it has to hand, or ask it to fill _once_.
1954 avail = PerlIO_get_cnt(n);
1957 avail = PerlIO_fill(n);
1959 avail = PerlIO_get_cnt(n);
1962 if (!PerlIO_error(n) && PerlIO_eof(n))
1968 STDCHAR *ptr = PerlIO_get_ptr(n);
1969 SSize_t cnt = avail;
1970 if (avail > b->bufsiz)
1972 Copy(ptr,b->buf,avail,STDCHAR);
1973 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1978 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1983 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1985 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1988 b->end = b->buf+avail;
1989 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1994 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1996 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1997 STDCHAR *buf = (STDCHAR *) vbuf;
2002 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2006 SSize_t avail = PerlIO_get_cnt(f);
2007 SSize_t take = (count < avail) ? count : avail;
2010 STDCHAR *ptr = PerlIO_get_ptr(f);
2011 Copy(ptr,buf,take,STDCHAR);
2012 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
2016 if (count > 0 && avail <= 0)
2018 if (PerlIO_fill(f) != 0)
2022 return (buf - (STDCHAR *) vbuf);
2028 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2030 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2031 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2034 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2040 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2042 avail = (b->ptr - b->buf);
2047 b->end = b->buf + avail;
2049 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2050 b->posn -= b->bufsiz;
2052 if (avail > (SSize_t) count)
2060 Copy(buf,b->ptr,avail,STDCHAR);
2064 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2071 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2073 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2074 const STDCHAR *buf = (const STDCHAR *) vbuf;
2078 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2082 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2083 if ((SSize_t) count < avail)
2085 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2086 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2106 Copy(buf,b->ptr,avail,STDCHAR);
2113 if (b->ptr >= (b->buf + b->bufsiz))
2116 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2122 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2125 if ((code = PerlIO_flush(f)) == 0)
2127 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2128 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2129 code = PerlIO_seek(PerlIONext(f),offset,whence);
2132 b->posn = PerlIO_tell(PerlIONext(f));
2139 PerlIOBuf_tell(PerlIO *f)
2141 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2142 Off_t posn = b->posn;
2144 posn += (b->ptr - b->buf);
2149 PerlIOBuf_close(PerlIO *f)
2152 IV code = PerlIOBase_close(f);
2153 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2154 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2156 PerlMemShared_free(b->buf);
2159 b->ptr = b->end = b->buf;
2160 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2165 PerlIOBuf_setlinebuf(PerlIO *f)
2169 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2174 PerlIOBuf_get_ptr(PerlIO *f)
2176 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2183 PerlIOBuf_get_cnt(PerlIO *f)
2185 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2188 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2189 return (b->end - b->ptr);
2194 PerlIOBuf_get_base(PerlIO *f)
2196 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2202 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2205 b->buf = (STDCHAR *)&b->oneword;
2206 b->bufsiz = sizeof(b->oneword);
2215 PerlIOBuf_bufsiz(PerlIO *f)
2217 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2220 return (b->end - b->buf);
2224 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2226 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2230 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2233 assert(PerlIO_get_cnt(f) == cnt);
2234 assert(b->ptr >= b->buf);
2236 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2239 PerlIO_funcs PerlIO_perlio = {
2259 PerlIOBase_clearerr,
2260 PerlIOBuf_setlinebuf,
2265 PerlIOBuf_set_ptrcnt,
2268 /*--------------------------------------------------------------------------------------*/
2269 /* Temp layer to hold unread chars when cannot do it any other way */
2272 PerlIOPending_fill(PerlIO *f)
2274 /* Should never happen */
2280 PerlIOPending_close(PerlIO *f)
2282 /* A tad tricky - flush pops us, then we close new top */
2284 return PerlIO_close(f);
2288 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2290 /* A tad tricky - flush pops us, then we seek new top */
2292 return PerlIO_seek(f,offset,whence);
2297 PerlIOPending_flush(PerlIO *f)
2299 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2300 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2303 PerlMemShared_free(b->buf);
2311 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2319 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2324 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2326 IV code = PerlIOBase_pushed(f,mode,arg,len);
2327 PerlIOl *l = PerlIOBase(f);
2328 /* Our PerlIO_fast_gets must match what we are pushed on,
2329 or sv_gets() etc. get muddled when it changes mid-string
2332 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2333 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2338 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2340 SSize_t avail = PerlIO_get_cnt(f);
2345 got = PerlIOBuf_read(f,vbuf,avail);
2347 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2352 PerlIO_funcs PerlIO_pending = {
2360 PerlIOPending_pushed,
2367 PerlIOPending_close,
2368 PerlIOPending_flush,
2372 PerlIOBase_clearerr,
2373 PerlIOBuf_setlinebuf,
2378 PerlIOPending_set_ptrcnt,
2383 /*--------------------------------------------------------------------------------------*/
2384 /* crlf - translation
2385 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2386 to hand back a line at a time and keeping a record of which nl we "lied" about.
2387 On write translate "\n" to CR,LF
2392 PerlIOBuf base; /* PerlIOBuf stuff */
2393 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2397 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2400 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2401 code = PerlIOBuf_pushed(f,mode,arg,len);
2403 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2404 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2405 PerlIOBase(f)->flags);
2412 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2414 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2420 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2421 return PerlIOBuf_unread(f,vbuf,count);
2424 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2425 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2427 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2433 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2435 b->end = b->ptr = b->buf + b->bufsiz;
2436 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2437 b->posn -= b->bufsiz;
2439 while (count > 0 && b->ptr > b->buf)
2444 if (b->ptr - 2 >= b->buf)
2470 PerlIOCrlf_get_cnt(PerlIO *f)
2472 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2475 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2477 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2478 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2480 STDCHAR *nl = b->ptr;
2482 while (nl < b->end && *nl != 0xd)
2484 if (nl < b->end && *nl == 0xd)
2496 /* Not CR,LF but just CR */
2503 /* Blast - found CR as last char in buffer */
2506 /* They may not care, defer work as long as possible */
2507 return (nl - b->ptr);
2513 b->ptr++; /* say we have read it as far as flush() is concerned */
2514 b->buf++; /* Leave space an front of buffer */
2515 b->bufsiz--; /* Buffer is thus smaller */
2516 code = PerlIO_fill(f); /* Fetch some more */
2517 b->bufsiz++; /* Restore size for next time */
2518 b->buf--; /* Point at space */
2519 b->ptr = nl = b->buf; /* Which is what we hand off */
2520 b->posn--; /* Buffer starts here */
2521 *nl = 0xd; /* Fill in the CR */
2523 goto test; /* fill() call worked */
2524 /* CR at EOF - just fall through */
2529 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2535 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2537 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2538 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2539 IV flags = PerlIOBase(f)->flags;
2549 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2556 /* Test code - delete when it works ... */
2563 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2571 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2572 ptr, chk, flags, c->nl, b->end, cnt);
2579 /* They have taken what we lied about */
2586 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2590 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2592 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2593 return PerlIOBuf_write(f,vbuf,count);
2596 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2597 const STDCHAR *buf = (const STDCHAR *) vbuf;
2598 const STDCHAR *ebuf = buf+count;
2601 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2605 STDCHAR *eptr = b->buf+b->bufsiz;
2606 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2607 while (buf < ebuf && b->ptr < eptr)
2611 if ((b->ptr + 2) > eptr)
2613 /* Not room for both */
2619 *(b->ptr)++ = 0xd; /* CR */
2620 *(b->ptr)++ = 0xa; /* LF */
2622 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2641 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2643 return (buf - (STDCHAR *) vbuf);
2648 PerlIOCrlf_flush(PerlIO *f)
2650 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2656 return PerlIOBuf_flush(f);
2659 PerlIO_funcs PerlIO_crlf = {
2662 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2668 PerlIOBase_noop_ok, /* popped */
2669 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2670 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2671 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2679 PerlIOBase_clearerr,
2680 PerlIOBuf_setlinebuf,
2685 PerlIOCrlf_set_ptrcnt,
2689 /*--------------------------------------------------------------------------------------*/
2690 /* mmap as "buffer" layer */
2694 PerlIOBuf base; /* PerlIOBuf stuff */
2695 Mmap_t mptr; /* Mapped address */
2696 Size_t len; /* mapped length */
2697 STDCHAR *bbuf; /* malloced buffer if map fails */
2700 static size_t page_size = 0;
2703 PerlIOMmap_map(PerlIO *f)
2706 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2707 PerlIOBuf *b = &m->base;
2708 IV flags = PerlIOBase(f)->flags;
2712 if (flags & PERLIO_F_CANREAD)
2714 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2715 int fd = PerlIO_fileno(f);
2717 code = fstat(fd,&st);
2718 if (code == 0 && S_ISREG(st.st_mode))
2720 SSize_t len = st.st_size - b->posn;
2725 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2727 SETERRNO(0,SS$_NORMAL);
2728 # ifdef _SC_PAGESIZE
2729 page_size = sysconf(_SC_PAGESIZE);
2731 page_size = sysconf(_SC_PAGE_SIZE);
2733 if ((long)page_size < 0) {
2738 (void)SvUPGRADE(error, SVt_PV);
2739 msg = SvPVx(error, n_a);
2740 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2743 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2747 # ifdef HAS_GETPAGESIZE
2748 page_size = getpagesize();
2750 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2751 page_size = PAGESIZE; /* compiletime, bad */
2755 if ((IV)page_size <= 0)
2756 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2760 /* This is a hack - should never happen - open should have set it ! */
2761 b->posn = PerlIO_tell(PerlIONext(f));
2763 posn = (b->posn / page_size) * page_size;
2764 len = st.st_size - posn;
2765 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2766 if (m->mptr && m->mptr != (Mmap_t) -1)
2768 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2769 madvise(m->mptr, len, MADV_SEQUENTIAL);
2771 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2772 madvise(m->mptr, len, MADV_WILLNEED);
2774 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2775 b->end = ((STDCHAR *)m->mptr) + len;
2776 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2787 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2789 b->ptr = b->end = b->ptr;
2798 PerlIOMmap_unmap(PerlIO *f)
2800 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2801 PerlIOBuf *b = &m->base;
2807 code = munmap(m->mptr, m->len);
2811 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2814 b->ptr = b->end = b->buf;
2815 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2821 PerlIOMmap_get_base(PerlIO *f)
2823 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2824 PerlIOBuf *b = &m->base;
2825 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2827 /* Already have a readbuffer in progress */
2832 /* We have a write buffer or flushed PerlIOBuf read buffer */
2833 m->bbuf = b->buf; /* save it in case we need it again */
2834 b->buf = NULL; /* Clear to trigger below */
2838 PerlIOMmap_map(f); /* Try and map it */
2841 /* Map did not work - recover PerlIOBuf buffer if we have one */
2845 b->ptr = b->end = b->buf;
2848 return PerlIOBuf_get_base(f);
2852 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2854 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2855 PerlIOBuf *b = &m->base;
2856 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2858 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2861 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2866 /* Loose the unwritable mapped buffer */
2868 /* If flush took the "buffer" see if we have one from before */
2869 if (!b->buf && m->bbuf)
2873 PerlIOBuf_get_base(f);
2877 return PerlIOBuf_unread(f,vbuf,count);
2881 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2883 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2884 PerlIOBuf *b = &m->base;
2885 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2887 /* No, or wrong sort of, buffer */
2890 if (PerlIOMmap_unmap(f) != 0)
2893 /* If unmap took the "buffer" see if we have one from before */
2894 if (!b->buf && m->bbuf)
2898 PerlIOBuf_get_base(f);
2902 return PerlIOBuf_write(f,vbuf,count);
2906 PerlIOMmap_flush(PerlIO *f)
2908 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2909 PerlIOBuf *b = &m->base;
2910 IV code = PerlIOBuf_flush(f);
2911 /* Now we are "synced" at PerlIOBuf level */
2916 /* Unmap the buffer */
2917 if (PerlIOMmap_unmap(f) != 0)
2922 /* We seem to have a PerlIOBuf buffer which was not mapped
2923 * remember it in case we need one later
2932 PerlIOMmap_fill(PerlIO *f)
2934 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2935 IV code = PerlIO_flush(f);
2936 if (code == 0 && !b->buf)
2938 code = PerlIOMmap_map(f);
2940 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2942 code = PerlIOBuf_fill(f);
2948 PerlIOMmap_close(PerlIO *f)
2950 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2951 PerlIOBuf *b = &m->base;
2952 IV code = PerlIO_flush(f);
2957 b->ptr = b->end = b->buf;
2959 if (PerlIOBuf_close(f) != 0)
2965 PerlIO_funcs PerlIO_mmap = {
2985 PerlIOBase_clearerr,
2986 PerlIOBuf_setlinebuf,
2987 PerlIOMmap_get_base,
2991 PerlIOBuf_set_ptrcnt,
2994 #endif /* HAS_MMAP */
3002 atexit(&PerlIO_cleanup);
3012 PerlIO_stdstreams();
3016 #undef PerlIO_stdout
3021 PerlIO_stdstreams();
3025 #undef PerlIO_stderr
3030 PerlIO_stdstreams();
3034 /*--------------------------------------------------------------------------------------*/
3036 #undef PerlIO_getname
3038 PerlIO_getname(PerlIO *f, char *buf)
3041 Perl_croak(aTHX_ "Don't know how to get file name");
3046 /*--------------------------------------------------------------------------------------*/
3047 /* Functions which can be called on any kind of PerlIO implemented
3053 PerlIO_getc(PerlIO *f)
3056 SSize_t count = PerlIO_read(f,buf,1);
3059 return (unsigned char) buf[0];
3064 #undef PerlIO_ungetc
3066 PerlIO_ungetc(PerlIO *f, int ch)
3071 if (PerlIO_unread(f,&buf,1) == 1)
3079 PerlIO_putc(PerlIO *f, int ch)
3082 return PerlIO_write(f,&buf,1);
3087 PerlIO_puts(PerlIO *f, const char *s)
3089 STRLEN len = strlen(s);
3090 return PerlIO_write(f,s,len);
3093 #undef PerlIO_rewind
3095 PerlIO_rewind(PerlIO *f)
3097 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3101 #undef PerlIO_vprintf
3103 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3106 SV *sv = newSVpvn("",0);
3111 Perl_va_copy(ap, apc);
3112 sv_vcatpvf(sv, fmt, &apc);
3114 sv_vcatpvf(sv, fmt, &ap);
3117 return PerlIO_write(f,s,len);
3120 #undef PerlIO_printf
3122 PerlIO_printf(PerlIO *f,const char *fmt,...)
3127 result = PerlIO_vprintf(f,fmt,ap);
3132 #undef PerlIO_stdoutf
3134 PerlIO_stdoutf(const char *fmt,...)
3139 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3144 #undef PerlIO_tmpfile
3146 PerlIO_tmpfile(void)
3148 /* I have no idea how portable mkstemp() is ... */
3149 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3152 FILE *stdio = PerlSIO_tmpfile();
3155 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3161 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3162 int fd = mkstemp(SvPVX(sv));
3166 f = PerlIO_fdopen(fd,"w+");
3169 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3171 PerlLIO_unlink(SvPVX(sv));
3181 #endif /* USE_SFIO */
3182 #endif /* PERLIO_IS_STDIO */
3184 /*======================================================================================*/
3185 /* Now some functions in terms of above which may be needed even if
3186 we are not in true PerlIO mode
3190 #undef PerlIO_setpos
3192 PerlIO_setpos(PerlIO *f, SV *pos)
3198 Off_t *posn = (Off_t *) SvPV(pos,len);
3199 if (f && len == sizeof(Off_t))
3200 return PerlIO_seek(f,*posn,SEEK_SET);
3206 #undef PerlIO_setpos
3208 PerlIO_setpos(PerlIO *f, SV *pos)
3214 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3215 if (f && len == sizeof(Fpos_t))
3217 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3218 return fsetpos64(f, fpos);
3220 return fsetpos(f, fpos);
3230 #undef PerlIO_getpos
3232 PerlIO_getpos(PerlIO *f, SV *pos)
3235 Off_t posn = PerlIO_tell(f);
3236 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3237 return (posn == (Off_t)-1) ? -1 : 0;
3240 #undef PerlIO_getpos
3242 PerlIO_getpos(PerlIO *f, SV *pos)
3247 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3248 code = fgetpos64(f, &fpos);
3250 code = fgetpos(f, &fpos);
3252 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3257 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3260 vprintf(char *pat, char *args)
3262 _doprnt(pat, args, stdout);
3263 return 0; /* wrong, but perl doesn't use the return value */
3267 vfprintf(FILE *fd, char *pat, char *args)
3269 _doprnt(pat, args, fd);
3270 return 0; /* wrong, but perl doesn't use the return value */
3275 #ifndef PerlIO_vsprintf
3277 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3279 int val = vsprintf(s, fmt, ap);
3282 if (strlen(s) >= (STRLEN)n)
3285 (void)PerlIO_puts(Perl_error_log,
3286 "panic: sprintf overflow - memory corrupted!\n");
3294 #ifndef PerlIO_sprintf
3296 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3301 result = PerlIO_vsprintf(s, n, fmt, ap);