3 * Copyright (c) 1996-2000, Nick Ing-Simmons
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
17 #define PERLIO_NOT_STDIO 0
18 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
19 /* #define PerlIO FILE */
22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
28 #define PERL_IN_PERLIO_C
31 #undef PerlMemShared_calloc
32 #define PerlMemShared_calloc(x,y) calloc(x,y)
33 #undef PerlMemShared_free
34 #define PerlMemShared_free(x) free(x)
39 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
41 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
45 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
51 perlsio_binmode(FILE *fp, int iotype, int mode)
53 /* This used to be contents of do_binmode in doio.c */
55 # if defined(atarist) || defined(__MINT__)
58 ((FILE*)fp)->_flag |= _IOBIN;
60 ((FILE*)fp)->_flag &= ~ _IOBIN;
65 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
66 # if defined(WIN32) && defined(__BORLANDC__)
67 /* The translation mode of the stream is maintained independent
68 * of the translation mode of the fd in the Borland RTL (heavy
69 * digging through their runtime sources reveal). User has to
70 * set the mode explicitly for the stream (though they don't
71 * document this anywhere). GSAR 97-5-24
77 fp->flags &= ~ _F_BIN;
85 # if defined(USEMYBINMODE)
86 if (my_binmode(fp, iotype, mode) != FALSE)
97 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
99 return perlsio_binmode(fp,iotype,mode);
105 #ifdef PERLIO_IS_STDIO
110 /* Does nothing (yet) except force this file to be included
111 in perl binary. That allows this file to force inclusion
112 of other functions that may be required by loadable
113 extensions e.g. for FileHandle::tmpfile
117 #undef PerlIO_tmpfile
124 #else /* PERLIO_IS_STDIO */
131 /* This section is just to make sure these functions
132 get pulled in from libsfio.a
135 #undef PerlIO_tmpfile
145 /* Force this file to be included in perl binary. Which allows
146 * this file to force inclusion of other functions that may be
147 * required by loadable extensions e.g. for FileHandle::tmpfile
151 * sfio does its own 'autoflush' on stdout in common cases.
152 * Flush results in a lot of lseek()s to regular files and
153 * lot of small writes to pipes.
155 sfset(sfstdout,SF_SHARE,0);
159 /*======================================================================================*/
160 /* Implement all the PerlIO interface ourselves.
165 /* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
170 #include <sys/mman.h>
175 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
178 PerlIO_debug(const char *fmt,...)
186 char *s = PerlEnv_getenv("PERLIO_DEBUG");
188 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
195 SV *sv = newSVpvn("",0);
198 s = CopFILE(PL_curcop);
201 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
202 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
205 PerlLIO_write(dbg,s,len);
211 /*--------------------------------------------------------------------------------------*/
213 /* Inner level routines */
215 /* Table of pointers to the PerlIO structs (malloc'ed) */
216 PerlIO *_perlio = NULL;
217 #define PERLIO_TABLE_SIZE 64
220 PerlIO_allocate(pTHX)
222 /* Find a free slot in the table, allocating new table as necessary */
229 last = (PerlIO **)(f);
230 for (i=1; i < PERLIO_TABLE_SIZE; i++)
238 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
248 PerlIO_cleantable(pTHX_ PerlIO **tablep)
250 PerlIO *table = *tablep;
254 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
255 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
263 PerlMemShared_free(table);
275 PerlIO_cleantable(aTHX_ &_perlio);
279 PerlIO_pop(PerlIO *f)
285 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
286 (*l->tab->Popped)(f);
288 PerlMemShared_free(l);
292 /*--------------------------------------------------------------------------------------*/
293 /* XS Interface for perl code */
299 char *s = GvNAME(gv);
300 STRLEN l = GvNAMELEN(gv);
301 PerlIO_debug("%.*s\n",(int) l,s);
305 XS(XS_perlio_unimport)
309 char *s = GvNAME(gv);
310 STRLEN l = GvNAMELEN(gv);
311 PerlIO_debug("%.*s\n",(int) l,s);
316 PerlIO_find_layer(const char *name, STRLEN len)
321 if ((SSize_t) len <= 0)
323 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
324 if (svp && (sv = *svp) && SvROK(sv))
331 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
335 IO *io = GvIOn((GV *)SvRV(sv));
336 PerlIO *ifp = IoIFP(io);
337 PerlIO *ofp = IoOFP(io);
338 AV *av = (AV *) mg->mg_obj;
339 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
345 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
349 IO *io = GvIOn((GV *)SvRV(sv));
350 PerlIO *ifp = IoIFP(io);
351 PerlIO *ofp = IoOFP(io);
352 AV *av = (AV *) mg->mg_obj;
353 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
359 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
361 Perl_warn(aTHX_ "clear %"SVf,sv);
366 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
368 Perl_warn(aTHX_ "free %"SVf,sv);
372 MGVTBL perlio_vtab = {
380 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
383 SV *sv = SvRV(ST(1));
388 sv_magic(sv, (SV *)av, '~', NULL, 0);
390 mg = mg_find(sv,'~');
391 mg->mg_virtual = &perlio_vtab;
393 Perl_warn(aTHX_ "attrib %"SVf,sv);
394 for (i=2; i < items; i++)
397 const char *name = SvPV(ST(i),len);
398 SV *layer = PerlIO_find_layer(name,len);
401 av_push(av,SvREFCNT_inc(layer));
414 PerlIO_define_layer(PerlIO_funcs *tab)
417 HV *stash = gv_stashpv("perlio::Layer", TRUE);
418 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
419 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
423 PerlIO_default_layer(I32 n)
428 PerlIO_funcs *tab = &PerlIO_stdio;
430 if (!PerlIO_layer_hv)
432 const char *s = PerlEnv_getenv("PERLIO");
433 newXS("perlio::import",XS_perlio_import,__FILE__);
434 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
436 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
438 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
439 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
440 PerlIO_define_layer(&PerlIO_unix);
441 PerlIO_define_layer(&PerlIO_perlio);
442 PerlIO_define_layer(&PerlIO_stdio);
443 PerlIO_define_layer(&PerlIO_crlf);
445 PerlIO_define_layer(&PerlIO_mmap);
447 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
452 while (*s && isSPACE((unsigned char)*s))
458 while (*e && !isSPACE((unsigned char)*e))
462 layer = PerlIO_find_layer(s,e-s);
465 PerlIO_debug("Pushing %.*s\n",(e-s),s);
466 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
469 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
475 len = av_len(PerlIO_layer_av);
478 if (O_BINARY != O_TEXT)
480 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
484 if (PerlIO_stdio.Set_ptrcnt)
486 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
490 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
493 len = av_len(PerlIO_layer_av);
497 svp = av_fetch(PerlIO_layer_av,n,0);
498 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
500 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
502 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
506 #define PerlIO_default_top() PerlIO_default_layer(-1)
507 #define PerlIO_default_btm() PerlIO_default_layer(0)
515 PerlIO_allocate(aTHX);
516 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
517 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
518 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
523 PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
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) != 0)
545 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
549 const char *s = names;
559 while (*e && *e != ':' && !isSPACE(*e))
563 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
565 /* Pop back to bottom layer */
569 while (PerlIONext(f))
575 else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
577 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
579 else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
581 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
585 SV *layer = PerlIO_find_layer(s,e-s);
588 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
591 PerlIO *new = PerlIO_push(f,tab,mode);
597 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
609 /*--------------------------------------------------------------------------------------*/
610 /* Given the abstraction above the public API functions */
613 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
615 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
616 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
617 if (!names || (O_TEXT != O_BINARY && (mode & O_BINARY)))
623 if (PerlIOBase(top)->tab == &PerlIO_crlf)
626 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
629 top = PerlIONext(top);
632 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
637 PerlIO__close(PerlIO *f)
639 return (*PerlIOBase(f)->tab->Close)(f);
642 #undef PerlIO_fdupopen
644 PerlIO_fdupopen(pTHX_ PerlIO *f)
647 int fd = PerlLIO_dup(PerlIO_fileno(f));
648 PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf));
651 Off_t posn = PerlIO_tell(f);
652 PerlIO_seek(new,posn,SEEK_SET);
659 PerlIO_close(PerlIO *f)
661 int code = (*PerlIOBase(f)->tab->Close)(f);
671 PerlIO_fileno(PerlIO *f)
673 return (*PerlIOBase(f)->tab->Fileno)(f);
680 PerlIO_fdopen(int fd, const char *mode)
682 PerlIO_funcs *tab = PerlIO_default_top();
685 return (*tab->Fdopen)(tab,fd,mode);
690 PerlIO_open(const char *path, const char *mode)
692 PerlIO_funcs *tab = PerlIO_default_top();
695 return (*tab->Open)(tab,path,mode);
700 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
705 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
707 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
713 return PerlIO_open(path,mode);
718 PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
720 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
725 PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
727 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
732 PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
734 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
739 PerlIO_seek(PerlIO *f, Off_t offset, int whence)
741 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
746 PerlIO_tell(PerlIO *f)
748 return (*PerlIOBase(f)->tab->Tell)(f);
753 PerlIO_flush(PerlIO *f)
757 return (*PerlIOBase(f)->tab->Flush)(f);
761 PerlIO **table = &_perlio;
766 table = (PerlIO **)(f++);
767 for (i=1; i < PERLIO_TABLE_SIZE; i++)
769 if (*f && PerlIO_flush(f) != 0)
780 PerlIO_fill(PerlIO *f)
782 return (*PerlIOBase(f)->tab->Fill)(f);
787 PerlIO_isutf8(PerlIO *f)
789 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
794 PerlIO_eof(PerlIO *f)
796 return (*PerlIOBase(f)->tab->Eof)(f);
801 PerlIO_error(PerlIO *f)
803 return (*PerlIOBase(f)->tab->Error)(f);
806 #undef PerlIO_clearerr
808 PerlIO_clearerr(PerlIO *f)
811 (*PerlIOBase(f)->tab->Clearerr)(f);
814 #undef PerlIO_setlinebuf
816 PerlIO_setlinebuf(PerlIO *f)
818 (*PerlIOBase(f)->tab->Setlinebuf)(f);
821 #undef PerlIO_has_base
823 PerlIO_has_base(PerlIO *f)
827 return (PerlIOBase(f)->tab->Get_base != NULL);
832 #undef PerlIO_fast_gets
834 PerlIO_fast_gets(PerlIO *f)
836 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
838 PerlIO_funcs *tab = PerlIOBase(f)->tab;
839 return (tab->Set_ptrcnt != NULL);
844 #undef PerlIO_has_cntptr
846 PerlIO_has_cntptr(PerlIO *f)
850 PerlIO_funcs *tab = PerlIOBase(f)->tab;
851 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
856 #undef PerlIO_canset_cnt
858 PerlIO_canset_cnt(PerlIO *f)
862 PerlIOl *l = PerlIOBase(f);
863 return (l->tab->Set_ptrcnt != NULL);
868 #undef PerlIO_get_base
870 PerlIO_get_base(PerlIO *f)
872 return (*PerlIOBase(f)->tab->Get_base)(f);
875 #undef PerlIO_get_bufsiz
877 PerlIO_get_bufsiz(PerlIO *f)
879 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
882 #undef PerlIO_get_ptr
884 PerlIO_get_ptr(PerlIO *f)
886 PerlIO_funcs *tab = PerlIOBase(f)->tab;
887 if (tab->Get_ptr == NULL)
889 return (*tab->Get_ptr)(f);
892 #undef PerlIO_get_cnt
894 PerlIO_get_cnt(PerlIO *f)
896 PerlIO_funcs *tab = PerlIOBase(f)->tab;
897 if (tab->Get_cnt == NULL)
899 return (*tab->Get_cnt)(f);
902 #undef PerlIO_set_cnt
904 PerlIO_set_cnt(PerlIO *f,int cnt)
906 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
909 #undef PerlIO_set_ptrcnt
911 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
913 PerlIO_funcs *tab = PerlIOBase(f)->tab;
914 if (tab->Set_ptrcnt == NULL)
917 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
919 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
922 /*--------------------------------------------------------------------------------------*/
923 /* "Methods" of the "base class" */
926 PerlIOBase_fileno(PerlIO *f)
928 return PerlIO_fileno(PerlIONext(f));
932 PerlIO_modestr(PerlIO *f,char *buf)
935 IV flags = PerlIOBase(f)->flags;
936 if (flags & PERLIO_F_APPEND)
939 if (flags & PERLIO_F_CANREAD)
944 else if (flags & PERLIO_F_CANREAD)
947 if (flags & PERLIO_F_CANWRITE)
950 else if (flags & PERLIO_F_CANWRITE)
953 if (flags & PERLIO_F_CANREAD)
958 #if O_TEXT != O_BINARY
959 if (!(flags & PERLIO_F_CRLF))
967 PerlIOBase_pushed(PerlIO *f, const char *mode)
969 PerlIOl *l = PerlIOBase(f);
970 const char *omode = mode;
972 PerlIO_funcs *tab = PerlIOBase(f)->tab;
973 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
974 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
975 if (tab->Set_ptrcnt != NULL)
976 l->flags |= PERLIO_F_FASTGETS;
982 l->flags |= PERLIO_F_CANREAD;
985 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
988 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
999 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
1002 l->flags &= ~PERLIO_F_CRLF;
1005 l->flags |= PERLIO_F_CRLF;
1017 l->flags |= l->next->flags &
1018 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1022 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1023 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1024 l->flags,PerlIO_modestr(f,temp));
1030 PerlIOBase_popped(PerlIO *f)
1035 extern PerlIO_funcs PerlIO_pending;
1038 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1041 Off_t old = PerlIO_tell(f);
1042 if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
1044 Off_t new = PerlIO_tell(f);
1052 PerlIO_push(f,&PerlIO_pending,"r");
1053 return PerlIOBuf_unread(f,vbuf,count);
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),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),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),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+"),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))),
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)
1788 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1789 b->posn = PerlIO_tell(PerlIONext(f));
1790 return PerlIOBase_pushed(f,mode);
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),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);
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);
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 *p = b->buf;
1861 PerlIO *n = PerlIONext(f);
1864 count = PerlIO_write(n,p,b->ptr - p);
1869 else if (count < 0 || PerlIO_error(n))
1871 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1876 b->posn += (p - b->buf);
1878 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1880 /* Note position change */
1881 b->posn += (b->ptr - b->buf);
1882 if (b->ptr < b->end)
1884 /* We did not consume all of it */
1885 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1887 b->posn = PerlIO_tell(PerlIONext(f));
1891 b->ptr = b->end = b->buf;
1892 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1893 /* FIXME: Is this right for read case ? */
1894 if (PerlIO_flush(PerlIONext(f)) != 0)
1900 PerlIOBuf_fill(PerlIO *f)
1902 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1903 PerlIO *n = PerlIONext(f);
1905 /* FIXME: doing the down-stream flush is a bad idea if it causes
1906 pre-read data in stdio buffer to be discarded
1907 but this is too simplistic - as it skips _our_ hosekeeping
1908 and breaks tell tests.
1909 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1913 if (PerlIO_flush(f) != 0)
1916 b->ptr = b->end = b->buf;
1917 if (PerlIO_fast_gets(n))
1919 /* Layer below is also buffered
1920 * We do _NOT_ want to call its ->Read() because that will loop
1921 * till it gets what we asked for which may hang on a pipe etc.
1922 * Instead take anything it has to hand, or ask it to fill _once_.
1924 avail = PerlIO_get_cnt(n);
1927 avail = PerlIO_fill(n);
1929 avail = PerlIO_get_cnt(n);
1932 if (!PerlIO_error(n) && PerlIO_eof(n))
1938 STDCHAR *ptr = PerlIO_get_ptr(n);
1939 SSize_t cnt = avail;
1940 if (avail > b->bufsiz)
1942 Copy(ptr,b->buf,avail,STDCHAR);
1943 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1948 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1953 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1955 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1958 b->end = b->buf+avail;
1959 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1964 PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
1966 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1967 STDCHAR *buf = (STDCHAR *) vbuf;
1972 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1976 SSize_t avail = PerlIO_get_cnt(f);
1977 SSize_t take = (count < avail) ? count : avail;
1980 STDCHAR *ptr = PerlIO_get_ptr(f);
1981 Copy(ptr,buf,take,STDCHAR);
1982 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1986 if (count > 0 && avail <= 0)
1988 if (PerlIO_fill(f) != 0)
1992 return (buf - (STDCHAR *) vbuf);
1998 PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2000 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2001 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2004 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2010 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2012 avail = (b->ptr - b->buf);
2017 b->end = b->buf + avail;
2019 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2020 b->posn -= b->bufsiz;
2022 if (avail > (SSize_t) count)
2030 Copy(buf,b->ptr,avail,STDCHAR);
2034 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2041 PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2043 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2044 const STDCHAR *buf = (const STDCHAR *) vbuf;
2048 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2052 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2053 if ((SSize_t) count < avail)
2055 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2056 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2076 Copy(buf,b->ptr,avail,STDCHAR);
2083 if (b->ptr >= (b->buf + b->bufsiz))
2086 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2092 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2095 if ((code = PerlIO_flush(f)) == 0)
2097 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2098 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2099 code = PerlIO_seek(PerlIONext(f),offset,whence);
2102 b->posn = PerlIO_tell(PerlIONext(f));
2109 PerlIOBuf_tell(PerlIO *f)
2111 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2112 Off_t posn = b->posn;
2114 posn += (b->ptr - b->buf);
2119 PerlIOBuf_close(PerlIO *f)
2122 IV code = PerlIOBase_close(f);
2123 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2124 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2126 PerlMemShared_free(b->buf);
2129 b->ptr = b->end = b->buf;
2130 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2135 PerlIOBuf_setlinebuf(PerlIO *f)
2139 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2144 PerlIOBuf_get_ptr(PerlIO *f)
2146 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2153 PerlIOBuf_get_cnt(PerlIO *f)
2155 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2158 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2159 return (b->end - b->ptr);
2164 PerlIOBuf_get_base(PerlIO *f)
2166 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2172 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
2175 b->buf = (STDCHAR *)&b->oneword;
2176 b->bufsiz = sizeof(b->oneword);
2185 PerlIOBuf_bufsiz(PerlIO *f)
2187 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2190 return (b->end - b->buf);
2194 PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2196 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2200 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2203 assert(PerlIO_get_cnt(f) == cnt);
2204 assert(b->ptr >= b->buf);
2206 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2209 PerlIO_funcs PerlIO_perlio = {
2229 PerlIOBase_clearerr,
2230 PerlIOBuf_setlinebuf,
2235 PerlIOBuf_set_ptrcnt,
2238 /*--------------------------------------------------------------------------------------*/
2239 /* Temp layer to hold unread chars when cannot do it any other way */
2242 PerlIOPending_fill(PerlIO *f)
2244 /* Should never happen */
2250 PerlIOPending_close(PerlIO *f)
2252 /* A tad tricky - flush pops us, then we close new top */
2254 return PerlIO_close(f);
2258 PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
2260 /* A tad tricky - flush pops us, then we seek new top */
2262 return PerlIO_seek(f,offset,whence);
2267 PerlIOPending_flush(PerlIO *f)
2269 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2270 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2273 PerlMemShared_free(b->buf);
2281 PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2289 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
2294 PerlIOPending_pushed(PerlIO *f,const char *mode)
2296 IV code = PerlIOBuf_pushed(f,mode);
2297 PerlIOl *l = PerlIOBase(f);
2298 /* Our PerlIO_fast_gets must match what we are pushed on,
2299 or sv_gets() etc. get muddled when it changes mid-string
2302 l->flags = (l->flags & ~PERLIO_F_FASTGETS) |
2303 (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
2308 PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
2310 SSize_t avail = PerlIO_get_cnt(f);
2315 got = PerlIOBuf_read(f,vbuf,avail);
2317 got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
2322 PerlIO_funcs PerlIO_pending = {
2330 PerlIOPending_pushed,
2337 PerlIOPending_close,
2338 PerlIOPending_flush,
2342 PerlIOBase_clearerr,
2343 PerlIOBuf_setlinebuf,
2348 PerlIOPending_set_ptrcnt,
2353 /*--------------------------------------------------------------------------------------*/
2354 /* crlf - translation
2355 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2356 to hand back a line at a time and keeping a record of which nl we "lied" about.
2357 On write translate "\n" to CR,LF
2362 PerlIOBuf base; /* PerlIOBuf stuff */
2363 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2367 PerlIOCrlf_pushed(PerlIO *f, const char *mode)
2370 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2371 code = PerlIOBuf_pushed(f,mode);
2373 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2374 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2375 PerlIOBase(f)->flags);
2382 PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2384 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2390 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2391 return PerlIOBuf_unread(f,vbuf,count);
2394 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2395 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2397 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2403 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2405 b->end = b->ptr = b->buf + b->bufsiz;
2406 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2407 b->posn -= b->bufsiz;
2409 while (count > 0 && b->ptr > b->buf)
2414 if (b->ptr - 2 >= b->buf)
2440 PerlIOCrlf_get_cnt(PerlIO *f)
2442 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2445 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2447 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2448 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2450 STDCHAR *nl = b->ptr;
2452 while (nl < b->end && *nl != 0xd)
2454 if (nl < b->end && *nl == 0xd)
2466 /* Not CR,LF but just CR */
2473 /* Blast - found CR as last char in buffer */
2476 /* They may not care, defer work as long as possible */
2477 return (nl - b->ptr);
2483 b->ptr++; /* say we have read it as far as flush() is concerned */
2484 b->buf++; /* Leave space an front of buffer */
2485 b->bufsiz--; /* Buffer is thus smaller */
2486 code = PerlIO_fill(f); /* Fetch some more */
2487 b->bufsiz++; /* Restore size for next time */
2488 b->buf--; /* Point at space */
2489 b->ptr = nl = b->buf; /* Which is what we hand off */
2490 b->posn--; /* Buffer starts here */
2491 *nl = 0xd; /* Fill in the CR */
2493 goto test; /* fill() call worked */
2494 /* CR at EOF - just fall through */
2499 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2505 PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2507 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2508 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2509 IV flags = PerlIOBase(f)->flags;
2519 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2526 /* Test code - delete when it works ... */
2533 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2541 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2542 ptr, chk, flags, c->nl, b->end, cnt);
2549 /* They have taken what we lied about */
2556 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2560 PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2562 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2563 return PerlIOBuf_write(f,vbuf,count);
2566 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2567 const STDCHAR *buf = (const STDCHAR *) vbuf;
2568 const STDCHAR *ebuf = buf+count;
2571 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2575 STDCHAR *eptr = b->buf+b->bufsiz;
2576 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2577 while (buf < ebuf && b->ptr < eptr)
2581 if ((b->ptr + 2) > eptr)
2583 /* Not room for both */
2589 *(b->ptr)++ = 0xd; /* CR */
2590 *(b->ptr)++ = 0xa; /* LF */
2592 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2611 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2613 return (buf - (STDCHAR *) vbuf);
2618 PerlIOCrlf_flush(PerlIO *f)
2620 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2626 return PerlIOBuf_flush(f);
2629 PerlIO_funcs PerlIO_crlf = {
2632 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2638 PerlIOBase_noop_ok, /* popped */
2639 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2640 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2641 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
2649 PerlIOBase_clearerr,
2650 PerlIOBuf_setlinebuf,
2655 PerlIOCrlf_set_ptrcnt,
2659 /*--------------------------------------------------------------------------------------*/
2660 /* mmap as "buffer" layer */
2664 PerlIOBuf base; /* PerlIOBuf stuff */
2665 Mmap_t mptr; /* Mapped address */
2666 Size_t len; /* mapped length */
2667 STDCHAR *bbuf; /* malloced buffer if map fails */
2670 static size_t page_size = 0;
2673 PerlIOMmap_map(PerlIO *f)
2676 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2677 PerlIOBuf *b = &m->base;
2678 IV flags = PerlIOBase(f)->flags;
2682 if (flags & PERLIO_F_CANREAD)
2684 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2685 int fd = PerlIO_fileno(f);
2687 code = fstat(fd,&st);
2688 if (code == 0 && S_ISREG(st.st_mode))
2690 SSize_t len = st.st_size - b->posn;
2695 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2697 SETERRNO(0,SS$_NORMAL);
2698 # ifdef _SC_PAGESIZE
2699 page_size = sysconf(_SC_PAGESIZE);
2701 page_size = sysconf(_SC_PAGE_SIZE);
2703 if ((long)page_size < 0) {
2708 (void)SvUPGRADE(error, SVt_PV);
2709 msg = SvPVx(error, n_a);
2710 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2713 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2717 # ifdef HAS_GETPAGESIZE
2718 page_size = getpagesize();
2720 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
2721 page_size = PAGESIZE; /* compiletime, bad */
2725 if ((IV)page_size <= 0)
2726 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2730 /* This is a hack - should never happen - open should have set it ! */
2731 b->posn = PerlIO_tell(PerlIONext(f));
2733 posn = (b->posn / page_size) * page_size;
2734 len = st.st_size - posn;
2735 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2736 if (m->mptr && m->mptr != (Mmap_t) -1)
2738 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2739 madvise(m->mptr, len, MADV_SEQUENTIAL);
2741 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2742 b->end = ((STDCHAR *)m->mptr) + len;
2743 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2754 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2756 b->ptr = b->end = b->ptr;
2765 PerlIOMmap_unmap(PerlIO *f)
2767 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2768 PerlIOBuf *b = &m->base;
2774 code = munmap(m->mptr, m->len);
2778 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2781 b->ptr = b->end = b->buf;
2782 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2788 PerlIOMmap_get_base(PerlIO *f)
2790 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2791 PerlIOBuf *b = &m->base;
2792 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2794 /* Already have a readbuffer in progress */
2799 /* We have a write buffer or flushed PerlIOBuf read buffer */
2800 m->bbuf = b->buf; /* save it in case we need it again */
2801 b->buf = NULL; /* Clear to trigger below */
2805 PerlIOMmap_map(f); /* Try and map it */
2808 /* Map did not work - recover PerlIOBuf buffer if we have one */
2812 b->ptr = b->end = b->buf;
2815 return PerlIOBuf_get_base(f);
2819 PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2821 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2822 PerlIOBuf *b = &m->base;
2823 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2825 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2828 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2833 /* Loose the unwritable mapped buffer */
2835 /* If flush took the "buffer" see if we have one from before */
2836 if (!b->buf && m->bbuf)
2840 PerlIOBuf_get_base(f);
2844 return PerlIOBuf_unread(f,vbuf,count);
2848 PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2850 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2851 PerlIOBuf *b = &m->base;
2852 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2854 /* No, or wrong sort of, buffer */
2857 if (PerlIOMmap_unmap(f) != 0)
2860 /* If unmap took the "buffer" see if we have one from before */
2861 if (!b->buf && m->bbuf)
2865 PerlIOBuf_get_base(f);
2869 return PerlIOBuf_write(f,vbuf,count);
2873 PerlIOMmap_flush(PerlIO *f)
2875 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2876 PerlIOBuf *b = &m->base;
2877 IV code = PerlIOBuf_flush(f);
2878 /* Now we are "synced" at PerlIOBuf level */
2883 /* Unmap the buffer */
2884 if (PerlIOMmap_unmap(f) != 0)
2889 /* We seem to have a PerlIOBuf buffer which was not mapped
2890 * remember it in case we need one later
2899 PerlIOMmap_fill(PerlIO *f)
2901 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2902 IV code = PerlIO_flush(f);
2903 if (code == 0 && !b->buf)
2905 code = PerlIOMmap_map(f);
2907 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2909 code = PerlIOBuf_fill(f);
2915 PerlIOMmap_close(PerlIO *f)
2917 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2918 PerlIOBuf *b = &m->base;
2919 IV code = PerlIO_flush(f);
2924 b->ptr = b->end = b->buf;
2926 if (PerlIOBuf_close(f) != 0)
2932 PerlIO_funcs PerlIO_mmap = {
2952 PerlIOBase_clearerr,
2953 PerlIOBuf_setlinebuf,
2954 PerlIOMmap_get_base,
2958 PerlIOBuf_set_ptrcnt,
2961 #endif /* HAS_MMAP */
2969 atexit(&PerlIO_cleanup);
2979 PerlIO_stdstreams();
2983 #undef PerlIO_stdout
2988 PerlIO_stdstreams();
2992 #undef PerlIO_stderr
2997 PerlIO_stdstreams();
3001 /*--------------------------------------------------------------------------------------*/
3003 #undef PerlIO_getname
3005 PerlIO_getname(PerlIO *f, char *buf)
3008 Perl_croak(aTHX_ "Don't know how to get file name");
3013 /*--------------------------------------------------------------------------------------*/
3014 /* Functions which can be called on any kind of PerlIO implemented
3020 PerlIO_getc(PerlIO *f)
3023 SSize_t count = PerlIO_read(f,buf,1);
3026 return (unsigned char) buf[0];
3031 #undef PerlIO_ungetc
3033 PerlIO_ungetc(PerlIO *f, int ch)
3038 if (PerlIO_unread(f,&buf,1) == 1)
3046 PerlIO_putc(PerlIO *f, int ch)
3049 return PerlIO_write(f,&buf,1);
3054 PerlIO_puts(PerlIO *f, const char *s)
3056 STRLEN len = strlen(s);
3057 return PerlIO_write(f,s,len);
3060 #undef PerlIO_rewind
3062 PerlIO_rewind(PerlIO *f)
3064 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3068 #undef PerlIO_vprintf
3070 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3073 SV *sv = newSVpvn("",0);
3078 Perl_va_copy(ap, apc);
3079 sv_vcatpvf(sv, fmt, &apc);
3081 sv_vcatpvf(sv, fmt, &ap);
3084 return PerlIO_write(f,s,len);
3087 #undef PerlIO_printf
3089 PerlIO_printf(PerlIO *f,const char *fmt,...)
3094 result = PerlIO_vprintf(f,fmt,ap);
3099 #undef PerlIO_stdoutf
3101 PerlIO_stdoutf(const char *fmt,...)
3106 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3111 #undef PerlIO_tmpfile
3113 PerlIO_tmpfile(void)
3115 /* I have no idea how portable mkstemp() is ... */
3116 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
3119 FILE *stdio = PerlSIO_tmpfile();
3122 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
3128 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3129 int fd = mkstemp(SvPVX(sv));
3133 f = PerlIO_fdopen(fd,"w+");
3136 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3138 PerlLIO_unlink(SvPVX(sv));
3148 #endif /* USE_SFIO */
3149 #endif /* PERLIO_IS_STDIO */
3151 /*======================================================================================*/
3152 /* Now some functions in terms of above which may be needed even if
3153 we are not in true PerlIO mode
3157 #undef PerlIO_setpos
3159 PerlIO_setpos(PerlIO *f, SV *pos)
3165 Off_t *posn = (Off_t *) SvPV(pos,len);
3166 if (f && len == sizeof(Off_t))
3167 return PerlIO_seek(f,*posn,SEEK_SET);
3173 #undef PerlIO_setpos
3175 PerlIO_setpos(PerlIO *f, SV *pos)
3181 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3182 if (f && len == sizeof(Fpos_t))
3184 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3185 return fsetpos64(f, fpos);
3187 return fsetpos(f, fpos);
3197 #undef PerlIO_getpos
3199 PerlIO_getpos(PerlIO *f, SV *pos)
3202 Off_t posn = PerlIO_tell(f);
3203 sv_setpvn(pos,(char *)&posn,sizeof(posn));
3204 return (posn == (Off_t)-1) ? -1 : 0;
3207 #undef PerlIO_getpos
3209 PerlIO_getpos(PerlIO *f, SV *pos)
3214 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
3215 code = fgetpos64(f, &fpos);
3217 code = fgetpos(f, &fpos);
3219 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3224 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3227 vprintf(char *pat, char *args)
3229 _doprnt(pat, args, stdout);
3230 return 0; /* wrong, but perl doesn't use the return value */
3234 vfprintf(FILE *fd, char *pat, char *args)
3236 _doprnt(pat, args, fd);
3237 return 0; /* wrong, but perl doesn't use the return value */
3242 #ifndef PerlIO_vsprintf
3244 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
3246 int val = vsprintf(s, fmt, ap);
3249 if (strlen(s) >= (STRLEN)n)
3252 (void)PerlIO_puts(Perl_error_log,
3253 "panic: sprintf overflow - memory corrupted!\n");
3261 #ifndef PerlIO_sprintf
3263 PerlIO_sprintf(char *s, int n, const char *fmt,...)
3268 result = PerlIO_vsprintf(s, n, fmt, ap);