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
33 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
35 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
39 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
45 perlsio_binmode(FILE *fp, int iotype, int mode)
47 /* This used to be contents of do_binmode in doio.c */
49 # if defined(atarist) || defined(__MINT__)
52 ((FILE*)fp)->_flag |= _IOBIN;
54 ((FILE*)fp)->_flag &= ~ _IOBIN;
59 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
60 # if defined(WIN32) && defined(__BORLANDC__)
61 /* The translation mode of the stream is maintained independent
62 * of the translation mode of the fd in the Borland RTL (heavy
63 * digging through their runtime sources reveal). User has to
64 * set the mode explicitly for the stream (though they don't
65 * document this anywhere). GSAR 97-5-24
71 fp->flags &= ~ _F_BIN;
79 # if defined(USEMYBINMODE)
80 if (my_binmode(fp, iotype, mode) != FALSE)
91 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
93 return perlsio_binmode(fp,iotype,mode);
99 #ifdef PERLIO_IS_STDIO
104 /* Does nothing (yet) except force this file to be included
105 in perl binary. That allows this file to force inclusion
106 of other functions that may be required by loadable
107 extensions e.g. for FileHandle::tmpfile
111 #undef PerlIO_tmpfile
118 #else /* PERLIO_IS_STDIO */
125 /* This section is just to make sure these functions
126 get pulled in from libsfio.a
129 #undef PerlIO_tmpfile
139 /* Force this file to be included in perl binary. Which allows
140 * this file to force inclusion of other functions that may be
141 * required by loadable extensions e.g. for FileHandle::tmpfile
145 * sfio does its own 'autoflush' on stdout in common cases.
146 * Flush results in a lot of lseek()s to regular files and
147 * lot of small writes to pipes.
149 sfset(sfstdout,SF_SHARE,0);
153 /*======================================================================================*/
154 /* Implement all the PerlIO interface ourselves.
159 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
164 #include <sys/mman.h>
169 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
172 PerlIO_debug(const char *fmt,...)
180 char *s = PerlEnv_getenv("PERLIO_DEBUG");
182 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
189 SV *sv = newSVpvn("",0);
192 s = CopFILE(PL_curcop);
195 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
196 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
199 PerlLIO_write(dbg,s,len);
205 /*--------------------------------------------------------------------------------------*/
207 /* Inner level routines */
209 /* Table of pointers to the PerlIO structs (malloc'ed) */
210 PerlIO *_perlio = NULL;
211 #define PERLIO_TABLE_SIZE 64
214 PerlIO_allocate(pTHX)
216 /* Find a free slot in the table, allocating new table as necessary */
223 last = (PerlIO **)(f);
224 for (i=1; i < PERLIO_TABLE_SIZE; i++)
232 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
242 PerlIO_cleantable(pTHX_ PerlIO **tablep)
244 PerlIO *table = *tablep;
248 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
249 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
257 PerlMemShared_free(table);
269 PerlIO_cleantable(aTHX_ &_perlio);
273 PerlIO_pop(PerlIO *f)
279 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
280 (*l->tab->Popped)(f);
282 PerlMemShared_free(l);
286 /*--------------------------------------------------------------------------------------*/
287 /* XS Interface for perl code */
293 char *s = GvNAME(gv);
294 STRLEN l = GvNAMELEN(gv);
295 PerlIO_debug("%.*s\n",(int) l,s);
299 XS(XS_perlio_unimport)
303 char *s = GvNAME(gv);
304 STRLEN l = GvNAMELEN(gv);
305 PerlIO_debug("%.*s\n",(int) l,s);
310 PerlIO_find_layer(const char *name, STRLEN len)
315 if ((SSize_t) len <= 0)
317 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
318 if (svp && (sv = *svp) && SvROK(sv))
325 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
329 IO *io = GvIOn((GV *)SvRV(sv));
330 PerlIO *ifp = IoIFP(io);
331 PerlIO *ofp = IoOFP(io);
332 AV *av = (AV *) mg->mg_obj;
333 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
339 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
343 IO *io = GvIOn((GV *)SvRV(sv));
344 PerlIO *ifp = IoIFP(io);
345 PerlIO *ofp = IoOFP(io);
346 AV *av = (AV *) mg->mg_obj;
347 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
353 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
355 Perl_warn(aTHX_ "clear %"SVf,sv);
360 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
362 Perl_warn(aTHX_ "free %"SVf,sv);
366 MGVTBL perlio_vtab = {
374 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
377 SV *sv = SvRV(ST(1));
382 sv_magic(sv, (SV *)av, '~', NULL, 0);
384 mg = mg_find(sv,'~');
385 mg->mg_virtual = &perlio_vtab;
387 Perl_warn(aTHX_ "attrib %"SVf,sv);
388 for (i=2; i < items; i++)
391 const char *name = SvPV(ST(i),len);
392 SV *layer = PerlIO_find_layer(name,len);
395 av_push(av,SvREFCNT_inc(layer));
408 PerlIO_define_layer(PerlIO_funcs *tab)
411 HV *stash = gv_stashpv("perlio::Layer", TRUE);
412 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
413 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
417 PerlIO_default_layer(I32 n)
422 PerlIO_funcs *tab = &PerlIO_stdio;
424 if (!PerlIO_layer_hv)
426 const char *s = PerlEnv_getenv("PERLIO");
427 newXS("perlio::import",XS_perlio_import,__FILE__);
428 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
430 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
432 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
433 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
434 PerlIO_define_layer(&PerlIO_unix);
435 PerlIO_define_layer(&PerlIO_perlio);
436 PerlIO_define_layer(&PerlIO_stdio);
437 PerlIO_define_layer(&PerlIO_crlf);
439 PerlIO_define_layer(&PerlIO_mmap);
441 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
446 while (*s && isSPACE((unsigned char)*s))
452 while (*e && !isSPACE((unsigned char)*e))
456 layer = PerlIO_find_layer(s,e-s);
459 PerlIO_debug("Pushing %.*s\n",(e-s),s);
460 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
463 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
469 len = av_len(PerlIO_layer_av);
472 if (O_BINARY != O_TEXT)
474 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
478 if (PerlIO_stdio.Set_ptrcnt)
480 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
484 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
487 len = av_len(PerlIO_layer_av);
491 svp = av_fetch(PerlIO_layer_av,n,0);
492 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
494 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
496 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
500 #define PerlIO_default_top() PerlIO_default_layer(-1)
501 #define PerlIO_default_btm() PerlIO_default_layer(0)
509 PerlIO_allocate(aTHX);
510 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
511 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
512 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
517 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
521 l = PerlMemShared_calloc(tab->size,sizeof(char));
524 Zero(l,tab->size,char);
528 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
529 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
539 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
543 const char *s = names;
553 const char *as = Nullch;
554 const char *ae = Nullch;
556 while (*e && *e != ':' && !isSPACE(*e))
566 if (as && --count == 0)
573 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
575 /* Pop back to bottom layer */
579 while (PerlIONext(f))
585 else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
587 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
589 else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
591 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
595 STRLEN len = ((as) ? as : e)-s;
596 SV *layer = PerlIO_find_layer(s,len);
599 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
602 len = (as) ? (ae-(as++)-1) : 0;
603 if (!PerlIO_push(f,tab,mode,as,len))
608 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
620 /*--------------------------------------------------------------------------------------*/
621 /* Given the abstraction above the public API functions */
624 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
626 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
627 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
628 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
634 if (PerlIOBase(top)->tab == &PerlIO_crlf)
637 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
640 top = PerlIONext(top);
643 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
648 PerlIO__close(PerlIO *f)
650 return (*PerlIOBase(f)->tab->Close)(f);
653 #undef PerlIO_fdupopen
655 PerlIO_fdupopen(pTHX_ PerlIO *f)
658 int fd = PerlLIO_dup(PerlIO_fileno(f));
659 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
662 Off_t posn = PerlIO_tell(f);
663 PerlIO_seek(new,posn,SEEK_SET);
670 PerlIO_close(PerlIO *f)
672 int code = (*PerlIOBase(f)->tab->Close)(f);
682 PerlIO_fileno(PerlIO *f)
684 return (*PerlIOBase(f)->tab->Fileno)(f);
691 PerlIO_fdopen(int fd, const char *mode)
693 PerlIO_funcs *tab = PerlIO_default_top();
696 return (*tab->Fdopen)(tab,fd,mode);
701 PerlIO_open(const char *path, const char *mode)
703 PerlIO_funcs *tab = PerlIO_default_top();
706 return (*tab->Open)(tab,path,mode);
711 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
716 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
718 if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
724 return PerlIO_open(path,mode);
729 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
731 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
736 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
738 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
743 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
745 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
750 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
752 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
757 PerlIO_tell(PerlIO *f)
759 return (*PerlIOBase(f)->tab->Tell)(f);
764 PerlIO_flush(PerlIO *f)
768 return (*PerlIOBase(f)->tab->Flush)(f);
772 PerlIO **table = &_perlio;
777 table = (PerlIO **)(f++);
778 for (i=1; i < PERLIO_TABLE_SIZE; i++)
780 if (*f && PerlIO_flush(f) != 0)
791 PerlIO_fill(PerlIO *f)
793 return (*PerlIOBase(f)->tab->Fill)(f);
798 PerlIO_isutf8(PerlIO *f)
800 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
805 PerlIO_eof(PerlIO *f)
807 return (*PerlIOBase(f)->tab->Eof)(f);
812 PerlIO_error(PerlIO *f)
814 return (*PerlIOBase(f)->tab->Error)(f);
817 #undef PerlIO_clearerr
819 PerlIO_clearerr(PerlIO *f)
822 (*PerlIOBase(f)->tab->Clearerr)(f);
825 #undef PerlIO_setlinebuf
827 PerlIO_setlinebuf(PerlIO *f)
829 (*PerlIOBase(f)->tab->Setlinebuf)(f);
832 #undef PerlIO_has_base
834 PerlIO_has_base(PerlIO *f)
838 return (PerlIOBase(f)->tab->Get_base != NULL);
843 #undef PerlIO_fast_gets
845 PerlIO_fast_gets(PerlIO *f)
847 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
849 PerlIO_funcs *tab = PerlIOBase(f)->tab;
850 return (tab->Set_ptrcnt != NULL);
855 #undef PerlIO_has_cntptr
857 PerlIO_has_cntptr(PerlIO *f)
861 PerlIO_funcs *tab = PerlIOBase(f)->tab;
862 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
867 #undef PerlIO_canset_cnt
869 PerlIO_canset_cnt(PerlIO *f)
873 PerlIOl *l = PerlIOBase(f);
874 return (l->tab->Set_ptrcnt != NULL);
879 #undef PerlIO_get_base
881 PerlIO_get_base(PerlIO *f)
883 return (*PerlIOBase(f)->tab->Get_base)(f);
886 #undef PerlIO_get_bufsiz
888 PerlIO_get_bufsiz(PerlIO *f)
890 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
893 #undef PerlIO_get_ptr
895 PerlIO_get_ptr(PerlIO *f)
897 PerlIO_funcs *tab = PerlIOBase(f)->tab;
898 if (tab->Get_ptr == NULL)
900 return (*tab->Get_ptr)(f);
903 #undef PerlIO_get_cnt
905 PerlIO_get_cnt(PerlIO *f)
907 PerlIO_funcs *tab = PerlIOBase(f)->tab;
908 if (tab->Get_cnt == NULL)
910 return (*tab->Get_cnt)(f);
913 #undef PerlIO_set_cnt
915 PerlIO_set_cnt(PerlIO *f,int cnt)
917 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
920 #undef PerlIO_set_ptrcnt
922 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
924 PerlIO_funcs *tab = PerlIOBase(f)->tab;
925 if (tab->Set_ptrcnt == NULL)
928 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
930 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
933 /*--------------------------------------------------------------------------------------*/
934 /* "Methods" of the "base class" */
937 PerlIOBase_fileno(PerlIO *f)
939 return PerlIO_fileno(PerlIONext(f));
943 PerlIO_modestr(PerlIO *f,char *buf)
946 IV flags = PerlIOBase(f)->flags;
947 if (flags & PERLIO_F_APPEND)
950 if (flags & PERLIO_F_CANREAD)
955 else if (flags & PERLIO_F_CANREAD)
958 if (flags & PERLIO_F_CANWRITE)
961 else if (flags & PERLIO_F_CANWRITE)
964 if (flags & PERLIO_F_CANREAD)
969 #if O_TEXT != O_BINARY
970 if (!(flags & PERLIO_F_CRLF))
978 PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
980 PerlIOl *l = PerlIOBase(f);
981 const char *omode = mode;
983 PerlIO_funcs *tab = PerlIOBase(f)->tab;
984 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
985 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
986 if (tab->Set_ptrcnt != NULL)
987 l->flags |= PERLIO_F_FASTGETS;
993 l->flags |= PERLIO_F_CANREAD;
996 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
999 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
1010 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1013 l->flags &= ~PERLIO_F_CRLF;
1016 l->flags |= PERLIO_F_CRLF;
1028 l->flags |= l->next->flags &
1029 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1033 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1034 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1035 l->flags,PerlIO_modestr(f,temp));
1041 PerlIOBase_popped(PerlIO *f)
1047 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1049 Off_t old = PerlIO_tell(f);
1051 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1052 done = PerlIOBuf_unread(f,vbuf,count);
1053 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1058 PerlIOBase_noop_ok(PerlIO *f)
1064 PerlIOBase_noop_fail(PerlIO *f)
1070 PerlIOBase_close(PerlIO *f)
1073 PerlIO *n = PerlIONext(f);
1074 if (PerlIO_flush(f) != 0)
1076 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1078 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1083 PerlIOBase_eof(PerlIO *f)
1087 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1093 PerlIOBase_error(PerlIO *f)
1097 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1103 PerlIOBase_clearerr(PerlIO *f)
1107 PerlIO *n = PerlIONext(f);
1108 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1115 PerlIOBase_setlinebuf(PerlIO *f)
1120 /*--------------------------------------------------------------------------------------*/
1121 /* Bottom-most level for UNIX-like case */
1125 struct _PerlIO base; /* The generic part */
1126 int fd; /* UNIX like file descriptor */
1127 int oflags; /* open/fcntl flags */
1131 PerlIOUnix_oflags(const char *mode)
1146 oflags = O_CREAT|O_TRUNC;
1157 oflags = O_CREAT|O_APPEND;
1173 else if (*mode == 't')
1176 oflags &= ~O_BINARY;
1179 /* Always open in binary mode */
1181 if (*mode || oflags == -1)
1190 PerlIOUnix_fileno(PerlIO *f)
1192 return PerlIOSelf(f,PerlIOUnix)->fd;
1196 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1204 int oflags = PerlIOUnix_oflags(mode);
1207 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1210 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1217 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1221 int oflags = PerlIOUnix_oflags(mode);
1224 int fd = PerlLIO_open3(path,oflags,0666);
1227 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1230 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1237 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1239 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1240 int oflags = PerlIOUnix_oflags(mode);
1241 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1242 (*PerlIOBase(f)->tab->Close)(f);
1246 int fd = PerlLIO_open3(path,oflags,0666);
1251 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1259 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1262 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1263 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1267 SSize_t len = PerlLIO_read(fd,vbuf,count);
1268 if (len >= 0 || errno != EINTR)
1271 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1272 else if (len == 0 && count != 0)
1273 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1280 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1283 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1286 SSize_t len = PerlLIO_write(fd,vbuf,count);
1287 if (len >= 0 || errno != EINTR)
1290 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1297 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1300 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1301 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1302 return (new == (Off_t) -1) ? -1 : 0;
1306 PerlIOUnix_tell(PerlIO *f)
1309 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1310 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1314 PerlIOUnix_close(PerlIO *f)
1317 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1319 while (PerlLIO_close(fd) != 0)
1329 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1334 PerlIO_funcs PerlIO_unix = {
1350 PerlIOBase_noop_ok, /* flush */
1351 PerlIOBase_noop_fail, /* fill */
1354 PerlIOBase_clearerr,
1355 PerlIOBase_setlinebuf,
1356 NULL, /* get_base */
1357 NULL, /* get_bufsiz */
1360 NULL, /* set_ptrcnt */
1363 /*--------------------------------------------------------------------------------------*/
1364 /* stdio as a layer */
1368 struct _PerlIO base;
1369 FILE * stdio; /* The stream */
1373 PerlIOStdio_fileno(PerlIO *f)
1376 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1380 PerlIOStdio_mode(const char *mode,char *tmode)
1387 if (O_BINARY != O_TEXT)
1396 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1415 stdio = PerlSIO_stdin;
1418 stdio = PerlSIO_stdout;
1421 stdio = PerlSIO_stderr;
1427 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1431 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1438 #undef PerlIO_importFILE
1440 PerlIO_importFILE(FILE *stdio, int fl)
1446 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1453 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1457 FILE *stdio = PerlSIO_fopen(path,mode);
1461 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1462 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1470 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1473 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1475 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1483 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1486 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1490 STDCHAR *buf = (STDCHAR *) vbuf;
1491 /* Perl is expecting PerlIO_getc() to fill the buffer
1492 * Linux's stdio does not do that for fread()
1494 int ch = PerlSIO_fgetc(s);
1502 got = PerlSIO_fread(vbuf,1,count,s);
1507 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1510 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1511 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1515 int ch = *buf-- & 0xff;
1516 if (PerlSIO_ungetc(ch,s) != ch)
1525 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1528 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1532 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1535 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1536 return PerlSIO_fseek(stdio,offset,whence);
1540 PerlIOStdio_tell(PerlIO *f)
1543 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1544 return PerlSIO_ftell(stdio);
1548 PerlIOStdio_close(PerlIO *f)
1552 int optval, optlen = sizeof(int);
1554 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1557 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1558 PerlSIO_fclose(stdio) :
1559 close(PerlIO_fileno(f))
1561 PerlSIO_fclose(stdio)
1568 PerlIOStdio_flush(PerlIO *f)
1571 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1572 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1574 return PerlSIO_fflush(stdio);
1579 /* FIXME: This discards ungetc() and pre-read stuff which is
1580 not right if this is just a "sync" from a layer above
1581 Suspect right design is to do _this_ but not have layer above
1582 flush this layer read-to-read
1584 /* Not writeable - sync by attempting a seek */
1586 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1594 PerlIOStdio_fill(PerlIO *f)
1597 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1599 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1600 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1602 if (PerlSIO_fflush(stdio) != 0)
1605 c = PerlSIO_fgetc(stdio);
1606 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1612 PerlIOStdio_eof(PerlIO *f)
1615 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1619 PerlIOStdio_error(PerlIO *f)
1622 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1626 PerlIOStdio_clearerr(PerlIO *f)
1629 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1633 PerlIOStdio_setlinebuf(PerlIO *f)
1636 #ifdef HAS_SETLINEBUF
1637 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1639 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1645 PerlIOStdio_get_base(PerlIO *f)
1648 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1649 return PerlSIO_get_base(stdio);
1653 PerlIOStdio_get_bufsiz(PerlIO *f)
1656 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1657 return PerlSIO_get_bufsiz(stdio);
1661 #ifdef USE_STDIO_PTR
1663 PerlIOStdio_get_ptr(PerlIO *f)
1666 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1667 return PerlSIO_get_ptr(stdio);
1671 PerlIOStdio_get_cnt(PerlIO *f)
1674 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1675 return PerlSIO_get_cnt(stdio);
1679 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1682 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1685 #ifdef STDIO_PTR_LVALUE
1686 PerlSIO_set_ptr(stdio,ptr);
1687 #ifdef STDIO_PTR_LVAL_SETS_CNT
1688 if (PerlSIO_get_cnt(stdio) != (cnt))
1691 assert(PerlSIO_get_cnt(stdio) == (cnt));
1694 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1695 /* Setting ptr _does_ change cnt - we are done */
1698 #else /* STDIO_PTR_LVALUE */
1700 #endif /* STDIO_PTR_LVALUE */
1702 /* Now (or only) set cnt */
1703 #ifdef STDIO_CNT_LVALUE
1704 PerlSIO_set_cnt(stdio,cnt);
1705 #else /* STDIO_CNT_LVALUE */
1706 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1707 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1708 #else /* STDIO_PTR_LVAL_SETS_CNT */
1710 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1711 #endif /* STDIO_CNT_LVALUE */
1716 PerlIO_funcs PerlIO_stdio = {
1718 sizeof(PerlIOStdio),
1736 PerlIOStdio_clearerr,
1737 PerlIOStdio_setlinebuf,
1739 PerlIOStdio_get_base,
1740 PerlIOStdio_get_bufsiz,
1745 #ifdef USE_STDIO_PTR
1746 PerlIOStdio_get_ptr,
1747 PerlIOStdio_get_cnt,
1748 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1749 PerlIOStdio_set_ptrcnt
1750 #else /* STDIO_PTR_LVALUE */
1752 #endif /* STDIO_PTR_LVALUE */
1753 #else /* USE_STDIO_PTR */
1757 #endif /* USE_STDIO_PTR */
1760 #undef PerlIO_exportFILE
1762 PerlIO_exportFILE(PerlIO *f, int fl)
1765 /* Should really push stdio discipline when we have them */
1766 return fdopen(PerlIO_fileno(f),"r+");
1769 #undef PerlIO_findFILE
1771 PerlIO_findFILE(PerlIO *f)
1773 return PerlIO_exportFILE(f,0);
1776 #undef PerlIO_releaseFILE
1778 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1782 /*--------------------------------------------------------------------------------------*/
1783 /* perlio buffer layer */
1786 PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1788 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1789 b->posn = PerlIO_tell(PerlIONext(f));
1790 return PerlIOBase_pushed(f,mode,arg,len);
1794 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1797 PerlIO_funcs *tab = PerlIO_default_btm();
1805 #if O_BINARY != O_TEXT
1806 /* do something about failing setmode()? --jhi */
1807 PerlLIO_setmode(fd, O_BINARY);
1809 f = (*tab->Fdopen)(tab,fd,mode);
1812 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1813 if (init && fd == 2)
1815 /* Initial stderr is unbuffered */
1816 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1819 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1820 self->name,f,fd,mode,PerlIOBase(f)->flags);
1827 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1829 PerlIO_funcs *tab = PerlIO_default_btm();
1830 PerlIO *f = (*tab->Open)(tab,path,mode);
1833 PerlIO_push(f,self,mode,Nullch,0);
1839 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1841 PerlIO *next = PerlIONext(f);
1842 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1844 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
1848 /* This "flush" is akin to sfio's sync in that it handles files in either
1852 PerlIOBuf_flush(PerlIO *f)
1854 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1856 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1858 /* write() the buffer */
1859 STDCHAR *buf = b->buf;
1862 PerlIO *n = PerlIONext(f);
1865 count = PerlIO_write(n,p,b->ptr - p);
1870 else if (count < 0 || PerlIO_error(n))
1872 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1877 b->posn += (p - buf);
1879 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1881 STDCHAR *buf = PerlIO_get_base(f);
1882 /* Note position change */
1883 b->posn += (b->ptr - buf);
1884 if (b->ptr < b->end)
1886 /* We did not consume all of it */
1887 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1889 b->posn = PerlIO_tell(PerlIONext(f));
1893 b->ptr = b->end = b->buf;
1894 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1895 /* FIXME: Is this right for read case ? */
1896 if (PerlIO_flush(PerlIONext(f)) != 0)
1902 PerlIOBuf_fill(PerlIO *f)
1904 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1905 PerlIO *n = PerlIONext(f);
1907 /* FIXME: doing the down-stream flush is a bad idea if it causes
1908 pre-read data in stdio buffer to be discarded
1909 but this is too simplistic - as it skips _our_ hosekeeping
1910 and breaks tell tests.
1911 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1915 if (PerlIO_flush(f) != 0)
1919 PerlIO_get_base(f); /* allocate via vtable */
1921 b->ptr = b->end = b->buf;
1922 if (PerlIO_fast_gets(n))
1924 /* Layer below is also buffered
1925 * We do _NOT_ want to call its ->Read() because that will loop
1926 * till it gets what we asked for which may hang on a pipe etc.
1927 * Instead take anything it has to hand, or ask it to fill _once_.
1929 avail = PerlIO_get_cnt(n);
1932 avail = PerlIO_fill(n);
1934 avail = PerlIO_get_cnt(n);
1937 if (!PerlIO_error(n) && PerlIO_eof(n))
1943 STDCHAR *ptr = PerlIO_get_ptr(n);
1944 SSize_t cnt = avail;
1945 if (avail > b->bufsiz)
1947 Copy(ptr,b->buf,avail,STDCHAR);
1948 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1953 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1958 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1960 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1963 b->end = b->buf+avail;
1964 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1969 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1971 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1972 STDCHAR *buf = (STDCHAR *) vbuf;
1977 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1981 SSize_t avail = PerlIO_get_cnt(f);
1982 SSize_t take = (count < avail) ? count : avail;
1985 STDCHAR *ptr = PerlIO_get_ptr(f);
1986 Copy(ptr,buf,take,STDCHAR);
1987 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1991 if (count > 0 && avail <= 0)
1993 if (PerlIO_fill(f) != 0)
1997 return (buf - (STDCHAR *) vbuf);
2003 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2005 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2006 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2009 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2015 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2017 avail = (b->ptr - b->buf);
2022 b->end = b->buf + avail;
2024 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2025 b->posn -= b->bufsiz;
2027 if (avail > (SSize_t) count)
2035 Copy(buf,b->ptr,avail,STDCHAR);
2039 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2046 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2048 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2049 const STDCHAR *buf = (const STDCHAR *) vbuf;
2053 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2057 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2058 if ((SSize_t) count < avail)
2060 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2061 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2081 Copy(buf,b->ptr,avail,STDCHAR);
2088 if (b->ptr >= (b->buf + b->bufsiz))
2091 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2097 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2100 if ((code = PerlIO_flush(f)) == 0)
2102 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2103 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2104 code = PerlIO_seek(PerlIONext(f),offset,whence);
2107 b->posn = PerlIO_tell(PerlIONext(f));
2114 PerlIOBuf_tell(PerlIO *f)
2116 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2117 Off_t posn = b->posn;
2119 posn += (b->ptr - b->buf);
2124 PerlIOBuf_close(PerlIO *f)
2127 IV code = PerlIOBase_close(f);
2128 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2129 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2131 PerlMemShared_free(b->buf);
2134 b->ptr = b->end = b->buf;
2135 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2140 PerlIOBuf_setlinebuf(PerlIO *f)
2144 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2149 PerlIOBuf_get_ptr(PerlIO *f)
2151 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2158 PerlIOBuf_get_cnt(PerlIO *f)
2160 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2163 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2164 return (b->end - b->ptr);
2169 PerlIOBuf_get_base(PerlIO *f)
2171 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2177 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2180 b->buf = (STDCHAR *)&b->oneword;
2181 b->bufsiz = sizeof(b->oneword);
2190 PerlIOBuf_bufsiz(PerlIO *f)
2192 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2195 return (b->end - b->buf);
2199 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2201 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2205 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2208 assert(PerlIO_get_cnt(f) == cnt);
2209 assert(b->ptr >= b->buf);
2211 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2214 PerlIO_funcs PerlIO_perlio = {
2234 PerlIOBase_clearerr,
2235 PerlIOBuf_setlinebuf,
2240 PerlIOBuf_set_ptrcnt,
2243 /*--------------------------------------------------------------------------------------*/
2244 /* Temp layer to hold unread chars when cannot do it any other way */
2247 PerlIOPending_fill(PerlIO *f)
2249 /* Should never happen */
2255 PerlIOPending_close(PerlIO *f)
2257 /* A tad tricky - flush pops us, then we close new top */
2259 return PerlIO_close(f);
2263 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2265 /* A tad tricky - flush pops us, then we seek new top */
2267 return PerlIO_seek(f,offset,whence);
2272 PerlIOPending_flush(PerlIO *f)
2274 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2275 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2278 PerlMemShared_free(b->buf);
2286 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2294 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2299 PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2301 IV code = PerlIOBase_pushed(f,mode,arg,len);
2302 PerlIOl *l = PerlIOBase(f);
2303 /* Our PerlIO_fast_gets must match what we are pushed on,
2304 or sv_gets() etc. get muddled when it changes mid-string
2307 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2308 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
2313 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2315 SSize_t avail = PerlIO_get_cnt(f);
2320 got = PerlIOBuf_read(f,vbuf,avail);
2322 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2327 PerlIO_funcs PerlIO_pending = {
2335 PerlIOPending_pushed,
2342 PerlIOPending_close,
2343 PerlIOPending_flush,
2347 PerlIOBase_clearerr,
2348 PerlIOBuf_setlinebuf,
2353 PerlIOPending_set_ptrcnt,
2358 /*--------------------------------------------------------------------------------------*/
2359 /* crlf - translation
2360 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2361 to hand back a line at a time and keeping a record of which nl we "lied" about.
2362 On write translate "\n" to CR,LF
2367 PerlIOBuf base; /* PerlIOBuf stuff */
2368 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2372 PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2375 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2376 code = PerlIOBuf_pushed(f,mode,arg,len);
2378 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2379 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2380 PerlIOBase(f)->flags);
2387 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2389 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2395 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2396 return PerlIOBuf_unread(f,vbuf,count);
2399 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2400 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2402 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2408 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2410 b->end = b->ptr = b->buf + b->bufsiz;
2411 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2412 b->posn -= b->bufsiz;
2414 while (count > 0 && b->ptr > b->buf)
2419 if (b->ptr - 2 >= b->buf)
2445 PerlIOCrlf_get_cnt(PerlIO *f)
2447 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2450 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2452 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2453 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2455 STDCHAR *nl = b->ptr;
2457 while (nl < b->end && *nl != 0xd)
2459 if (nl < b->end && *nl == 0xd)
2471 /* Not CR,LF but just CR */
2478 /* Blast - found CR as last char in buffer */
2481 /* They may not care, defer work as long as possible */
2482 return (nl - b->ptr);
2488 b->ptr++; /* say we have read it as far as flush() is concerned */
2489 b->buf++; /* Leave space an front of buffer */
2490 b->bufsiz--; /* Buffer is thus smaller */
2491 code = PerlIO_fill(f); /* Fetch some more */
2492 b->bufsiz++; /* Restore size for next time */
2493 b->buf--; /* Point at space */
2494 b->ptr = nl = b->buf; /* Which is what we hand off */
2495 b->posn--; /* Buffer starts here */
2496 *nl = 0xd; /* Fill in the CR */
2498 goto test; /* fill() call worked */
2499 /* CR at EOF - just fall through */
2504 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2510 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2512 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2513 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2514 IV flags = PerlIOBase(f)->flags;
2524 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2531 /* Test code - delete when it works ... */
2538 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2546 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2547 ptr, chk, flags, c->nl, b->end, cnt);
2554 /* They have taken what we lied about */
2561 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2565 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2567 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2568 return PerlIOBuf_write(f,vbuf,count);
2571 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2572 const STDCHAR *buf = (const STDCHAR *) vbuf;
2573 const STDCHAR *ebuf = buf+count;
2576 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2580 STDCHAR *eptr = b->buf+b->bufsiz;
2581 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2582 while (buf < ebuf && b->ptr < eptr)
2586 if ((b->ptr + 2) > eptr)
2588 /* Not room for both */
2594 *(b->ptr)++ = 0xd; /* CR */
2595 *(b->ptr)++ = 0xa; /* LF */
2597 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2616 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2618 return (buf - (STDCHAR *) vbuf);
2623 PerlIOCrlf_flush(PerlIO *f)
2625 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2631 return PerlIOBuf_flush(f);
2634 PerlIO_funcs PerlIO_crlf = {
2637 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2643 PerlIOBase_noop_ok, /* popped */
2644 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2645 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2646 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2654 PerlIOBase_clearerr,
2655 PerlIOBuf_setlinebuf,
2660 PerlIOCrlf_set_ptrcnt,
2664 /*--------------------------------------------------------------------------------------*/
2665 /* mmap as "buffer" layer */
2669 PerlIOBuf base; /* PerlIOBuf stuff */
2670 Mmap_t mptr; /* Mapped address */
2671 Size_t len; /* mapped length */
2672 STDCHAR *bbuf; /* malloced buffer if map fails */
2675 static size_t page_size = 0;
2678 PerlIOMmap_map(PerlIO *f)
2681 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2682 PerlIOBuf *b = &m->base;
2683 IV flags = PerlIOBase(f)->flags;
2687 if (flags & PERLIO_F_CANREAD)
2689 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2690 int fd = PerlIO_fileno(f);
2692 code = fstat(fd,&st);
2693 if (code == 0 && S_ISREG(st.st_mode))
2695 SSize_t len = st.st_size - b->posn;
2700 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2702 SETERRNO(0,SS$_NORMAL);
2703 # ifdef _SC_PAGESIZE
2704 page_size = sysconf(_SC_PAGESIZE);
2706 page_size = sysconf(_SC_PAGE_SIZE);
2708 if ((long)page_size < 0) {
2713 (void)SvUPGRADE(error, SVt_PV);
2714 msg = SvPVx(error, n_a);
2715 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2718 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2722 # ifdef HAS_GETPAGESIZE
2723 page_size = getpagesize();
2725 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2726 page_size = PAGESIZE; /* compiletime, bad */
2730 if ((IV)page_size <= 0)
2731 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2735 /* This is a hack - should never happen - open should have set it ! */
2736 b->posn = PerlIO_tell(PerlIONext(f));
2738 posn = (b->posn / page_size) * page_size;
2739 len = st.st_size - posn;
2740 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2741 if (m->mptr && m->mptr != (Mmap_t) -1)
2743 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2744 madvise(m->mptr, len, MADV_SEQUENTIAL);
2746 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2747 madvise(m->mptr, len, MADV_WILLNEED);
2749 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2750 b->end = ((STDCHAR *)m->mptr) + len;
2751 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2762 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2764 b->ptr = b->end = b->ptr;
2773 PerlIOMmap_unmap(PerlIO *f)
2775 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2776 PerlIOBuf *b = &m->base;
2782 code = munmap(m->mptr, m->len);
2786 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2789 b->ptr = b->end = b->buf;
2790 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2796 PerlIOMmap_get_base(PerlIO *f)
2798 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2799 PerlIOBuf *b = &m->base;
2800 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2802 /* Already have a readbuffer in progress */
2807 /* We have a write buffer or flushed PerlIOBuf read buffer */
2808 m->bbuf = b->buf; /* save it in case we need it again */
2809 b->buf = NULL; /* Clear to trigger below */
2813 PerlIOMmap_map(f); /* Try and map it */
2816 /* Map did not work - recover PerlIOBuf buffer if we have one */
2820 b->ptr = b->end = b->buf;
2823 return PerlIOBuf_get_base(f);
2827 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2829 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2830 PerlIOBuf *b = &m->base;
2831 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2833 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2836 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2841 /* Loose the unwritable mapped buffer */
2843 /* If flush took the "buffer" see if we have one from before */
2844 if (!b->buf && m->bbuf)
2848 PerlIOBuf_get_base(f);
2852 return PerlIOBuf_unread(f,vbuf,count);
2856 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2858 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2859 PerlIOBuf *b = &m->base;
2860 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2862 /* No, or wrong sort of, buffer */
2865 if (PerlIOMmap_unmap(f) != 0)
2868 /* If unmap took the "buffer" see if we have one from before */
2869 if (!b->buf && m->bbuf)
2873 PerlIOBuf_get_base(f);
2877 return PerlIOBuf_write(f,vbuf,count);
2881 PerlIOMmap_flush(PerlIO *f)
2883 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2884 PerlIOBuf *b = &m->base;
2885 IV code = PerlIOBuf_flush(f);
2886 /* Now we are "synced" at PerlIOBuf level */
2891 /* Unmap the buffer */
2892 if (PerlIOMmap_unmap(f) != 0)
2897 /* We seem to have a PerlIOBuf buffer which was not mapped
2898 * remember it in case we need one later
2907 PerlIOMmap_fill(PerlIO *f)
2909 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2910 IV code = PerlIO_flush(f);
2911 if (code == 0 && !b->buf)
2913 code = PerlIOMmap_map(f);
2915 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2917 code = PerlIOBuf_fill(f);
2923 PerlIOMmap_close(PerlIO *f)
2925 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2926 PerlIOBuf *b = &m->base;
2927 IV code = PerlIO_flush(f);
2932 b->ptr = b->end = b->buf;
2934 if (PerlIOBuf_close(f) != 0)
2940 PerlIO_funcs PerlIO_mmap = {
2960 PerlIOBase_clearerr,
2961 PerlIOBuf_setlinebuf,
2962 PerlIOMmap_get_base,
2966 PerlIOBuf_set_ptrcnt,
2969 #endif /* HAS_MMAP */
2977 atexit(&PerlIO_cleanup);
2987 PerlIO_stdstreams();
2991 #undef PerlIO_stdout
2996 PerlIO_stdstreams();
3000 #undef PerlIO_stderr
3005 PerlIO_stdstreams();
3009 /*--------------------------------------------------------------------------------------*/
3011 #undef PerlIO_getname
3013 PerlIO_getname(PerlIO *f, char *buf)
3016 Perl_croak(aTHX_ "Don't know how to get file name");
3021 /*--------------------------------------------------------------------------------------*/
3022 /* Functions which can be called on any kind of PerlIO implemented
3028 PerlIO_getc(PerlIO *f)
3031 SSize_t count = PerlIO_read(f,buf,1);
3034 return (unsigned char) buf[0];
3039 #undef PerlIO_ungetc
3041 PerlIO_ungetc(PerlIO *f, int ch)
3046 if (PerlIO_unread(f,&buf,1) == 1)
3054 PerlIO_putc(PerlIO *f, int ch)
3057 return PerlIO_write(f,&buf,1);
3062 PerlIO_puts(PerlIO *f, const char *s)
3064 STRLEN len = strlen(s);
3065 return PerlIO_write(f,s,len);
3068 #undef PerlIO_rewind
3070 PerlIO_rewind(PerlIO *f)
3072 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3076 #undef PerlIO_vprintf
3078 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3081 SV *sv = newSVpvn("",0);
3086 Perl_va_copy(ap, apc);
3087 sv_vcatpvf(sv, fmt, &apc);
3089 sv_vcatpvf(sv, fmt, &ap);
3092 return PerlIO_write(f,s,len);
3095 #undef PerlIO_printf
3097 PerlIO_printf(PerlIO *f,const char *fmt,...)
3102 result = PerlIO_vprintf(f,fmt,ap);
3107 #undef PerlIO_stdoutf
3109 PerlIO_stdoutf(const char *fmt,...)
3114 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3119 #undef PerlIO_tmpfile
3121 PerlIO_tmpfile(void)
3123 /* I have no idea how portable mkstemp() is ... */
3124 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3127 FILE *stdio = PerlSIO_tmpfile();
3130 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3136 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3137 int fd = mkstemp(SvPVX(sv));
3141 f = PerlIO_fdopen(fd,"w+");
3144 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3146 PerlLIO_unlink(SvPVX(sv));
3156 #endif /* USE_SFIO */
3157 #endif /* PERLIO_IS_STDIO */
3159 /*======================================================================================*/
3160 /* Now some functions in terms of above which may be needed even if
3161 we are not in true PerlIO mode
3165 #undef PerlIO_setpos
3167 PerlIO_setpos(PerlIO *f, SV *pos)
3173 Off_t *posn = (Off_t *) SvPV(pos,len);
3174 if (f && len == sizeof(Off_t))
3175 return PerlIO_seek(f,*posn,SEEK_SET);
3181 #undef PerlIO_setpos
3183 PerlIO_setpos(PerlIO *f, SV *pos)
3189 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3190 if (f && len == sizeof(Fpos_t))
3192 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3193 return fsetpos64(f, fpos);
3195 return fsetpos(f, fpos);
3205 #undef PerlIO_getpos
3207 PerlIO_getpos(PerlIO *f, SV *pos)
3210 Off_t posn = PerlIO_tell(f);
3211 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3212 return (posn == (Off_t)-1) ? -1 : 0;
3215 #undef PerlIO_getpos
3217 PerlIO_getpos(PerlIO *f, SV *pos)
3222 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3223 code = fgetpos64(f, &fpos);
3225 code = fgetpos(f, &fpos);
3227 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3232 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3235 vprintf(char *pat, char *args)
3237 _doprnt(pat, args, stdout);
3238 return 0; /* wrong, but perl doesn't use the return value */
3242 vfprintf(FILE *fd, char *pat, char *args)
3244 _doprnt(pat, args, fd);
3245 return 0; /* wrong, but perl doesn't use the return value */
3250 #ifndef PerlIO_vsprintf
3252 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3254 int val = vsprintf(s, fmt, ap);
3257 if (strlen(s) >= (STRLEN)n)
3260 (void)PerlIO_puts(Perl_error_log,
3261 "panic: sprintf overflow - memory corrupted!\n");
3269 #ifndef PerlIO_sprintf
3271 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3276 result = PerlIO_vsprintf(s, n, fmt, ap);