2 * perlio.c Copyright (c) 1996-2005, Nick Ing-Simmons You may distribute
3 * under the terms of either the GNU General Public License or the
4 * Artistic License, as specified in the README file.
8 * Hour after hour for nearly three weary days he had jogged up and down,
9 * over passes, and through long dales, and across many streams.
12 /* This file contains the functions needed to implement PerlIO, which
13 * is Perl's private replacement for the C stdio library. This is used
14 * by default unless you compile with -Uuseperlio or run with
15 * PERLIO=:stdio (but don't do this unless you know what you're doing)
19 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
20 * at the dispatch tables, even when we do not need it for other reasons.
21 * Invent a dSYS macro to abstract this out
23 #ifdef PERL_IMPLICIT_SYS
36 #define PERLIO_NOT_STDIO 0
37 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
43 * This file provides those parts of PerlIO abstraction
44 * which are not #defined in perlio.h.
45 * Which these are depends on various Configure #ifdef's
49 #define PERL_IN_PERLIO_C
52 #ifdef PERL_IMPLICIT_CONTEXT
60 /* Missing proto on LynxOS */
64 /* Call the callback or PerlIOBase, and return failure. */
65 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
66 if (PerlIOValid(f)) { \
67 PerlIO_funcs *tab = PerlIOBase(f)->tab; \
68 if (tab && tab->callback) \
69 return (*tab->callback) args; \
71 return PerlIOBase_ ## base args; \
74 SETERRNO(EBADF, SS_IVCHAN); \
77 /* Call the callback or fail, and return failure. */
78 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
79 if (PerlIOValid(f)) { \
80 PerlIO_funcs *tab = PerlIOBase(f)->tab; \
81 if (tab && tab->callback) \
82 return (*tab->callback) args; \
83 SETERRNO(EINVAL, LIB_INVARG); \
86 SETERRNO(EBADF, SS_IVCHAN); \
89 /* Call the callback or PerlIOBase, and be void. */
90 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
91 if (PerlIOValid(f)) { \
92 PerlIO_funcs *tab = PerlIOBase(f)->tab; \
93 if (tab && tab->callback) \
94 (*tab->callback) args; \
96 PerlIOBase_ ## base args; \
99 SETERRNO(EBADF, SS_IVCHAN)
101 /* Call the callback or fail, and be void. */
102 #define Perl_PerlIO_or_fail_void(f, callback, args) \
103 if (PerlIOValid(f)) { \
104 PerlIO_funcs *tab = PerlIOBase(f)->tab; \
105 if (tab && tab->callback) \
106 (*tab->callback) args; \
108 SETERRNO(EINVAL, LIB_INVARG); \
111 SETERRNO(EBADF, SS_IVCHAN)
114 perlsio_binmode(FILE *fp, int iotype, int mode)
117 * This used to be contents of do_binmode in doio.c
120 # if defined(atarist) || defined(__MINT__)
123 ((FILE *) fp)->_flag |= _IOBIN;
125 ((FILE *) fp)->_flag &= ~_IOBIN;
132 if (PerlLIO_setmode(fp, mode) != -1) {
134 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
136 # if defined(WIN32) && defined(__BORLANDC__)
138 * The translation mode of the stream is maintained independent of
139 * the translation mode of the fd in the Borland RTL (heavy
140 * digging through their runtime sources reveal). User has to set
141 * the mode explicitly for the stream (though they don't document
142 * this anywhere). GSAR 97-5-24
148 fp->flags &= ~_F_BIN;
156 # if defined(USEMYBINMODE)
158 if (my_binmode(fp, iotype, mode) != FALSE)
169 #define O_ACCMODE 3 /* Assume traditional implementation */
173 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
175 int result = rawmode & O_ACCMODE;
180 ptype = IoTYPE_RDONLY;
183 ptype = IoTYPE_WRONLY;
191 *writing = (result != O_RDONLY);
193 if (result == O_RDONLY) {
197 else if (rawmode & O_APPEND) {
199 if (result != O_WRONLY)
204 if (result == O_WRONLY)
211 if (rawmode & O_BINARY)
217 #ifndef PERLIO_LAYERS
219 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
221 if (!names || !*names
222 || strEQ(names, ":crlf")
223 || strEQ(names, ":raw")
224 || strEQ(names, ":bytes")
228 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
236 PerlIO_destruct(pTHX)
241 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
246 return perlsio_binmode(fp, iotype, mode);
251 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
256 #ifdef PERL_IMPLICIT_SYS
257 return PerlSIO_fdupopen(f);
260 return win32_fdupopen(f);
263 int fd = PerlLIO_dup(PerlIO_fileno(f));
266 int omode = fcntl(fd, F_GETFL);
268 omode = djgpp_get_stream_mode(f);
270 PerlIO_intmode2str(omode,mode,NULL);
271 /* the r+ is a hack */
272 return PerlIO_fdopen(fd, mode);
277 SETERRNO(EBADF, SS_IVCHAN);
287 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
291 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
292 int imode, int perm, PerlIO *old, int narg, SV **args)
296 Perl_croak(aTHX_ "More than one argument to open");
298 if (*args == &PL_sv_undef)
299 return PerlIO_tmpfile();
301 char *name = SvPV_nolen(*args);
302 if (*mode == IoTYPE_NUMERIC) {
303 fd = PerlLIO_open3(name, imode, perm);
305 return PerlIO_fdopen(fd, (char *) mode + 1);
308 return PerlIO_reopen(name, mode, old);
311 return PerlIO_open(name, mode);
316 return PerlIO_fdopen(fd, (char *) mode);
321 XS(XS_PerlIO__Layer__find)
325 Perl_croak(aTHX_ "Usage class->find(name[,load])");
327 char *name = SvPV_nolen(ST(1));
328 ST(0) = (strEQ(name, "crlf")
329 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
336 Perl_boot_core_PerlIO(pTHX)
338 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
344 #ifdef PERLIO_IS_STDIO
350 * Does nothing (yet) except force this file to be included in perl
351 * binary. That allows this file to force inclusion of other functions
352 * that may be required by loadable extensions e.g. for
353 * FileHandle::tmpfile
357 #undef PerlIO_tmpfile
364 #else /* PERLIO_IS_STDIO */
372 * This section is just to make sure these functions get pulled in from
376 #undef PerlIO_tmpfile
387 * Force this file to be included in perl binary. Which allows this
388 * file to force inclusion of other functions that may be required by
389 * loadable extensions e.g. for FileHandle::tmpfile
393 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
394 * results in a lot of lseek()s to regular files and lot of small
397 sfset(sfstdout, SF_SHARE, 0);
400 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
402 PerlIO_importFILE(FILE *stdio, const char *mode)
404 int fd = fileno(stdio);
405 if (!mode || !*mode) {
408 return PerlIO_fdopen(fd, mode);
412 PerlIO_findFILE(PerlIO *pio)
414 int fd = PerlIO_fileno(pio);
415 FILE *f = fdopen(fd, "r+");
417 if (!f && errno == EINVAL)
419 if (!f && errno == EINVAL)
426 /*======================================================================================*/
428 * Implement all the PerlIO interface ourselves.
434 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
441 #include <sys/mman.h>
445 * Why is this here - not in perlio.h? RMB
447 void PerlIO_debug(const char *fmt, ...)
448 __attribute__format__(__printf__, 1, 2);
451 PerlIO_debug(const char *fmt, ...)
457 if (!dbg && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
458 char *s = PerlEnv_getenv("PERLIO_DEBUG");
460 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
468 /* Use fixed buffer as sv_catpvf etc. needs SVs */
471 s = CopFILE(PL_curcop);
474 sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
475 len = strlen(buffer);
476 vsprintf(buffer+len, fmt, ap);
477 PerlLIO_write(dbg, buffer, strlen(buffer));
479 SV *sv = newSVpvn("", 0);
481 s = CopFILE(PL_curcop);
484 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
485 (IV) CopLINE(PL_curcop));
486 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
489 PerlLIO_write(dbg, s, len);
496 /*--------------------------------------------------------------------------------------*/
499 * Inner level routines
503 * Table of pointers to the PerlIO structs (malloc'ed)
505 #define PERLIO_TABLE_SIZE 64
508 PerlIO_allocate(pTHX)
511 * Find a free slot in the table, allocating new table as necessary
516 while ((f = *last)) {
518 last = (PerlIO **) (f);
519 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
525 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
533 #undef PerlIO_fdupopen
535 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
537 if (PerlIOValid(f)) {
538 PerlIO_funcs *tab = PerlIOBase(f)->tab;
539 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
541 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
543 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
547 SETERRNO(EBADF, SS_IVCHAN);
553 PerlIO_cleantable(pTHX_ PerlIO **tablep)
555 PerlIO *table = *tablep;
558 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
559 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
560 PerlIO *f = table + i;
572 PerlIO_list_alloc(pTHX)
575 Newz('L', list, 1, PerlIO_list_t);
581 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
584 if (--list->refcnt == 0) {
587 for (i = 0; i < list->cur; i++) {
588 if (list->array[i].arg)
589 SvREFCNT_dec(list->array[i].arg);
591 Safefree(list->array);
599 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
602 if (list->cur >= list->len) {
605 Renew(list->array, list->len, PerlIO_pair_t);
607 New('l', list->array, list->len, PerlIO_pair_t);
609 p = &(list->array[list->cur++]);
611 if ((p->arg = arg)) {
612 (void)SvREFCNT_inc(arg);
617 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
619 PerlIO_list_t *list = (PerlIO_list_t *) NULL;
622 list = PerlIO_list_alloc(aTHX);
623 for (i=0; i < proto->cur; i++) {
625 if (proto->array[i].arg)
626 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
627 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
634 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
637 PerlIO **table = &proto->Iperlio;
640 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
641 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
642 PerlIO_allocate(aTHX); /* root slot is never used */
643 PerlIO_debug("Clone %p from %p\n",aTHX,proto);
644 while ((f = *table)) {
646 table = (PerlIO **) (f++);
647 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
649 (void) fp_dup(f, 0, param);
658 PerlIO_destruct(pTHX)
660 PerlIO **table = &PL_perlio;
663 PerlIO_debug("Destruct %p\n",aTHX);
665 while ((f = *table)) {
667 table = (PerlIO **) (f++);
668 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
672 if (l->tab->kind & PERLIO_K_DESTRUCT) {
673 PerlIO_debug("Destruct popping %s\n", l->tab->name);
687 PerlIO_pop(pTHX_ PerlIO *f)
691 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
692 if (l->tab->Popped) {
694 * If popped returns non-zero do not free its layer structure
695 * it has either done so itself, or it is shared and still in
698 if ((*l->tab->Popped) (aTHX_ f) != 0)
706 /* Return as an array the stack of layers on a filehandle. Note that
707 * the stack is returned top-first in the array, and there are three
708 * times as many array elements as there are layers in the stack: the
709 * first element of a layer triplet is the name, the second one is the
710 * arguments, and the third one is the flags. */
713 PerlIO_get_layers(pTHX_ PerlIO *f)
717 if (PerlIOValid(f)) {
718 PerlIOl *l = PerlIOBase(f);
721 SV *name = l->tab && l->tab->name ?
722 newSVpv(l->tab->name, 0) : &PL_sv_undef;
723 SV *arg = l->tab && l->tab->Getarg ?
724 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
727 av_push(av, newSViv((IV)l->flags));
735 /*--------------------------------------------------------------------------------------*/
737 * XS Interface for perl code
741 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
744 if ((SSize_t) len <= 0)
746 for (i = 0; i < PL_known_layers->cur; i++) {
747 PerlIO_funcs *f = PL_known_layers->array[i].funcs;
748 if (memEQ(f->name, name, len) && f->name[len] == 0) {
749 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
753 if (load && PL_subname && PL_def_layerlist
754 && PL_def_layerlist->cur >= 2) {
755 if (PL_in_load_module) {
756 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
759 SV *pkgsv = newSVpvn("PerlIO", 6);
760 SV *layer = newSVpvn(name, len);
761 CV *cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
763 SAVEINT(PL_in_load_module);
765 SAVESPTR(PL_warnhook);
766 PL_warnhook = (SV *) cv;
770 * The two SVs are magically freed by load_module
772 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
775 return PerlIO_find_layer(aTHX_ name, len, 0);
778 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
782 #ifdef USE_ATTRIBUTES_FOR_PERLIO
785 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
788 IO *io = GvIOn((GV *) SvRV(sv));
789 PerlIO *ifp = IoIFP(io);
790 PerlIO *ofp = IoOFP(io);
791 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
797 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
800 IO *io = GvIOn((GV *) SvRV(sv));
801 PerlIO *ifp = IoIFP(io);
802 PerlIO *ofp = IoOFP(io);
803 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
809 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
811 Perl_warn(aTHX_ "clear %" SVf, sv);
816 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
818 Perl_warn(aTHX_ "free %" SVf, sv);
822 MGVTBL perlio_vtab = {
830 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
833 SV *sv = SvRV(ST(1));
838 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
840 mg = mg_find(sv, PERL_MAGIC_ext);
841 mg->mg_virtual = &perlio_vtab;
843 Perl_warn(aTHX_ "attrib %" SVf, sv);
844 for (i = 2; i < items; i++) {
846 const char *name = SvPV(ST(i), len);
847 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
849 av_push(av, SvREFCNT_inc(layer));
860 #endif /* USE_ATTIBUTES_FOR_PERLIO */
863 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
865 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
866 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
870 XS(XS_PerlIO__Layer__NoWarnings)
872 /* This is used as a %SIG{__WARN__} handler to supress warnings
873 during loading of layers.
877 PerlIO_debug("warning:%s\n",SvPV_nolen(ST(0)));
881 XS(XS_PerlIO__Layer__find)
885 Perl_croak(aTHX_ "Usage class->find(name[,load])");
888 char *name = SvPV(ST(1), len);
889 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
890 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
892 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
899 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
901 if (!PL_known_layers)
902 PL_known_layers = PerlIO_list_alloc(aTHX);
903 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
904 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
908 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
911 const char *s = names;
913 while (isSPACE(*s) || *s == ':')
918 const char *as = Nullch;
920 if (!isIDFIRST(*s)) {
922 * Message is consistent with how attribute lists are
923 * passed. Even though this means "foo : : bar" is
924 * seen as an invalid separator character.
926 char q = ((*s == '\'') ? '"' : '\'');
927 if (ckWARN(WARN_LAYER))
928 Perl_warner(aTHX_ packWARN(WARN_LAYER),
929 "Invalid separator character %c%c%c in PerlIO layer specification %s",
931 SETERRNO(EINVAL, LIB_INVARG);
936 } while (isALNUM(*e));
952 * It's a nul terminated string, not allowed
953 * to \ the terminating null. Anything other
954 * character is passed over.
964 if (ckWARN(WARN_LAYER))
965 Perl_warner(aTHX_ packWARN(WARN_LAYER),
966 "Argument list not closed for PerlIO layer \"%.*s\"",
978 bool warn_layer = ckWARN(WARN_LAYER);
979 PerlIO_funcs *layer =
980 PerlIO_find_layer(aTHX_ s, llen, 1);
982 PerlIO_list_push(aTHX_ av, layer,
989 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1002 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1004 PerlIO_funcs *tab = &PerlIO_perlio;
1005 #ifdef PERLIO_USING_CRLF
1008 if (PerlIO_stdio.Set_ptrcnt)
1009 tab = &PerlIO_stdio;
1011 PerlIO_debug("Pushing %s\n", tab->name);
1012 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1017 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1019 return av->array[n].arg;
1023 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1025 if (n >= 0 && n < av->cur) {
1026 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1027 av->array[n].funcs->name);
1028 return av->array[n].funcs;
1031 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1036 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1038 if (PerlIOValid(f)) {
1040 PerlIO_pop(aTHX_ f);
1046 PerlIO_funcs PerlIO_remove = {
1047 sizeof(PerlIO_funcs),
1050 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1068 NULL, /* get_base */
1069 NULL, /* get_bufsiz */
1072 NULL, /* set_ptrcnt */
1076 PerlIO_default_layers(pTHX)
1078 if (!PL_def_layerlist) {
1079 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
1080 PerlIO_funcs *osLayer = &PerlIO_unix;
1081 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1082 PerlIO_define_layer(aTHX_ & PerlIO_unix);
1084 PerlIO_define_layer(aTHX_ & PerlIO_win32);
1086 osLayer = &PerlIO_win32;
1089 PerlIO_define_layer(aTHX_ & PerlIO_raw);
1090 PerlIO_define_layer(aTHX_ & PerlIO_perlio);
1091 PerlIO_define_layer(aTHX_ & PerlIO_stdio);
1092 PerlIO_define_layer(aTHX_ & PerlIO_crlf);
1094 PerlIO_define_layer(aTHX_ & PerlIO_mmap);
1096 PerlIO_define_layer(aTHX_ & PerlIO_utf8);
1097 PerlIO_define_layer(aTHX_ & PerlIO_remove);
1098 PerlIO_define_layer(aTHX_ & PerlIO_byte);
1099 PerlIO_list_push(aTHX_ PL_def_layerlist,
1100 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1103 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1106 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1109 if (PL_def_layerlist->cur < 2) {
1110 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1112 return PL_def_layerlist;
1116 Perl_boot_core_PerlIO(pTHX)
1118 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1119 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1122 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1123 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1127 PerlIO_default_layer(pTHX_ I32 n)
1129 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
1132 return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
1135 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1136 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1139 PerlIO_stdstreams(pTHX)
1142 PerlIO_allocate(aTHX);
1143 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1144 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1145 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1150 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
1152 if (tab->fsize != sizeof(PerlIO_funcs)) {
1154 Perl_croak(aTHX_ "Layer does not match this perl");
1158 if (tab->size < sizeof(PerlIOl)) {
1161 /* Real layer with a data area */
1162 Newc('L',l,tab->size,char,PerlIOl);
1164 Zero(l, tab->size, char);
1168 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1169 (mode) ? mode : "(Null)", (void*)arg);
1170 if (*l->tab->Pushed &&
1171 (*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
1172 PerlIO_pop(aTHX_ f);
1178 /* Pseudo-layer where push does its own stack adjust */
1179 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1180 (mode) ? mode : "(Null)", (void*)arg);
1182 (*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
1190 PerlIOBase_binmode(pTHX_ PerlIO *f)
1192 if (PerlIOValid(f)) {
1193 /* Is layer suitable for raw stream ? */
1194 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1195 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1196 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1199 /* Not suitable - pop it */
1200 PerlIO_pop(aTHX_ f);
1208 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1211 if (PerlIOValid(f)) {
1216 * Strip all layers that are not suitable for a raw stream
1219 while (t && (l = *t)) {
1220 if (l->tab->Binmode) {
1221 /* Has a handler - normal case */
1222 if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1224 /* Layer still there - move down a layer */
1233 /* No handler - pop it */
1234 PerlIO_pop(aTHX_ t);
1237 if (PerlIOValid(f)) {
1238 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1246 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1247 PerlIO_list_t *layers, IV n, IV max)
1251 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1253 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1264 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1268 PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1269 code = PerlIO_parse_layers(aTHX_ layers, names);
1271 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1273 PerlIO_list_free(aTHX_ layers);
1279 /*--------------------------------------------------------------------------------------*/
1281 * Given the abstraction above the public API functions
1285 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1287 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1288 (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1289 (names) ? names : "(Null)");
1291 /* Do not flush etc. if (e.g.) switching encodings.
1292 if a pushed layer knows it needs to flush lower layers
1293 (for example :unix which is never going to call them)
1294 it can do the flush when it is pushed.
1296 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1299 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1300 #ifdef PERLIO_USING_CRLF
1301 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1302 O_BINARY so we can look for it in mode.
1304 if (!(mode & O_BINARY)) {
1306 /* FIXME?: Looking down the layer stack seems wrong,
1307 but is a way of reaching past (say) an encoding layer
1308 to flip CRLF-ness of the layer(s) below
1311 /* Perhaps we should turn on bottom-most aware layer
1312 e.g. Ilya's idea that UNIX TTY could serve
1314 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1315 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1316 /* Not in text mode - flush any pending stuff and flip it */
1318 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1320 /* Only need to turn it on in one layer so we are done */
1325 /* Not finding a CRLF aware layer presumably means we are binary
1326 which is not what was requested - so we failed
1327 We _could_ push :crlf layer but so could caller
1332 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1333 So code that used to be here is now in PerlIORaw_pushed().
1335 return PerlIO_push(aTHX_ f, &PerlIO_raw, Nullch, Nullsv) ? TRUE : FALSE;
1340 PerlIO__close(pTHX_ PerlIO *f)
1342 if (PerlIOValid(f)) {
1343 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1344 if (tab && tab->Close)
1345 return (*tab->Close)(aTHX_ f);
1347 return PerlIOBase_close(aTHX_ f);
1350 SETERRNO(EBADF, SS_IVCHAN);
1356 Perl_PerlIO_close(pTHX_ PerlIO *f)
1358 int code = PerlIO__close(aTHX_ f);
1359 while (PerlIOValid(f)) {
1360 PerlIO_pop(aTHX_ f);
1366 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1368 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1372 PerlIO_context_layers(pTHX_ const char *mode)
1374 const char *type = NULL;
1376 * Need to supply default layer info from open.pm
1379 SV *layers = PL_curcop->cop_io;
1382 type = SvPV(layers, len);
1383 if (type && mode[0] != 'r') {
1385 * Skip to write part
1387 const char *s = strchr(type, 0);
1388 if (s && (STRLEN)(s - type) < len) {
1397 static PerlIO_funcs *
1398 PerlIO_layer_from_ref(pTHX_ SV *sv)
1401 * For any scalar type load the handler which is bundled with perl
1403 if (SvTYPE(sv) < SVt_PVAV)
1404 return PerlIO_find_layer(aTHX_ "scalar", 6, 1);
1407 * For other types allow if layer is known but don't try and load it
1409 switch (SvTYPE(sv)) {
1411 return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1413 return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1415 return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1417 return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1423 PerlIO_resolve_layers(pTHX_ const char *layers,
1424 const char *mode, int narg, SV **args)
1426 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1429 PerlIO_stdstreams(aTHX);
1433 * If it is a reference but not an object see if we have a handler
1436 if (SvROK(arg) && !sv_isobject(arg)) {
1437 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1439 def = PerlIO_list_alloc(aTHX);
1440 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1444 * Don't fail if handler cannot be found :via(...) etc. may do
1445 * something sensible else we will just stringfy and open
1451 layers = PerlIO_context_layers(aTHX_ mode);
1452 if (layers && *layers) {
1456 av = PerlIO_list_alloc(aTHX);
1457 for (i = 0; i < def->cur; i++) {
1458 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1465 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1469 PerlIO_list_free(aTHX_ av);
1470 return (PerlIO_list_t *) NULL;
1481 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1482 int imode, int perm, PerlIO *f, int narg, SV **args)
1484 if (!f && narg == 1 && *args == &PL_sv_undef) {
1485 if ((f = PerlIO_tmpfile())) {
1487 layers = PerlIO_context_layers(aTHX_ mode);
1488 if (layers && *layers)
1489 PerlIO_apply_layers(aTHX_ f, mode, layers);
1493 PerlIO_list_t *layera = NULL;
1495 PerlIO_funcs *tab = NULL;
1496 if (PerlIOValid(f)) {
1498 * This is "reopen" - it is not tested as perl does not use it
1502 layera = PerlIO_list_alloc(aTHX);
1504 SV *arg = (l->tab->Getarg)
1505 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1507 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1508 l = *PerlIONext(&l);
1512 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1518 * Start at "top" of layer stack
1520 n = layera->cur - 1;
1522 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1531 * Found that layer 'n' can do opens - call it
1533 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1534 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1536 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1537 tab->name, layers, mode, fd, imode, perm,
1538 (void*)f, narg, (void*)args);
1540 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1543 SETERRNO(EINVAL, LIB_INVARG);
1547 if (n + 1 < layera->cur) {
1549 * More layers above the one that we used to open -
1552 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1553 /* If pushing layers fails close the file */
1560 PerlIO_list_free(aTHX_ layera);
1567 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1569 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1573 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1575 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1579 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1581 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1585 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1587 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1591 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1593 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1597 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1601 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1603 if (tab && tab->Flush)
1604 return (*tab->Flush) (aTHX_ f);
1606 return 0; /* If no Flush defined, silently succeed. */
1609 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1610 SETERRNO(EBADF, SS_IVCHAN);
1616 * Is it good API design to do flush-all on NULL, a potentially
1617 * errorneous input? Maybe some magical value (PerlIO*
1618 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1619 * things on fflush(NULL), but should we be bound by their design
1622 PerlIO **table = &PL_perlio;
1624 while ((f = *table)) {
1626 table = (PerlIO **) (f++);
1627 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1628 if (*f && PerlIO_flush(f) != 0)
1638 PerlIOBase_flush_linebuf(pTHX)
1640 PerlIO **table = &PL_perlio;
1642 while ((f = *table)) {
1644 table = (PerlIO **) (f++);
1645 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1648 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1649 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1657 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1659 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1663 PerlIO_isutf8(PerlIO *f)
1666 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1668 SETERRNO(EBADF, SS_IVCHAN);
1674 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1676 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1680 Perl_PerlIO_error(pTHX_ PerlIO *f)
1682 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1686 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1688 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1692 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1694 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1698 PerlIO_has_base(PerlIO *f)
1700 if (PerlIOValid(f)) {
1701 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1704 return (tab->Get_base != NULL);
1705 SETERRNO(EINVAL, LIB_INVARG);
1708 SETERRNO(EBADF, SS_IVCHAN);
1714 PerlIO_fast_gets(PerlIO *f)
1716 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1717 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1720 return (tab->Set_ptrcnt != NULL);
1721 SETERRNO(EINVAL, LIB_INVARG);
1724 SETERRNO(EBADF, SS_IVCHAN);
1730 PerlIO_has_cntptr(PerlIO *f)
1732 if (PerlIOValid(f)) {
1733 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1736 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1737 SETERRNO(EINVAL, LIB_INVARG);
1740 SETERRNO(EBADF, SS_IVCHAN);
1746 PerlIO_canset_cnt(PerlIO *f)
1748 if (PerlIOValid(f)) {
1749 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1752 return (tab->Set_ptrcnt != NULL);
1753 SETERRNO(EINVAL, LIB_INVARG);
1756 SETERRNO(EBADF, SS_IVCHAN);
1762 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1764 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1768 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1770 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1774 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1776 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1780 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1782 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1786 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1788 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1792 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1794 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1798 /*--------------------------------------------------------------------------------------*/
1800 * utf8 and raw dummy layers
1804 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1806 if (PerlIOValid(f)) {
1807 if (tab->kind & PERLIO_K_UTF8)
1808 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1810 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1816 PerlIO_funcs PerlIO_utf8 = {
1817 sizeof(PerlIO_funcs),
1820 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1838 NULL, /* get_base */
1839 NULL, /* get_bufsiz */
1842 NULL, /* set_ptrcnt */
1845 PerlIO_funcs PerlIO_byte = {
1846 sizeof(PerlIO_funcs),
1867 NULL, /* get_base */
1868 NULL, /* get_bufsiz */
1871 NULL, /* set_ptrcnt */
1875 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1876 IV n, const char *mode, int fd, int imode, int perm,
1877 PerlIO *old, int narg, SV **args)
1879 PerlIO_funcs *tab = PerlIO_default_btm();
1880 if (tab && tab->Open)
1881 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1883 SETERRNO(EINVAL, LIB_INVARG);
1887 PerlIO_funcs PerlIO_raw = {
1888 sizeof(PerlIO_funcs),
1909 NULL, /* get_base */
1910 NULL, /* get_bufsiz */
1913 NULL, /* set_ptrcnt */
1915 /*--------------------------------------------------------------------------------------*/
1916 /*--------------------------------------------------------------------------------------*/
1918 * "Methods" of the "base class"
1922 PerlIOBase_fileno(pTHX_ PerlIO *f)
1924 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1928 PerlIO_modestr(PerlIO * f, char *buf)
1931 if (PerlIOValid(f)) {
1932 IV flags = PerlIOBase(f)->flags;
1933 if (flags & PERLIO_F_APPEND) {
1935 if (flags & PERLIO_F_CANREAD) {
1939 else if (flags & PERLIO_F_CANREAD) {
1941 if (flags & PERLIO_F_CANWRITE)
1944 else if (flags & PERLIO_F_CANWRITE) {
1946 if (flags & PERLIO_F_CANREAD) {
1950 #ifdef PERLIO_USING_CRLF
1951 if (!(flags & PERLIO_F_CRLF))
1961 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1963 PerlIOl *l = PerlIOBase(f);
1965 const char *omode = mode;
1968 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1969 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1970 if (tab->Set_ptrcnt != NULL)
1971 l->flags |= PERLIO_F_FASTGETS;
1973 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1977 l->flags |= PERLIO_F_CANREAD;
1980 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1983 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1986 SETERRNO(EINVAL, LIB_INVARG);
1992 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1995 l->flags &= ~PERLIO_F_CRLF;
1998 l->flags |= PERLIO_F_CRLF;
2001 SETERRNO(EINVAL, LIB_INVARG);
2008 l->flags |= l->next->flags &
2009 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2014 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2015 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2016 l->flags, PerlIO_modestr(f, temp));
2022 PerlIOBase_popped(pTHX_ PerlIO *f)
2028 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2031 * Save the position as current head considers it
2033 Off_t old = PerlIO_tell(f);
2035 PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
2036 PerlIOSelf(f, PerlIOBuf)->posn = old;
2037 done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
2042 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2044 STDCHAR *buf = (STDCHAR *) vbuf;
2046 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2047 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2048 SETERRNO(EBADF, SS_IVCHAN);
2052 SSize_t avail = PerlIO_get_cnt(f);
2055 take = ((SSize_t)count < avail) ? count : avail;
2057 STDCHAR *ptr = PerlIO_get_ptr(f);
2058 Copy(ptr, buf, take, STDCHAR);
2059 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2063 if (count > 0 && avail <= 0) {
2064 if (PerlIO_fill(f) != 0)
2068 return (buf - (STDCHAR *) vbuf);
2074 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2080 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2086 PerlIOBase_close(pTHX_ PerlIO *f)
2089 if (PerlIOValid(f)) {
2090 PerlIO *n = PerlIONext(f);
2091 code = PerlIO_flush(f);
2092 PerlIOBase(f)->flags &=
2093 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2094 while (PerlIOValid(n)) {
2095 PerlIO_funcs *tab = PerlIOBase(n)->tab;
2096 if (tab && tab->Close) {
2097 if ((*tab->Close)(aTHX_ n) != 0)
2102 PerlIOBase(n)->flags &=
2103 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2109 SETERRNO(EBADF, SS_IVCHAN);
2115 PerlIOBase_eof(pTHX_ PerlIO *f)
2117 if (PerlIOValid(f)) {
2118 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2124 PerlIOBase_error(pTHX_ PerlIO *f)
2126 if (PerlIOValid(f)) {
2127 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2133 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2135 if (PerlIOValid(f)) {
2136 PerlIO *n = PerlIONext(f);
2137 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2144 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2146 if (PerlIOValid(f)) {
2147 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2152 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2158 return sv_dup(arg, param);
2161 return newSVsv(arg);
2164 return newSVsv(arg);
2169 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2171 PerlIO *nexto = PerlIONext(o);
2172 if (PerlIOValid(nexto)) {
2173 PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
2174 if (tab && tab->Dup)
2175 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2177 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2180 PerlIO_funcs *self = PerlIOBase(o)->tab;
2183 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2184 self->name, (void*)f, (void*)o, (void*)param);
2186 arg = (*self->Getarg)(aTHX_ o, param, flags);
2190 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2198 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2200 perl_mutex PerlIO_mutex;
2202 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2207 /* Place holder for stdstreams call ??? */
2209 MUTEX_INIT(&PerlIO_mutex);
2214 PerlIOUnix_refcnt_inc(int fd)
2216 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2218 MUTEX_LOCK(&PerlIO_mutex);
2220 PerlIO_fd_refcnt[fd]++;
2221 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2223 MUTEX_UNLOCK(&PerlIO_mutex);
2229 PerlIOUnix_refcnt_dec(int fd)
2232 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2234 MUTEX_LOCK(&PerlIO_mutex);
2236 cnt = --PerlIO_fd_refcnt[fd];
2237 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2239 MUTEX_UNLOCK(&PerlIO_mutex);
2246 PerlIO_cleanup(pTHX)
2250 PerlIO_debug("Cleanup layers for %p\n",aTHX);
2252 PerlIO_debug("Cleanup layers\n");
2254 /* Raise STDIN..STDERR refcount so we don't close them */
2255 for (i=0; i < 3; i++)
2256 PerlIOUnix_refcnt_inc(i);
2257 PerlIO_cleantable(aTHX_ &PL_perlio);
2258 /* Restore STDIN..STDERR refcount */
2259 for (i=0; i < 3; i++)
2260 PerlIOUnix_refcnt_dec(i);
2262 if (PL_known_layers) {
2263 PerlIO_list_free(aTHX_ PL_known_layers);
2264 PL_known_layers = NULL;
2266 if(PL_def_layerlist) {
2267 PerlIO_list_free(aTHX_ PL_def_layerlist);
2268 PL_def_layerlist = NULL;
2274 /*--------------------------------------------------------------------------------------*/
2276 * Bottom-most level for UNIX-like case
2280 struct _PerlIO base; /* The generic part */
2281 int fd; /* UNIX like file descriptor */
2282 int oflags; /* open/fcntl flags */
2286 PerlIOUnix_oflags(const char *mode)
2289 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2294 if (*++mode == '+') {
2301 oflags = O_CREAT | O_TRUNC;
2302 if (*++mode == '+') {
2311 oflags = O_CREAT | O_APPEND;
2312 if (*++mode == '+') {
2325 else if (*mode == 't') {
2327 oflags &= ~O_BINARY;
2331 * Always open in binary mode
2334 if (*mode || oflags == -1) {
2335 SETERRNO(EINVAL, LIB_INVARG);
2342 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2344 return PerlIOSelf(f, PerlIOUnix)->fd;
2348 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2350 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2353 if (PerlLIO_fstat(fd, &st) == 0) {
2354 if (!S_ISREG(st.st_mode)) {
2355 PerlIO_debug("%d is not regular file\n",fd);
2356 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2359 PerlIO_debug("%d _is_ a regular file\n",fd);
2365 PerlIOUnix_refcnt_inc(fd);
2369 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2371 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2372 if (*PerlIONext(f)) {
2373 /* We never call down so do any pending stuff now */
2374 PerlIO_flush(PerlIONext(f));
2376 * XXX could (or should) we retrieve the oflags from the open file
2377 * handle rather than believing the "mode" we are passed in? XXX
2378 * Should the value on NULL mode be 0 or -1?
2380 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2381 mode ? PerlIOUnix_oflags(mode) : -1);
2383 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2389 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2391 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2393 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2395 SETERRNO(ESPIPE, LIB_INVARG);
2397 SETERRNO(EINVAL, LIB_INVARG);
2401 new = PerlLIO_lseek(fd, offset, whence);
2402 if (new == (Off_t) - 1)
2406 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2411 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2412 IV n, const char *mode, int fd, int imode,
2413 int perm, PerlIO *f, int narg, SV **args)
2415 if (PerlIOValid(f)) {
2416 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2417 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2420 char *path = SvPV_nolen(*args);
2421 if (*mode == IoTYPE_NUMERIC)
2424 imode = PerlIOUnix_oflags(mode);
2428 fd = PerlLIO_open3(path, imode, perm);
2432 if (*mode == IoTYPE_IMPLICIT)
2435 f = PerlIO_allocate(aTHX);
2437 if (!PerlIOValid(f)) {
2438 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2442 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2443 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2444 if (*mode == IoTYPE_APPEND)
2445 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2451 * FIXME: pop layers ???
2459 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2461 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2463 if (flags & PERLIO_DUP_FD) {
2464 fd = PerlLIO_dup(fd);
2466 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2467 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2469 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2470 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2479 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2481 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2482 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2483 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2487 SSize_t len = PerlLIO_read(fd, vbuf, count);
2488 if (len >= 0 || errno != EINTR) {
2490 if (errno != EAGAIN) {
2491 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2494 else if (len == 0 && count != 0) {
2495 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2505 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2507 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2509 SSize_t len = PerlLIO_write(fd, vbuf, count);
2510 if (len >= 0 || errno != EINTR) {
2512 if (errno != EAGAIN) {
2513 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2523 PerlIOUnix_tell(pTHX_ PerlIO *f)
2525 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2530 PerlIOUnix_close(pTHX_ PerlIO *f)
2532 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2534 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2535 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2536 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2541 SETERRNO(EBADF,SS_IVCHAN);
2544 while (PerlLIO_close(fd) != 0) {
2545 if (errno != EINTR) {
2552 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2557 PerlIO_funcs PerlIO_unix = {
2558 sizeof(PerlIO_funcs),
2565 PerlIOBase_binmode, /* binmode */
2575 PerlIOBase_noop_ok, /* flush */
2576 PerlIOBase_noop_fail, /* fill */
2579 PerlIOBase_clearerr,
2580 PerlIOBase_setlinebuf,
2581 NULL, /* get_base */
2582 NULL, /* get_bufsiz */
2585 NULL, /* set_ptrcnt */
2588 /*--------------------------------------------------------------------------------------*/
2593 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2594 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2595 broken by the last second glibc 2.3 fix
2597 #define STDIO_BUFFER_WRITABLE
2602 struct _PerlIO base;
2603 FILE *stdio; /* The stream */
2607 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2610 if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) {
2611 return PerlSIO_fileno(s);
2618 PerlIOStdio_mode(const char *mode, char *tmode)
2626 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2634 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2637 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2638 PerlIO_funcs *toptab = PerlIOBase(n)->tab;
2639 if (toptab == tab) {
2640 /* Top is already stdio - pop self (duplicate) and use original */
2641 PerlIO_pop(aTHX_ f);
2644 int fd = PerlIO_fileno(n);
2647 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2648 mode = PerlIOStdio_mode(mode, tmode)))) {
2649 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2650 /* We never call down so do any pending stuff now */
2651 PerlIO_flush(PerlIONext(f));
2658 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2663 PerlIO_importFILE(FILE *stdio, const char *mode)
2669 if (!mode || !*mode) {
2670 /* We need to probe to see how we can open the stream
2671 so start with read/write and then try write and read
2672 we dup() so that we can fclose without loosing the fd.
2674 Note that the errno value set by a failing fdopen
2675 varies between stdio implementations.
2677 int fd = PerlLIO_dup(fileno(stdio));
2678 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2680 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2683 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2686 /* Don't seem to be able to open */
2692 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio, mode, Nullsv))) {
2693 s = PerlIOSelf(f, PerlIOStdio);
2701 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2702 IV n, const char *mode, int fd, int imode,
2703 int perm, PerlIO *f, int narg, SV **args)
2706 if (PerlIOValid(f)) {
2707 char *path = SvPV_nolen(*args);
2708 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2710 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2711 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2716 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2721 char *path = SvPV_nolen(*args);
2722 if (*mode == IoTYPE_NUMERIC) {
2724 fd = PerlLIO_open3(path, imode, perm);
2728 bool appended = FALSE;
2730 /* Cygwin wants its 'b' early. */
2732 mode = PerlIOStdio_mode(mode, tmode);
2734 stdio = PerlSIO_fopen(path, mode);
2738 f = PerlIO_allocate(aTHX);
2741 mode = PerlIOStdio_mode(mode, tmode);
2742 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2744 s = PerlIOSelf(f, PerlIOStdio);
2746 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2758 if (*mode == IoTYPE_IMPLICIT) {
2765 stdio = PerlSIO_stdin;
2768 stdio = PerlSIO_stdout;
2771 stdio = PerlSIO_stderr;
2776 stdio = PerlSIO_fdopen(fd, mode =
2777 PerlIOStdio_mode(mode, tmode));
2782 f = PerlIO_allocate(aTHX);
2784 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2785 s = PerlIOSelf(f, PerlIOStdio);
2787 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2797 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2799 /* This assumes no layers underneath - which is what
2800 happens, but is not how I remember it. NI-S 2001/10/16
2802 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2803 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2804 int fd = fileno(stdio);
2806 if (flags & PERLIO_DUP_FD) {
2807 int dfd = PerlLIO_dup(fileno(stdio));
2809 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
2813 /* FIXME: To avoid messy error recovery if dup fails
2814 re-use the existing stdio as though flag was not set
2818 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
2820 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2821 PerlIOUnix_refcnt_inc(fileno(stdio));
2827 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
2829 /* XXX this could use PerlIO_canset_fileno() and
2830 * PerlIO_set_fileno() support from Configure
2832 # if defined(__UCLIBC__)
2833 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
2836 # elif defined(__GLIBC__)
2837 /* There may be a better way for GLIBC:
2838 - libio.h defines a flag to not close() on cleanup
2842 # elif defined(__sun__)
2844 /* On solaris, if _LP64 is defined, the FILE structure is this:
2850 * It turns out that the fd is stored in the top 32 bits of
2851 * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears
2852 * to contain a pointer or offset into another structure. All the
2853 * remaining fields are zero.
2855 * We set the top bits to -1 (0xFFFFFFFF).
2857 f->__pad[4] |= 0xffffffff00000000L;
2858 assert(fileno(f) == 0xffffffff);
2859 # else /* !defined(_LP64) */
2860 /* _file is just a unsigned char :-(
2861 Not clear why we dup() rather than using -1
2862 even if that would be treated as 0xFF - so will
2865 f->_file = PerlLIO_dup(fileno(f));
2866 # endif /* defined(_LP64) */
2868 # elif defined(__hpux)
2872 /* Next one ->_file seems to be a reasonable fallback, i.e. if
2873 your platform does not have special entry try this one.
2874 [For OSF only have confirmation for Tru64 (alpha)
2875 but assume other OSFs will be similar.]
2877 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
2880 # elif defined(__FreeBSD__)
2881 /* There may be a better way on FreeBSD:
2882 - we could insert a dummy func in the _close function entry
2883 f->_close = (int (*)(void *)) dummy_close;
2887 # elif defined(__OpenBSD__)
2888 /* There may be a better way on OpenBSD:
2889 - we could insert a dummy func in the _close function entry
2890 f->_close = (int (*)(void *)) dummy_close;
2894 # elif defined(__EMX__)
2895 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
2898 # elif defined(__CYGWIN__)
2899 /* There may be a better way on CYGWIN:
2900 - we could insert a dummy func in the _close function entry
2901 f->_close = (int (*)(void *)) dummy_close;
2905 # elif defined(WIN32)
2906 # if defined(__BORLANDC__)
2907 f->fd = PerlLIO_dup(fileno(f));
2908 # elif defined(UNDER_CE)
2909 /* WIN_CE does not have access to FILE internals, it hardly has FILE
2918 /* Sarathy's code did this - we fall back to a dup/dup2 hack
2919 (which isn't thread safe) instead
2921 # error "Don't know how to set FILE.fileno on your platform"
2928 PerlIOStdio_close(pTHX_ PerlIO *f)
2930 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2936 int fd = fileno(stdio);
2942 #ifdef SOCKS5_VERSION_NAME
2943 /* Socks lib overrides close() but stdio isn't linked to
2944 that library (though we are) - so we must call close()
2945 on sockets on stdio's behalf.
2948 Sock_size_t optlen = sizeof(int);
2949 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) {
2954 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2955 /* File descriptor still in use */
2960 /* For STD* handles don't close the stdio at all
2961 this is because we have shared the FILE * too
2963 if (stdio == stdin) {
2964 /* Some stdios are buggy fflush-ing inputs */
2967 else if (stdio == stdout || stdio == stderr) {
2968 return PerlIO_flush(f);
2970 /* Tricky - must fclose(stdio) to free memory but not close(fd)
2971 Use Sarathy's trick from maint-5.6 to invalidate the
2972 fileno slot of the FILE *
2974 result = PerlIO_flush(f);
2976 if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
2977 dupfd = PerlLIO_dup(fd);
2980 result = PerlSIO_fclose(stdio);
2981 /* We treat error from stdio as success if we invalidated
2982 errno may NOT be expected EBADF
2984 if (invalidate && result != 0) {
2989 /* in SOCKS case let close() determine return value */
2993 PerlLIO_dup2(dupfd,fd);
2994 PerlLIO_close(dupfd);
3001 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3003 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
3007 STDCHAR *buf = (STDCHAR *) vbuf;
3009 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3010 * stdio does not do that for fread()
3012 int ch = PerlSIO_fgetc(s);
3019 got = PerlSIO_fread(vbuf, 1, count, s);
3020 if (got == 0 && PerlSIO_ferror(s))
3022 if (got >= 0 || errno != EINTR)
3025 SETERRNO(0,0); /* just in case */
3031 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3034 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
3036 #ifdef STDIO_BUFFER_WRITABLE
3037 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3038 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3039 STDCHAR *base = PerlIO_get_base(f);
3040 SSize_t cnt = PerlIO_get_cnt(f);
3041 STDCHAR *ptr = PerlIO_get_ptr(f);
3042 SSize_t avail = ptr - base;
3044 if (avail > count) {
3048 Move(buf-avail,ptr,avail,STDCHAR);
3051 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3052 if (PerlSIO_feof(s) && unread >= 0)
3053 PerlSIO_clearerr(s);
3058 if (PerlIO_has_cntptr(f)) {
3059 /* We can get pointer to buffer but not its base
3060 Do ungetc() but check chars are ending up in the
3063 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3064 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3066 int ch = *--buf & 0xFF;
3067 if (ungetc(ch,s) != ch) {
3068 /* ungetc did not work */
3071 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3072 /* Did not change pointer as expected */
3073 fgetc(s); /* get char back again */
3083 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3089 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3093 got = PerlSIO_fwrite(vbuf, 1, count,
3094 PerlIOSelf(f, PerlIOStdio)->stdio);
3095 if (got >= 0 || errno != EINTR)
3098 SETERRNO(0,0); /* just in case */
3104 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3106 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3107 return PerlSIO_fseek(stdio, offset, whence);
3111 PerlIOStdio_tell(pTHX_ PerlIO *f)
3113 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3114 return PerlSIO_ftell(stdio);
3118 PerlIOStdio_flush(pTHX_ PerlIO *f)
3120 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3121 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3122 return PerlSIO_fflush(stdio);
3127 * FIXME: This discards ungetc() and pre-read stuff which is not
3128 * right if this is just a "sync" from a layer above Suspect right
3129 * design is to do _this_ but not have layer above flush this
3130 * layer read-to-read
3133 * Not writeable - sync by attempting a seek
3136 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3144 PerlIOStdio_eof(pTHX_ PerlIO *f)
3146 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3150 PerlIOStdio_error(pTHX_ PerlIO *f)
3152 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3156 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3158 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3162 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3164 #ifdef HAS_SETLINEBUF
3165 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3167 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
3173 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3175 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3176 return (STDCHAR*)PerlSIO_get_base(stdio);
3180 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3182 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3183 return PerlSIO_get_bufsiz(stdio);
3187 #ifdef USE_STDIO_PTR
3189 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3191 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3192 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3196 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3198 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3199 return PerlSIO_get_cnt(stdio);
3203 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3205 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3207 #ifdef STDIO_PTR_LVALUE
3208 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
3209 #ifdef STDIO_PTR_LVAL_SETS_CNT
3210 if (PerlSIO_get_cnt(stdio) != (cnt)) {
3211 assert(PerlSIO_get_cnt(stdio) == (cnt));
3214 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3216 * Setting ptr _does_ change cnt - we are done
3220 #else /* STDIO_PTR_LVALUE */
3222 #endif /* STDIO_PTR_LVALUE */
3225 * Now (or only) set cnt
3227 #ifdef STDIO_CNT_LVALUE
3228 PerlSIO_set_cnt(stdio, cnt);
3229 #else /* STDIO_CNT_LVALUE */
3230 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3231 PerlSIO_set_ptr(stdio,
3232 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3234 #else /* STDIO_PTR_LVAL_SETS_CNT */
3236 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3237 #endif /* STDIO_CNT_LVALUE */
3244 PerlIOStdio_fill(pTHX_ PerlIO *f)
3246 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3249 * fflush()ing read-only streams can cause trouble on some stdio-s
3251 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3252 if (PerlSIO_fflush(stdio) != 0)
3255 c = PerlSIO_fgetc(stdio);
3259 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3261 #ifdef STDIO_BUFFER_WRITABLE
3262 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3263 /* Fake ungetc() to the real buffer in case system's ungetc
3266 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3267 SSize_t cnt = PerlSIO_get_cnt(stdio);
3268 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3269 if (ptr == base+1) {
3270 *--ptr = (STDCHAR) c;
3271 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3272 if (PerlSIO_feof(stdio))
3273 PerlSIO_clearerr(stdio);
3279 if (PerlIO_has_cntptr(f)) {
3281 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3288 /* An ungetc()d char is handled separately from the regular
3289 * buffer, so we stuff it in the buffer ourselves.
3290 * Should never get called as should hit code above
3292 *(--((*stdio)->_ptr)) = (unsigned char) c;
3295 /* If buffer snoop scheme above fails fall back to
3298 if (PerlSIO_ungetc(c, stdio) != c)
3306 PerlIO_funcs PerlIO_stdio = {
3307 sizeof(PerlIO_funcs),
3309 sizeof(PerlIOStdio),
3310 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3314 PerlIOBase_binmode, /* binmode */
3328 PerlIOStdio_clearerr,
3329 PerlIOStdio_setlinebuf,
3331 PerlIOStdio_get_base,
3332 PerlIOStdio_get_bufsiz,
3337 #ifdef USE_STDIO_PTR
3338 PerlIOStdio_get_ptr,
3339 PerlIOStdio_get_cnt,
3340 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3341 PerlIOStdio_set_ptrcnt,
3344 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3349 #endif /* USE_STDIO_PTR */
3352 /* Note that calls to PerlIO_exportFILE() are reversed using
3353 * PerlIO_releaseFILE(), not importFILE. */
3355 PerlIO_exportFILE(PerlIO * f, const char *mode)
3359 if (PerlIOValid(f)) {
3362 if (!mode || !*mode) {
3363 mode = PerlIO_modestr(f, buf);
3365 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3369 /* De-link any lower layers so new :stdio sticks */
3371 if ((f2 = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) {
3372 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3374 /* Link previous lower layers under new one */
3378 /* restore layers list */
3388 PerlIO_findFILE(PerlIO *f)
3392 if (l->tab == &PerlIO_stdio) {
3393 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3396 l = *PerlIONext(&l);
3398 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3399 return PerlIO_exportFILE(f, Nullch);
3402 /* Use this to reverse PerlIO_exportFILE calls. */
3404 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3408 if (l->tab == &PerlIO_stdio) {
3409 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3410 if (s->stdio == f) {
3412 PerlIO_pop(aTHX_ p);
3421 /*--------------------------------------------------------------------------------------*/
3423 * perlio buffer layer
3427 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3429 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3430 int fd = PerlIO_fileno(f);
3431 if (fd >= 0 && PerlLIO_isatty(fd)) {
3432 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3434 if (*PerlIONext(f)) {
3435 Off_t posn = PerlIO_tell(PerlIONext(f));
3436 if (posn != (Off_t) - 1) {
3440 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3444 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3445 IV n, const char *mode, int fd, int imode, int perm,
3446 PerlIO *f, int narg, SV **args)
3448 if (PerlIOValid(f)) {
3449 PerlIO *next = PerlIONext(f);
3451 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3452 if (tab && tab->Open)
3454 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3456 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3461 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3463 if (*mode == IoTYPE_IMPLICIT) {
3469 if (tab && tab->Open)
3470 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3473 SETERRNO(EINVAL, LIB_INVARG);
3475 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3477 * if push fails during open, open fails. close will pop us.
3482 fd = PerlIO_fileno(f);
3483 if (init && fd == 2) {
3485 * Initial stderr is unbuffered
3487 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3489 #ifdef PERLIO_USING_CRLF
3490 # ifdef PERLIO_IS_BINMODE_FD
3491 if (PERLIO_IS_BINMODE_FD(fd))
3492 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch);
3496 * do something about failing setmode()? --jhi
3498 PerlLIO_setmode(fd, O_BINARY);
3507 * This "flush" is akin to sfio's sync in that it handles files in either
3508 * read or write state
3511 PerlIOBuf_flush(pTHX_ PerlIO *f)
3513 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3515 PerlIO *n = PerlIONext(f);
3516 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3518 * write() the buffer
3520 STDCHAR *buf = b->buf;
3522 while (p < b->ptr) {
3523 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3527 else if (count < 0 || PerlIO_error(n)) {
3528 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3533 b->posn += (p - buf);
3535 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3536 STDCHAR *buf = PerlIO_get_base(f);
3538 * Note position change
3540 b->posn += (b->ptr - buf);
3541 if (b->ptr < b->end) {
3542 /* We did not consume all of it - try and seek downstream to
3543 our logical position
3545 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3546 /* Reload n as some layers may pop themselves on seek */
3547 b->posn = PerlIO_tell(n = PerlIONext(f));
3550 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3551 data is lost for good - so return saying "ok" having undone
3554 b->posn -= (b->ptr - buf);
3559 b->ptr = b->end = b->buf;
3560 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3561 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3562 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3568 PerlIOBuf_fill(pTHX_ PerlIO *f)
3570 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3571 PerlIO *n = PerlIONext(f);
3574 * Down-stream flush is defined not to loose read data so is harmless.
3575 * we would not normally be fill'ing if there was data left in anycase.
3577 if (PerlIO_flush(f) != 0)
3579 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3580 PerlIOBase_flush_linebuf(aTHX);
3583 PerlIO_get_base(f); /* allocate via vtable */
3585 b->ptr = b->end = b->buf;
3587 if (!PerlIOValid(n)) {
3588 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3592 if (PerlIO_fast_gets(n)) {
3594 * Layer below is also buffered. We do _NOT_ want to call its
3595 * ->Read() because that will loop till it gets what we asked for
3596 * which may hang on a pipe etc. Instead take anything it has to
3597 * hand, or ask it to fill _once_.
3599 avail = PerlIO_get_cnt(n);
3601 avail = PerlIO_fill(n);
3603 avail = PerlIO_get_cnt(n);
3605 if (!PerlIO_error(n) && PerlIO_eof(n))
3610 STDCHAR *ptr = PerlIO_get_ptr(n);
3611 SSize_t cnt = avail;
3612 if (avail > (SSize_t)b->bufsiz)
3614 Copy(ptr, b->buf, avail, STDCHAR);
3615 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3619 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3623 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3625 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3628 b->end = b->buf + avail;
3629 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3634 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3636 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3637 if (PerlIOValid(f)) {
3640 return PerlIOBase_read(aTHX_ f, vbuf, count);
3646 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3648 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3649 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3652 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3657 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3659 * Buffer is already a read buffer, we can overwrite any chars
3660 * which have been read back to buffer start
3662 avail = (b->ptr - b->buf);
3666 * Buffer is idle, set it up so whole buffer is available for
3670 b->end = b->buf + avail;
3672 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3674 * Buffer extends _back_ from where we are now
3676 b->posn -= b->bufsiz;
3678 if (avail > (SSize_t) count) {
3680 * If we have space for more than count, just move count
3688 * In simple stdio-like ungetc() case chars will be already
3691 if (buf != b->ptr) {
3692 Copy(buf, b->ptr, avail, STDCHAR);
3696 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3700 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3706 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3708 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3709 const STDCHAR *buf = (const STDCHAR *) vbuf;
3710 const STDCHAR *flushptr = buf;
3714 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3716 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3717 if (PerlIO_flush(f) != 0) {
3721 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3722 flushptr = buf + count;
3723 while (flushptr > buf && *(flushptr - 1) != '\n')
3727 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3728 if ((SSize_t) count < avail)
3730 if (flushptr > buf && flushptr <= buf + avail)
3731 avail = flushptr - buf;
3732 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3734 Copy(buf, b->ptr, avail, STDCHAR);
3739 if (buf == flushptr)
3742 if (b->ptr >= (b->buf + b->bufsiz))
3745 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3751 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3754 if ((code = PerlIO_flush(f)) == 0) {
3755 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3756 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3757 code = PerlIO_seek(PerlIONext(f), offset, whence);
3759 b->posn = PerlIO_tell(PerlIONext(f));
3766 PerlIOBuf_tell(pTHX_ PerlIO *f)
3768 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3770 * b->posn is file position where b->buf was read, or will be written
3772 Off_t posn = b->posn;
3773 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
3774 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3776 /* As O_APPEND files are normally shared in some sense it is better
3781 /* when file is NOT shared then this is sufficient */
3782 PerlIO_seek(PerlIONext(f),0, SEEK_END);
3784 posn = b->posn = PerlIO_tell(PerlIONext(f));
3788 * If buffer is valid adjust position by amount in buffer
3790 posn += (b->ptr - b->buf);
3796 PerlIOBuf_popped(pTHX_ PerlIO *f)
3798 IV code = PerlIOBase_popped(aTHX_ f);
3799 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3800 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3804 b->ptr = b->end = b->buf;
3805 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3810 PerlIOBuf_close(pTHX_ PerlIO *f)
3812 IV code = PerlIOBase_close(aTHX_ f);
3813 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3814 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3818 b->ptr = b->end = b->buf;
3819 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3824 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3826 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3833 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3835 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3838 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3839 return (b->end - b->ptr);
3844 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3846 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3851 Newz('B',b->buf,b->bufsiz, STDCHAR);
3853 b->buf = (STDCHAR *) & b->oneword;
3854 b->bufsiz = sizeof(b->oneword);
3863 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3865 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3868 return (b->end - b->buf);
3872 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3874 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3878 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3879 assert(PerlIO_get_cnt(f) == cnt);
3880 assert(b->ptr >= b->buf);
3882 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3886 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3888 return PerlIOBase_dup(aTHX_ f, o, param, flags);
3893 PerlIO_funcs PerlIO_perlio = {
3894 sizeof(PerlIO_funcs),
3897 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3901 PerlIOBase_binmode, /* binmode */
3915 PerlIOBase_clearerr,
3916 PerlIOBase_setlinebuf,
3921 PerlIOBuf_set_ptrcnt,
3924 /*--------------------------------------------------------------------------------------*/
3926 * Temp layer to hold unread chars when cannot do it any other way
3930 PerlIOPending_fill(pTHX_ PerlIO *f)
3933 * Should never happen
3940 PerlIOPending_close(pTHX_ PerlIO *f)
3943 * A tad tricky - flush pops us, then we close new top
3946 return PerlIO_close(f);
3950 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3953 * A tad tricky - flush pops us, then we seek new top
3956 return PerlIO_seek(f, offset, whence);
3961 PerlIOPending_flush(pTHX_ PerlIO *f)
3963 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3964 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3968 PerlIO_pop(aTHX_ f);
3973 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3979 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3984 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3986 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3987 PerlIOl *l = PerlIOBase(f);
3989 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3990 * etc. get muddled when it changes mid-string when we auto-pop.
3992 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3993 (PerlIOBase(PerlIONext(f))->
3994 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3999 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4001 SSize_t avail = PerlIO_get_cnt(f);
4003 if ((SSize_t)count < avail)
4006 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4007 if (got >= 0 && got < (SSize_t)count) {
4009 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4010 if (more >= 0 || got == 0)
4016 PerlIO_funcs PerlIO_pending = {
4017 sizeof(PerlIO_funcs),
4020 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4021 PerlIOPending_pushed,
4024 PerlIOBase_binmode, /* binmode */
4033 PerlIOPending_close,
4034 PerlIOPending_flush,
4038 PerlIOBase_clearerr,
4039 PerlIOBase_setlinebuf,
4044 PerlIOPending_set_ptrcnt,
4049 /*--------------------------------------------------------------------------------------*/
4051 * crlf - translation On read translate CR,LF to "\n" we do this by
4052 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4053 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4057 PerlIOBuf base; /* PerlIOBuf stuff */
4058 STDCHAR *nl; /* Position of crlf we "lied" about in the
4063 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4066 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4067 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4069 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4070 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4071 PerlIOBase(f)->flags);
4074 /* Enable the first CRLF capable layer you can find, but if none
4075 * found, the one we just pushed is fine. This results in at
4076 * any given moment at most one CRLF-capable layer being enabled
4077 * in the whole layer stack. */
4078 PerlIO *g = PerlIONext(f);
4080 PerlIOl *b = PerlIOBase(g);
4081 if (b && b->tab == &PerlIO_crlf) {
4082 if (!(b->flags & PERLIO_F_CRLF))
4083 b->flags |= PERLIO_F_CRLF;
4084 PerlIO_pop(aTHX_ f);
4095 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4097 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4102 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4103 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4105 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4106 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4108 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4113 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4114 b->end = b->ptr = b->buf + b->bufsiz;
4115 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4116 b->posn -= b->bufsiz;
4118 while (count > 0 && b->ptr > b->buf) {
4121 if (b->ptr - 2 >= b->buf) {
4144 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4146 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4149 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4150 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4151 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4152 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4154 while (nl < b->end && *nl != 0xd)
4156 if (nl < b->end && *nl == 0xd) {
4158 if (nl + 1 < b->end) {
4165 * Not CR,LF but just CR
4173 * Blast - found CR as last char in buffer
4178 * They may not care, defer work as long as
4182 return (nl - b->ptr);
4186 b->ptr++; /* say we have read it as far as
4187 * flush() is concerned */
4188 b->buf++; /* Leave space in front of buffer */
4189 /* Note as we have moved buf up flush's
4191 will naturally make posn point at CR
4193 b->bufsiz--; /* Buffer is thus smaller */
4194 code = PerlIO_fill(f); /* Fetch some more */
4195 b->bufsiz++; /* Restore size for next time */
4196 b->buf--; /* Point at space */
4197 b->ptr = nl = b->buf; /* Which is what we hand
4199 *nl = 0xd; /* Fill in the CR */
4201 goto test; /* fill() call worked */
4203 * CR at EOF - just fall through
4205 /* Should we clear EOF though ??? */
4210 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4216 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4218 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4219 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4225 if (ptr == b->end && *c->nl == 0xd) {
4226 /* Defered CR at end of buffer case - we lied about count */
4238 * Test code - delete when it works ...
4240 IV flags = PerlIOBase(f)->flags;
4241 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4242 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4243 /* Defered CR at end of buffer case - we lied about count */
4249 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4250 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
4258 * They have taken what we lied about
4266 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4270 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4272 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4273 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4275 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4276 const STDCHAR *buf = (const STDCHAR *) vbuf;
4277 const STDCHAR *ebuf = buf + count;
4280 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4282 while (buf < ebuf) {
4283 STDCHAR *eptr = b->buf + b->bufsiz;
4284 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4285 while (buf < ebuf && b->ptr < eptr) {
4287 if ((b->ptr + 2) > eptr) {
4295 *(b->ptr)++ = 0xd; /* CR */
4296 *(b->ptr)++ = 0xa; /* LF */
4298 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4308 if (b->ptr >= eptr) {
4314 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4316 return (buf - (STDCHAR *) vbuf);
4321 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4323 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
4328 return PerlIOBuf_flush(aTHX_ f);
4332 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4334 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4335 /* In text mode - flush any pending stuff and flip it */
4336 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4337 #ifndef PERLIO_USING_CRLF
4338 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4339 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4340 PerlIO_pop(aTHX_ f);
4347 PerlIO_funcs PerlIO_crlf = {
4348 sizeof(PerlIO_funcs),
4351 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4353 PerlIOBuf_popped, /* popped */
4355 PerlIOCrlf_binmode, /* binmode */
4359 PerlIOBuf_read, /* generic read works with ptr/cnt lies
4361 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4362 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4370 PerlIOBase_clearerr,
4371 PerlIOBase_setlinebuf,
4376 PerlIOCrlf_set_ptrcnt,
4380 /*--------------------------------------------------------------------------------------*/
4382 * mmap as "buffer" layer
4386 PerlIOBuf base; /* PerlIOBuf stuff */
4387 Mmap_t mptr; /* Mapped address */
4388 Size_t len; /* mapped length */
4389 STDCHAR *bbuf; /* malloced buffer if map fails */
4392 static size_t page_size = 0;
4395 PerlIOMmap_map(pTHX_ PerlIO *f)
4397 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4398 IV flags = PerlIOBase(f)->flags;
4402 if (flags & PERLIO_F_CANREAD) {
4403 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4404 int fd = PerlIO_fileno(f);
4406 code = Fstat(fd, &st);
4407 if (code == 0 && S_ISREG(st.st_mode)) {
4408 SSize_t len = st.st_size - b->posn;
4412 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
4414 SETERRNO(0, SS_NORMAL);
4415 # ifdef _SC_PAGESIZE
4416 page_size = sysconf(_SC_PAGESIZE);
4418 page_size = sysconf(_SC_PAGE_SIZE);
4420 if ((long) page_size < 0) {
4425 (void) SvUPGRADE(error, SVt_PV);
4426 msg = SvPVx(error, n_a);
4427 Perl_croak(aTHX_ "panic: sysconf: %s",
4432 "panic: sysconf: pagesize unknown");
4436 # ifdef HAS_GETPAGESIZE
4437 page_size = getpagesize();
4439 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
4440 page_size = PAGESIZE; /* compiletime, bad */
4444 if ((IV) page_size <= 0)
4445 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4450 * This is a hack - should never happen - open should
4453 b->posn = PerlIO_tell(PerlIONext(f));
4455 posn = (b->posn / page_size) * page_size;
4456 len = st.st_size - posn;
4457 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4458 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4459 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4460 madvise(m->mptr, len, MADV_SEQUENTIAL);
4462 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4463 madvise(m->mptr, len, MADV_WILLNEED);
4465 PerlIOBase(f)->flags =
4466 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4467 b->end = ((STDCHAR *) m->mptr) + len;
4468 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4477 PerlIOBase(f)->flags =
4478 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4480 b->ptr = b->end = b->ptr;
4489 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4491 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4492 PerlIOBuf *b = &m->base;
4496 code = munmap(m->mptr, m->len);
4500 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4503 b->ptr = b->end = b->buf;
4504 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4510 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4512 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4513 PerlIOBuf *b = &m->base;
4514 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4516 * Already have a readbuffer in progress
4522 * We have a write buffer or flushed PerlIOBuf read buffer
4524 m->bbuf = b->buf; /* save it in case we need it again */
4525 b->buf = NULL; /* Clear to trigger below */
4528 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4531 * Map did not work - recover PerlIOBuf buffer if we have one
4536 b->ptr = b->end = b->buf;
4539 return PerlIOBuf_get_base(aTHX_ f);
4543 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4545 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4546 PerlIOBuf *b = &m->base;
4547 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4549 if (b->ptr && (b->ptr - count) >= b->buf
4550 && memEQ(b->ptr - count, vbuf, count)) {
4552 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4557 * Loose the unwritable mapped buffer
4561 * If flush took the "buffer" see if we have one from before
4563 if (!b->buf && m->bbuf)
4566 PerlIOBuf_get_base(aTHX_ f);
4570 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4574 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4576 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4577 PerlIOBuf *b = &m->base;
4578 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4580 * No, or wrong sort of, buffer
4583 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4587 * If unmap took the "buffer" see if we have one from before
4589 if (!b->buf && m->bbuf)
4592 PerlIOBuf_get_base(aTHX_ f);
4596 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4600 PerlIOMmap_flush(pTHX_ PerlIO *f)
4602 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4603 PerlIOBuf *b = &m->base;
4604 IV code = PerlIOBuf_flush(aTHX_ f);
4606 * Now we are "synced" at PerlIOBuf level
4613 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4618 * We seem to have a PerlIOBuf buffer which was not mapped
4619 * remember it in case we need one later
4628 PerlIOMmap_fill(pTHX_ PerlIO *f)
4630 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4631 IV code = PerlIO_flush(f);
4632 if (code == 0 && !b->buf) {
4633 code = PerlIOMmap_map(aTHX_ f);
4635 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4636 code = PerlIOBuf_fill(aTHX_ f);
4642 PerlIOMmap_close(pTHX_ PerlIO *f)
4644 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4645 PerlIOBuf *b = &m->base;
4646 IV code = PerlIO_flush(f);
4650 b->ptr = b->end = b->buf;
4652 if (PerlIOBuf_close(aTHX_ f) != 0)
4658 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4660 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4664 PerlIO_funcs PerlIO_mmap = {
4665 sizeof(PerlIO_funcs),
4668 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4672 PerlIOBase_binmode, /* binmode */
4686 PerlIOBase_clearerr,
4687 PerlIOBase_setlinebuf,
4688 PerlIOMmap_get_base,
4692 PerlIOBuf_set_ptrcnt,
4695 #endif /* HAS_MMAP */
4698 Perl_PerlIO_stdin(pTHX)
4701 PerlIO_stdstreams(aTHX);
4703 return &PL_perlio[1];
4707 Perl_PerlIO_stdout(pTHX)
4710 PerlIO_stdstreams(aTHX);
4712 return &PL_perlio[2];
4716 Perl_PerlIO_stderr(pTHX)
4719 PerlIO_stdstreams(aTHX);
4721 return &PL_perlio[3];
4724 /*--------------------------------------------------------------------------------------*/
4727 PerlIO_getname(PerlIO *f, char *buf)
4732 bool exported = FALSE;
4733 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4735 stdio = PerlIO_exportFILE(f,0);
4739 name = fgetname(stdio, buf);
4740 if (exported) PerlIO_releaseFILE(f,stdio);
4746 Perl_croak(aTHX_ "Don't know how to get file name");
4751 /*--------------------------------------------------------------------------------------*/
4753 * Functions which can be called on any kind of PerlIO implemented in
4757 #undef PerlIO_fdopen
4759 PerlIO_fdopen(int fd, const char *mode)
4762 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4767 PerlIO_open(const char *path, const char *mode)
4770 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4771 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4774 #undef Perlio_reopen
4776 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4779 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4780 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4785 PerlIO_getc(PerlIO *f)
4789 SSize_t count = PerlIO_read(f, buf, 1);
4791 return (unsigned char) buf[0];
4796 #undef PerlIO_ungetc
4798 PerlIO_ungetc(PerlIO *f, int ch)
4803 if (PerlIO_unread(f, &buf, 1) == 1)
4811 PerlIO_putc(PerlIO *f, int ch)
4815 return PerlIO_write(f, &buf, 1);
4820 PerlIO_puts(PerlIO *f, const char *s)
4823 STRLEN len = strlen(s);
4824 return PerlIO_write(f, s, len);
4827 #undef PerlIO_rewind
4829 PerlIO_rewind(PerlIO *f)
4832 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4836 #undef PerlIO_vprintf
4838 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4841 SV *sv = newSVpvn("", 0);
4847 Perl_va_copy(ap, apc);
4848 sv_vcatpvf(sv, fmt, &apc);
4850 sv_vcatpvf(sv, fmt, &ap);
4853 wrote = PerlIO_write(f, s, len);
4858 #undef PerlIO_printf
4860 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4865 result = PerlIO_vprintf(f, fmt, ap);
4870 #undef PerlIO_stdoutf
4872 PerlIO_stdoutf(const char *fmt, ...)
4878 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4883 #undef PerlIO_tmpfile
4885 PerlIO_tmpfile(void)
4893 f = PerlIO_fdopen(fd, "w+b");
4895 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4896 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4899 * I have no idea how portable mkstemp() is ... NI-S
4901 fd = mkstemp(SvPVX(sv));
4903 f = PerlIO_fdopen(fd, "w+");
4905 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4906 PerlLIO_unlink(SvPVX(sv));
4909 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
4910 FILE *stdio = PerlSIO_tmpfile();
4913 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)),
4914 &PerlIO_stdio, "w+", Nullsv))) {
4915 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
4921 # endif /* else HAS_MKSTEMP */
4922 #endif /* else WIN32 */
4929 #endif /* USE_SFIO */
4930 #endif /* PERLIO_IS_STDIO */
4932 /*======================================================================================*/
4934 * Now some functions in terms of above which may be needed even if we are
4935 * not in true PerlIO mode
4939 #undef PerlIO_setpos
4941 PerlIO_setpos(PerlIO *f, SV *pos)
4946 Off_t *posn = (Off_t *) SvPV(pos, len);
4947 if (f && len == sizeof(Off_t))
4948 return PerlIO_seek(f, *posn, SEEK_SET);
4950 SETERRNO(EINVAL, SS_IVCHAN);
4954 #undef PerlIO_setpos
4956 PerlIO_setpos(PerlIO *f, SV *pos)
4961 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4962 if (f && len == sizeof(Fpos_t)) {
4963 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4964 return fsetpos64(f, fpos);
4966 return fsetpos(f, fpos);
4970 SETERRNO(EINVAL, SS_IVCHAN);
4976 #undef PerlIO_getpos
4978 PerlIO_getpos(PerlIO *f, SV *pos)
4981 Off_t posn = PerlIO_tell(f);
4982 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4983 return (posn == (Off_t) - 1) ? -1 : 0;
4986 #undef PerlIO_getpos
4988 PerlIO_getpos(PerlIO *f, SV *pos)
4993 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4994 code = fgetpos64(f, &fpos);
4996 code = fgetpos(f, &fpos);
4998 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5003 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5006 vprintf(char *pat, char *args)
5008 _doprnt(pat, args, stdout);
5009 return 0; /* wrong, but perl doesn't use the return
5014 vfprintf(FILE *fd, char *pat, char *args)
5016 _doprnt(pat, args, fd);
5017 return 0; /* wrong, but perl doesn't use the return
5023 #ifndef PerlIO_vsprintf
5025 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5027 int val = vsprintf(s, fmt, ap);
5029 if (strlen(s) >= (STRLEN) n) {
5031 (void) PerlIO_puts(Perl_error_log,
5032 "panic: sprintf overflow - memory corrupted!\n");
5040 #ifndef PerlIO_sprintf
5042 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5047 result = PerlIO_vsprintf(s, n, fmt, ap);