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)
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)
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) != 0)
539 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
543 const char *s = names;
553 while (*e && *e != ':' && !isSPACE(*e))
557 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
559 /* Pop back to bottom layer */
563 while (PerlIONext(f))
571 SV *layer = PerlIO_find_layer(s,e-s);
574 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
577 PerlIO *new = PerlIO_push(f,tab,mode);
583 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
595 /*--------------------------------------------------------------------------------------*/
596 /* Given the abstraction above the public API functions */
599 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
601 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
602 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
603 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
609 if (PerlIOBase(top)->tab == &PerlIO_crlf)
612 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
615 top = PerlIONext(top);
618 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
623 PerlIO__close(PerlIO *f)
625 return (*PerlIOBase(f)->tab->Close)(f);
628 #undef PerlIO_fdupopen
630 PerlIO_fdupopen(pTHX_ PerlIO *f)
633 int fd = PerlLIO_dup(PerlIO_fileno(f));
634 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
637 Off_t posn = PerlIO_tell(f);
638 PerlIO_seek(new,posn,SEEK_SET);
645 PerlIO_close(PerlIO *f)
647 int code = (*PerlIOBase(f)->tab->Close)(f);
657 PerlIO_fileno(PerlIO *f)
659 return (*PerlIOBase(f)->tab->Fileno)(f);
666 PerlIO_fdopen(int fd, const char *mode)
668 PerlIO_funcs *tab = PerlIO_default_top();
671 return (*tab->Fdopen)(tab,fd,mode);
676 PerlIO_open(const char *path, const char *mode)
678 PerlIO_funcs *tab = PerlIO_default_top();
681 return (*tab->Open)(tab,path,mode);
686 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
691 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
693 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
699 return PerlIO_open(path,mode);
704 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
706 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
711 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
713 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
718 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
720 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
725 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
727 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
732 PerlIO_tell(PerlIO *f)
734 return (*PerlIOBase(f)->tab->Tell)(f);
739 PerlIO_flush(PerlIO *f)
743 return (*PerlIOBase(f)->tab->Flush)(f);
747 PerlIO **table = &_perlio;
752 table = (PerlIO **)(f++);
753 for (i=1; i < PERLIO_TABLE_SIZE; i++)
755 if (*f && PerlIO_flush(f) != 0)
766 PerlIO_fill(PerlIO *f)
768 return (*PerlIOBase(f)->tab->Fill)(f);
773 PerlIO_isutf8(PerlIO *f)
775 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
780 PerlIO_eof(PerlIO *f)
782 return (*PerlIOBase(f)->tab->Eof)(f);
787 PerlIO_error(PerlIO *f)
789 return (*PerlIOBase(f)->tab->Error)(f);
792 #undef PerlIO_clearerr
794 PerlIO_clearerr(PerlIO *f)
797 (*PerlIOBase(f)->tab->Clearerr)(f);
800 #undef PerlIO_setlinebuf
802 PerlIO_setlinebuf(PerlIO *f)
804 (*PerlIOBase(f)->tab->Setlinebuf)(f);
807 #undef PerlIO_has_base
809 PerlIO_has_base(PerlIO *f)
813 return (PerlIOBase(f)->tab->Get_base != NULL);
818 #undef PerlIO_fast_gets
820 PerlIO_fast_gets(PerlIO *f)
822 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
824 PerlIO_funcs *tab = PerlIOBase(f)->tab;
825 return (tab->Set_ptrcnt != NULL);
830 #undef PerlIO_has_cntptr
832 PerlIO_has_cntptr(PerlIO *f)
836 PerlIO_funcs *tab = PerlIOBase(f)->tab;
837 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
842 #undef PerlIO_canset_cnt
844 PerlIO_canset_cnt(PerlIO *f)
848 PerlIOl *l = PerlIOBase(f);
849 return (l->tab->Set_ptrcnt != NULL);
854 #undef PerlIO_get_base
856 PerlIO_get_base(PerlIO *f)
858 return (*PerlIOBase(f)->tab->Get_base)(f);
861 #undef PerlIO_get_bufsiz
863 PerlIO_get_bufsiz(PerlIO *f)
865 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
868 #undef PerlIO_get_ptr
870 PerlIO_get_ptr(PerlIO *f)
872 PerlIO_funcs *tab = PerlIOBase(f)->tab;
873 if (tab->Get_ptr == NULL)
875 return (*tab->Get_ptr)(f);
878 #undef PerlIO_get_cnt
880 PerlIO_get_cnt(PerlIO *f)
882 PerlIO_funcs *tab = PerlIOBase(f)->tab;
883 if (tab->Get_cnt == NULL)
885 return (*tab->Get_cnt)(f);
888 #undef PerlIO_set_cnt
890 PerlIO_set_cnt(PerlIO *f,int cnt)
892 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
895 #undef PerlIO_set_ptrcnt
897 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
899 PerlIO_funcs *tab = PerlIOBase(f)->tab;
900 if (tab->Set_ptrcnt == NULL)
903 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
905 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
908 /*--------------------------------------------------------------------------------------*/
909 /* "Methods" of the "base class" */
912 PerlIOBase_fileno(PerlIO *f)
914 return PerlIO_fileno(PerlIONext(f));
918 PerlIO_modestr(PerlIO *f,char *buf)
921 IV flags = PerlIOBase(f)->flags;
922 if (flags & PERLIO_F_APPEND)
925 if (flags & PERLIO_F_CANREAD)
930 else if (flags & PERLIO_F_CANREAD)
933 if (flags & PERLIO_F_CANWRITE)
936 else if (flags & PERLIO_F_CANWRITE)
939 if (flags & PERLIO_F_CANREAD)
944 #if O_TEXT != O_BINARY
945 if (!(flags & PERLIO_F_CRLF))
953 PerlIOBase_pushed(PerlIO *f, const char *mode)
955 PerlIOl *l = PerlIOBase(f);
956 const char *omode = mode;
958 PerlIO_funcs *tab = PerlIOBase(f)->tab;
959 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
960 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
961 if (tab->Set_ptrcnt != NULL)
962 l->flags |= PERLIO_F_FASTGETS;
968 l->flags |= PERLIO_F_CANREAD;
971 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
974 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
985 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
988 l->flags &= ~PERLIO_F_CRLF;
991 l->flags |= PERLIO_F_CRLF;
1003 l->flags |= l->next->flags &
1004 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1008 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1009 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1010 l->flags,PerlIO_modestr(f,temp));
1016 PerlIOBase_popped(PerlIO *f)
1021 extern PerlIO_funcs PerlIO_pending;
1024 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1027 Off_t old = PerlIO_tell(f);
1028 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1030 Off_t new = PerlIO_tell(f);
1038 PerlIO_push(f,&PerlIO_pending,"r");
1039 return PerlIOBuf_unread(f,vbuf,count);
1044 PerlIOBase_noop_ok(PerlIO *f)
1050 PerlIOBase_noop_fail(PerlIO *f)
1056 PerlIOBase_close(PerlIO *f)
1059 PerlIO *n = PerlIONext(f);
1060 if (PerlIO_flush(f) != 0)
1062 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
1064 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
1069 PerlIOBase_eof(PerlIO *f)
1073 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1079 PerlIOBase_error(PerlIO *f)
1083 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1089 PerlIOBase_clearerr(PerlIO *f)
1093 PerlIO *n = PerlIONext(f);
1094 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1101 PerlIOBase_setlinebuf(PerlIO *f)
1106 /*--------------------------------------------------------------------------------------*/
1107 /* Bottom-most level for UNIX-like case */
1111 struct _PerlIO base; /* The generic part */
1112 int fd; /* UNIX like file descriptor */
1113 int oflags; /* open/fcntl flags */
1117 PerlIOUnix_oflags(const char *mode)
1132 oflags = O_CREAT|O_TRUNC;
1143 oflags = O_CREAT|O_APPEND;
1159 else if (*mode == 't')
1162 oflags &= ~O_BINARY;
1165 /* Always open in binary mode */
1167 if (*mode || oflags == -1)
1176 PerlIOUnix_fileno(PerlIO *f)
1178 return PerlIOSelf(f,PerlIOUnix)->fd;
1182 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1190 int oflags = PerlIOUnix_oflags(mode);
1193 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1196 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1203 PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1207 int oflags = PerlIOUnix_oflags(mode);
1210 int fd = PerlLIO_open3(path,oflags,0666);
1213 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
1216 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1223 PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1225 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1226 int oflags = PerlIOUnix_oflags(mode);
1227 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1228 (*PerlIOBase(f)->tab->Close)(f);
1232 int fd = PerlLIO_open3(path,oflags,0666);
1237 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1245 PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1248 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1249 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1253 SSize_t len = PerlLIO_read(fd,vbuf,count);
1254 if (len >= 0 || errno != EINTR)
1257 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1258 else if (len == 0 && count != 0)
1259 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1266 PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1269 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1272 SSize_t len = PerlLIO_write(fd,vbuf,count);
1273 if (len >= 0 || errno != EINTR)
1276 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1283 PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1286 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1287 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1288 return (new == (Off_t) -1) ? -1 : 0;
1292 PerlIOUnix_tell(PerlIO *f)
1295 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1299 PerlIOUnix_close(PerlIO *f)
1302 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1304 while (PerlLIO_close(fd) != 0)
1314 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1319 PerlIO_funcs PerlIO_unix = {
1335 PerlIOBase_noop_ok, /* flush */
1336 PerlIOBase_noop_fail, /* fill */
1339 PerlIOBase_clearerr,
1340 PerlIOBase_setlinebuf,
1341 NULL, /* get_base */
1342 NULL, /* get_bufsiz */
1345 NULL, /* set_ptrcnt */
1348 /*--------------------------------------------------------------------------------------*/
1349 /* stdio as a layer */
1353 struct _PerlIO base;
1354 FILE * stdio; /* The stream */
1358 PerlIOStdio_fileno(PerlIO *f)
1361 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1365 PerlIOStdio_mode(const char *mode,char *tmode)
1367 const char *ret = mode;
1368 if (O_BINARY != O_TEXT)
1370 ret = (const char *) tmode;
1382 PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1401 stdio = PerlSIO_stdin;
1404 stdio = PerlSIO_stdout;
1407 stdio = PerlSIO_stderr;
1413 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1417 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
1424 #undef PerlIO_importFILE
1426 PerlIO_importFILE(FILE *stdio, int fl)
1432 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
1439 PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1443 FILE *stdio = PerlSIO_fopen(path,mode);
1447 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1448 (mode = PerlIOStdio_mode(mode,tmode))),
1456 PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1459 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1461 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
1469 PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1472 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1476 STDCHAR *buf = (STDCHAR *) vbuf;
1477 /* Perl is expecting PerlIO_getc() to fill the buffer
1478 * Linux's stdio does not do that for fread()
1480 int ch = PerlSIO_fgetc(s);
1488 got = PerlSIO_fread(vbuf,1,count,s);
1493 PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1496 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1497 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1501 int ch = *buf-- & 0xff;
1502 if (PerlSIO_ungetc(ch,s) != ch)
1511 PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1514 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1518 PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1521 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1522 return PerlSIO_fseek(stdio,offset,whence);
1526 PerlIOStdio_tell(PerlIO *f)
1529 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1530 return PerlSIO_ftell(stdio);
1534 PerlIOStdio_close(PerlIO *f)
1537 int optval, optlen = sizeof(int);
1538 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1540 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1541 PerlSIO_fclose(stdio) :
1542 close(PerlIO_fileno(f)));
1546 PerlIOStdio_flush(PerlIO *f)
1549 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1550 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1552 return PerlSIO_fflush(stdio);
1557 /* FIXME: This discards ungetc() and pre-read stuff which is
1558 not right if this is just a "sync" from a layer above
1559 Suspect right design is to do _this_ but not have layer above
1560 flush this layer read-to-read
1562 /* Not writeable - sync by attempting a seek */
1564 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1572 PerlIOStdio_fill(PerlIO *f)
1575 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1577 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1578 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1580 if (PerlSIO_fflush(stdio) != 0)
1583 c = PerlSIO_fgetc(stdio);
1584 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1590 PerlIOStdio_eof(PerlIO *f)
1593 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1597 PerlIOStdio_error(PerlIO *f)
1600 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1604 PerlIOStdio_clearerr(PerlIO *f)
1607 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1611 PerlIOStdio_setlinebuf(PerlIO *f)
1614 #ifdef HAS_SETLINEBUF
1615 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1617 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1623 PerlIOStdio_get_base(PerlIO *f)
1626 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1627 return PerlSIO_get_base(stdio);
1631 PerlIOStdio_get_bufsiz(PerlIO *f)
1634 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1635 return PerlSIO_get_bufsiz(stdio);
1639 #ifdef USE_STDIO_PTR
1641 PerlIOStdio_get_ptr(PerlIO *f)
1644 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1645 return PerlSIO_get_ptr(stdio);
1649 PerlIOStdio_get_cnt(PerlIO *f)
1652 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1653 return PerlSIO_get_cnt(stdio);
1657 PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1660 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1663 #ifdef STDIO_PTR_LVALUE
1664 PerlSIO_set_ptr(stdio,ptr);
1665 #ifdef STDIO_PTR_LVAL_SETS_CNT
1666 if (PerlSIO_get_cnt(stdio) != (cnt))
1669 assert(PerlSIO_get_cnt(stdio) == (cnt));
1672 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1673 /* Setting ptr _does_ change cnt - we are done */
1676 #else /* STDIO_PTR_LVALUE */
1678 #endif /* STDIO_PTR_LVALUE */
1680 /* Now (or only) set cnt */
1681 #ifdef STDIO_CNT_LVALUE
1682 PerlSIO_set_cnt(stdio,cnt);
1683 #else /* STDIO_CNT_LVALUE */
1684 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1685 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1686 #else /* STDIO_PTR_LVAL_SETS_CNT */
1688 #endif /* STDIO_PTR_LVAL_SETS_CNT */
1689 #endif /* STDIO_CNT_LVALUE */
1694 PerlIO_funcs PerlIO_stdio = {
1696 sizeof(PerlIOStdio),
1714 PerlIOStdio_clearerr,
1715 PerlIOStdio_setlinebuf,
1717 PerlIOStdio_get_base,
1718 PerlIOStdio_get_bufsiz,
1723 #ifdef USE_STDIO_PTR
1724 PerlIOStdio_get_ptr,
1725 PerlIOStdio_get_cnt,
1726 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1727 PerlIOStdio_set_ptrcnt
1728 #else /* STDIO_PTR_LVALUE */
1730 #endif /* STDIO_PTR_LVALUE */
1731 #else /* USE_STDIO_PTR */
1735 #endif /* USE_STDIO_PTR */
1738 #undef PerlIO_exportFILE
1740 PerlIO_exportFILE(PerlIO *f, int fl)
1743 /* Should really push stdio discipline when we have them */
1744 return fdopen(PerlIO_fileno(f),"r+");
1747 #undef PerlIO_findFILE
1749 PerlIO_findFILE(PerlIO *f)
1751 return PerlIO_exportFILE(f,0);
1754 #undef PerlIO_releaseFILE
1756 PerlIO_releaseFILE(PerlIO *p, FILE *f)
1760 /*--------------------------------------------------------------------------------------*/
1761 /* perlio buffer layer */
1764 PerlIOBuf_pushed(PerlIO *f, const char *mode)
1766 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1767 b->posn = PerlIO_tell(PerlIONext(f));
1768 return PerlIOBase_pushed(f,mode);
1772 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1775 PerlIO_funcs *tab = PerlIO_default_btm();
1783 #if O_BINARY != O_TEXT
1784 /* do something about failing setmode()? --jhi */
1785 PerlLIO_setmode(fd, O_BINARY);
1787 f = (*tab->Fdopen)(tab,fd,mode);
1790 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
1791 if (init && fd == 2)
1793 /* Initial stderr is unbuffered */
1794 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1797 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1798 self->name,f,fd,mode,PerlIOBase(f)->flags);
1805 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
1807 PerlIO_funcs *tab = PerlIO_default_btm();
1808 PerlIO *f = (*tab->Open)(tab,path,mode);
1811 PerlIO_push(f,self,mode);
1817 PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
1819 PerlIO *next = PerlIONext(f);
1820 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1822 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1826 /* This "flush" is akin to sfio's sync in that it handles files in either
1830 PerlIOBuf_flush(PerlIO *f)
1832 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1834 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1836 /* write() the buffer */
1837 STDCHAR *p = b->buf;
1839 PerlIO *n = PerlIONext(f);
1842 count = PerlIO_write(n,p,b->ptr - p);
1847 else if (count < 0 || PerlIO_error(n))
1849 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1854 b->posn += (p - b->buf);
1856 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1858 /* Note position change */
1859 b->posn += (b->ptr - b->buf);
1860 if (b->ptr < b->end)
1862 /* We did not consume all of it */
1863 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1865 b->posn = PerlIO_tell(PerlIONext(f));
1869 b->ptr = b->end = b->buf;
1870 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1871 /* FIXME: Is this right for read case ? */
1872 if (PerlIO_flush(PerlIONext(f)) != 0)
1878 PerlIOBuf_fill(PerlIO *f)
1880 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1881 PerlIO *n = PerlIONext(f);
1883 /* FIXME: doing the down-stream flush is a bad idea if it causes
1884 pre-read data in stdio buffer to be discarded
1885 but this is too simplistic - as it skips _our_ hosekeeping
1886 and breaks tell tests.
1887 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1891 if (PerlIO_flush(f) != 0)
1894 b->ptr = b->end = b->buf;
1895 if (PerlIO_fast_gets(n))
1897 /* Layer below is also buffered
1898 * We do _NOT_ want to call its ->Read() because that will loop
1899 * till it gets what we asked for which may hang on a pipe etc.
1900 * Instead take anything it has to hand, or ask it to fill _once_.
1902 avail = PerlIO_get_cnt(n);
1905 avail = PerlIO_fill(n);
1907 avail = PerlIO_get_cnt(n);
1910 if (!PerlIO_error(n) && PerlIO_eof(n))
1916 STDCHAR *ptr = PerlIO_get_ptr(n);
1917 SSize_t cnt = avail;
1918 if (avail > b->bufsiz)
1920 Copy(ptr,b->buf,avail,STDCHAR);
1921 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1926 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1931 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1933 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1936 b->end = b->buf+avail;
1937 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1942 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1944 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1945 STDCHAR *buf = (STDCHAR *) vbuf;
1950 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1954 SSize_t avail = PerlIO_get_cnt(f);
1955 SSize_t take = (count < avail) ? count : avail;
1958 STDCHAR *ptr = PerlIO_get_ptr(f);
1959 Copy(ptr,buf,take,STDCHAR);
1960 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1964 if (count > 0 && avail <= 0)
1966 if (PerlIO_fill(f) != 0)
1970 return (buf - (STDCHAR *) vbuf);
1976 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
1978 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1979 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1982 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1988 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1990 avail = (b->ptr - b->buf);
1995 b->end = b->buf + avail;
1997 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1998 b->posn -= b->bufsiz;
2000 if (avail > (SSize_t) count)
2008 Copy(buf,b->ptr,avail,STDCHAR);
2012 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2019 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2021 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2022 const STDCHAR *buf = (const STDCHAR *) vbuf;
2026 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2030 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2031 if ((SSize_t) count < avail)
2033 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2034 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2054 Copy(buf,b->ptr,avail,STDCHAR);
2061 if (b->ptr >= (b->buf + b->bufsiz))
2064 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2070 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2073 if ((code = PerlIO_flush(f)) == 0)
2075 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2076 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2077 code = PerlIO_seek(PerlIONext(f),offset,whence);
2080 b->posn = PerlIO_tell(PerlIONext(f));
2087 PerlIOBuf_tell(PerlIO *f)
2089 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2090 Off_t posn = b->posn;
2092 posn += (b->ptr - b->buf);
2097 PerlIOBuf_close(PerlIO *f)
2100 IV code = PerlIOBase_close(f);
2101 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2102 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2104 PerlMemShared_free(b->buf);
2107 b->ptr = b->end = b->buf;
2108 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2113 PerlIOBuf_setlinebuf(PerlIO *f)
2117 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2122 PerlIOBuf_get_ptr(PerlIO *f)
2124 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2131 PerlIOBuf_get_cnt(PerlIO *f)
2133 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2136 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2137 return (b->end - b->ptr);
2142 PerlIOBuf_get_base(PerlIO *f)
2144 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2150 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2153 b->buf = (STDCHAR *)&b->oneword;
2154 b->bufsiz = sizeof(b->oneword);
2163 PerlIOBuf_bufsiz(PerlIO *f)
2165 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2168 return (b->end - b->buf);
2172 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2174 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2178 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2181 assert(PerlIO_get_cnt(f) == cnt);
2182 assert(b->ptr >= b->buf);
2184 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2187 PerlIO_funcs PerlIO_perlio = {
2207 PerlIOBase_clearerr,
2208 PerlIOBuf_setlinebuf,
2213 PerlIOBuf_set_ptrcnt,
2216 /*--------------------------------------------------------------------------------------*/
2217 /* Temp layer to hold unread chars when cannot do it any other way */
2220 PerlIOPending_fill(PerlIO *f)
2222 /* Should never happen */
2228 PerlIOPending_close(PerlIO *f)
2230 /* A tad tricky - flush pops us, then we close new top */
2232 return PerlIO_close(f);
2236 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2238 /* A tad tricky - flush pops us, then we seek new top */
2240 return PerlIO_seek(f,offset,whence);
2245 PerlIOPending_flush(PerlIO *f)
2247 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2248 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2251 PerlMemShared_free(b->buf);
2259 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2267 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2272 PerlIOPending_pushed(PerlIO *f,const char *mode)
2274 IV code = PerlIOBuf_pushed(f,mode);
2275 PerlIOl *l = PerlIOBase(f);
2276 /* Our PerlIO_fast_gets must match what we are pushed on,
2277 or sv_gets() etc. get muddled when it changes mid-string
2280 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2281 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2286 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2288 SSize_t avail = PerlIO_get_cnt(f);
2293 got = PerlIOBuf_read(f,vbuf,avail);
2295 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2300 PerlIO_funcs PerlIO_pending = {
2308 PerlIOPending_pushed,
2315 PerlIOPending_close,
2316 PerlIOPending_flush,
2320 PerlIOBase_clearerr,
2321 PerlIOBuf_setlinebuf,
2326 PerlIOPending_set_ptrcnt,
2331 /*--------------------------------------------------------------------------------------*/
2332 /* crlf - translation
2333 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2334 to hand back a line at a time and keeping a record of which nl we "lied" about.
2335 On write translate "\n" to CR,LF
2340 PerlIOBuf base; /* PerlIOBuf stuff */
2341 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2345 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2348 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2349 code = PerlIOBuf_pushed(f,mode);
2351 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2352 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2353 PerlIOBase(f)->flags);
2360 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2362 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2368 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2369 return PerlIOBuf_unread(f,vbuf,count);
2372 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2373 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2375 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2381 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2383 b->end = b->ptr = b->buf + b->bufsiz;
2384 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2385 b->posn -= b->bufsiz;
2387 while (count > 0 && b->ptr > b->buf)
2392 if (b->ptr - 2 >= b->buf)
2418 PerlIOCrlf_get_cnt(PerlIO *f)
2420 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2423 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2425 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2426 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2428 STDCHAR *nl = b->ptr;
2430 while (nl < b->end && *nl != 0xd)
2432 if (nl < b->end && *nl == 0xd)
2444 /* Not CR,LF but just CR */
2451 /* Blast - found CR as last char in buffer */
2454 /* They may not care, defer work as long as possible */
2455 return (nl - b->ptr);
2461 b->ptr++; /* say we have read it as far as flush() is concerned */
2462 b->buf++; /* Leave space an front of buffer */
2463 b->bufsiz--; /* Buffer is thus smaller */
2464 code = PerlIO_fill(f); /* Fetch some more */
2465 b->bufsiz++; /* Restore size for next time */
2466 b->buf--; /* Point at space */
2467 b->ptr = nl = b->buf; /* Which is what we hand off */
2468 b->posn--; /* Buffer starts here */
2469 *nl = 0xd; /* Fill in the CR */
2471 goto test; /* fill() call worked */
2472 /* CR at EOF - just fall through */
2477 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2483 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2485 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2486 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2487 IV flags = PerlIOBase(f)->flags;
2497 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2504 /* Test code - delete when it works ... */
2511 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2519 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2520 ptr, chk, flags, c->nl, b->end, cnt);
2527 /* They have taken what we lied about */
2534 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2538 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2540 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2541 return PerlIOBuf_write(f,vbuf,count);
2544 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2545 const STDCHAR *buf = (const STDCHAR *) vbuf;
2546 const STDCHAR *ebuf = buf+count;
2549 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2553 STDCHAR *eptr = b->buf+b->bufsiz;
2554 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2555 while (buf < ebuf && b->ptr < eptr)
2559 if ((b->ptr + 2) > eptr)
2561 /* Not room for both */
2567 *(b->ptr)++ = 0xd; /* CR */
2568 *(b->ptr)++ = 0xa; /* LF */
2570 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2589 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2591 return (buf - (STDCHAR *) vbuf);
2596 PerlIOCrlf_flush(PerlIO *f)
2598 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2604 return PerlIOBuf_flush(f);
2607 PerlIO_funcs PerlIO_crlf = {
2610 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2616 PerlIOBase_noop_ok, /* popped */
2617 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2618 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2619 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2627 PerlIOBase_clearerr,
2628 PerlIOBuf_setlinebuf,
2633 PerlIOCrlf_set_ptrcnt,
2637 /*--------------------------------------------------------------------------------------*/
2638 /* mmap as "buffer" layer */
2642 PerlIOBuf base; /* PerlIOBuf stuff */
2643 Mmap_t mptr; /* Mapped address */
2644 Size_t len; /* mapped length */
2645 STDCHAR *bbuf; /* malloced buffer if map fails */
2648 static size_t page_size = 0;
2651 PerlIOMmap_map(PerlIO *f)
2654 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2655 PerlIOBuf *b = &m->base;
2656 IV flags = PerlIOBase(f)->flags;
2660 if (flags & PERLIO_F_CANREAD)
2662 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2663 int fd = PerlIO_fileno(f);
2665 code = fstat(fd,&st);
2666 if (code == 0 && S_ISREG(st.st_mode))
2668 SSize_t len = st.st_size - b->posn;
2673 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2675 SETERRNO(0,SS$_NORMAL);
2676 # ifdef _SC_PAGESIZE
2677 page_size = sysconf(_SC_PAGESIZE);
2679 page_size = sysconf(_SC_PAGE_SIZE);
2681 if ((long)page_size < 0) {
2686 (void)SvUPGRADE(error, SVt_PV);
2687 msg = SvPVx(error, n_a);
2688 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2691 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2695 # ifdef HAS_GETPAGESIZE
2696 page_size = getpagesize();
2698 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2699 page_size = PAGESIZE; /* compiletime, bad */
2703 if ((IV)page_size <= 0)
2704 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2708 /* This is a hack - should never happen - open should have set it ! */
2709 b->posn = PerlIO_tell(PerlIONext(f));
2711 posn = (b->posn / page_size) * page_size;
2712 len = st.st_size - posn;
2713 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2714 if (m->mptr && m->mptr != (Mmap_t) -1)
2716 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2717 madvise(m->mptr, len, MADV_SEQUENTIAL);
2719 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2720 b->end = ((STDCHAR *)m->mptr) + len;
2721 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2732 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2734 b->ptr = b->end = b->ptr;
2743 PerlIOMmap_unmap(PerlIO *f)
2745 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2746 PerlIOBuf *b = &m->base;
2752 code = munmap(m->mptr, m->len);
2756 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2759 b->ptr = b->end = b->buf;
2760 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2766 PerlIOMmap_get_base(PerlIO *f)
2768 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2769 PerlIOBuf *b = &m->base;
2770 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2772 /* Already have a readbuffer in progress */
2777 /* We have a write buffer or flushed PerlIOBuf read buffer */
2778 m->bbuf = b->buf; /* save it in case we need it again */
2779 b->buf = NULL; /* Clear to trigger below */
2783 PerlIOMmap_map(f); /* Try and map it */
2786 /* Map did not work - recover PerlIOBuf buffer if we have one */
2790 b->ptr = b->end = b->buf;
2793 return PerlIOBuf_get_base(f);
2797 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2799 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2800 PerlIOBuf *b = &m->base;
2801 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2803 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2806 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2811 /* Loose the unwritable mapped buffer */
2813 /* If flush took the "buffer" see if we have one from before */
2814 if (!b->buf && m->bbuf)
2818 PerlIOBuf_get_base(f);
2822 return PerlIOBuf_unread(f,vbuf,count);
2826 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2828 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2829 PerlIOBuf *b = &m->base;
2830 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2832 /* No, or wrong sort of, buffer */
2835 if (PerlIOMmap_unmap(f) != 0)
2838 /* If unmap took the "buffer" see if we have one from before */
2839 if (!b->buf && m->bbuf)
2843 PerlIOBuf_get_base(f);
2847 return PerlIOBuf_write(f,vbuf,count);
2851 PerlIOMmap_flush(PerlIO *f)
2853 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2854 PerlIOBuf *b = &m->base;
2855 IV code = PerlIOBuf_flush(f);
2856 /* Now we are "synced" at PerlIOBuf level */
2861 /* Unmap the buffer */
2862 if (PerlIOMmap_unmap(f) != 0)
2867 /* We seem to have a PerlIOBuf buffer which was not mapped
2868 * remember it in case we need one later
2877 PerlIOMmap_fill(PerlIO *f)
2879 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2880 IV code = PerlIO_flush(f);
2881 if (code == 0 && !b->buf)
2883 code = PerlIOMmap_map(f);
2885 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2887 code = PerlIOBuf_fill(f);
2893 PerlIOMmap_close(PerlIO *f)
2895 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2896 PerlIOBuf *b = &m->base;
2897 IV code = PerlIO_flush(f);
2902 b->ptr = b->end = b->buf;
2904 if (PerlIOBuf_close(f) != 0)
2910 PerlIO_funcs PerlIO_mmap = {
2930 PerlIOBase_clearerr,
2931 PerlIOBuf_setlinebuf,
2932 PerlIOMmap_get_base,
2936 PerlIOBuf_set_ptrcnt,
2939 #endif /* HAS_MMAP */
2946 atexit(&PerlIO_cleanup);
2955 PerlIO_stdstreams();
2959 #undef PerlIO_stdout
2964 PerlIO_stdstreams();
2968 #undef PerlIO_stderr
2973 PerlIO_stdstreams();
2977 /*--------------------------------------------------------------------------------------*/
2979 #undef PerlIO_getname
2981 PerlIO_getname(PerlIO *f, char *buf)
2984 Perl_croak(aTHX_ "Don't know how to get file name");
2989 /*--------------------------------------------------------------------------------------*/
2990 /* Functions which can be called on any kind of PerlIO implemented
2996 PerlIO_getc(PerlIO *f)
2999 SSize_t count = PerlIO_read(f,buf,1);
3002 return (unsigned char) buf[0];
3007 #undef PerlIO_ungetc
3009 PerlIO_ungetc(PerlIO *f, int ch)
3014 if (PerlIO_unread(f,&buf,1) == 1)
3022 PerlIO_putc(PerlIO *f, int ch)
3025 return PerlIO_write(f,&buf,1);
3030 PerlIO_puts(PerlIO *f, const char *s)
3032 STRLEN len = strlen(s);
3033 return PerlIO_write(f,s,len);
3036 #undef PerlIO_rewind
3038 PerlIO_rewind(PerlIO *f)
3040 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3044 #undef PerlIO_vprintf
3046 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3049 SV *sv = newSVpvn("",0);
3054 Perl_va_copy(ap, apc);
3055 sv_vcatpvf(sv, fmt, &apc);
3057 sv_vcatpvf(sv, fmt, &ap);
3060 return PerlIO_write(f,s,len);
3063 #undef PerlIO_printf
3065 PerlIO_printf(PerlIO *f,const char *fmt,...)
3070 result = PerlIO_vprintf(f,fmt,ap);
3075 #undef PerlIO_stdoutf
3077 PerlIO_stdoutf(const char *fmt,...)
3082 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3087 #undef PerlIO_tmpfile
3089 PerlIO_tmpfile(void)
3091 /* I have no idea how portable mkstemp() is ... */
3092 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3095 FILE *stdio = PerlSIO_tmpfile();
3098 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3104 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3105 int fd = mkstemp(SvPVX(sv));
3109 f = PerlIO_fdopen(fd,"w+");
3112 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3114 PerlLIO_unlink(SvPVX(sv));
3124 #endif /* USE_SFIO */
3125 #endif /* PERLIO_IS_STDIO */
3127 /*======================================================================================*/
3128 /* Now some functions in terms of above which may be needed even if
3129 we are not in true PerlIO mode
3133 #undef PerlIO_setpos
3135 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3137 return PerlIO_seek(f,*pos,0);
3140 #ifndef PERLIO_IS_STDIO
3141 #undef PerlIO_setpos
3143 PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
3145 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3146 return fsetpos64(f, pos);
3148 return fsetpos(f, pos);
3155 #undef PerlIO_getpos
3157 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3159 *pos = PerlIO_tell(f);
3160 return *pos == -1 ? -1 : 0;
3163 #ifndef PERLIO_IS_STDIO
3164 #undef PerlIO_getpos
3166 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
3168 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3169 return fgetpos64(f, pos);
3171 return fgetpos(f, pos);
3177 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3180 vprintf(char *pat, char *args)
3182 _doprnt(pat, args, stdout);
3183 return 0; /* wrong, but perl doesn't use the return value */
3187 vfprintf(FILE *fd, char *pat, char *args)
3189 _doprnt(pat, args, fd);
3190 return 0; /* wrong, but perl doesn't use the return value */
3195 #ifndef PerlIO_vsprintf
3197 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3199 int val = vsprintf(s, fmt, ap);
3202 if (strlen(s) >= (STRLEN)n)
3205 (void)PerlIO_puts(Perl_error_log,
3206 "panic: sprintf overflow - memory corrupted!\n");
3214 #ifndef PerlIO_sprintf
3216 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3221 result = PerlIO_vsprintf(s, n, fmt, ap);