3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
17 /* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
28 #ifdef PERL_IMPLICIT_SYS
38 # ifndef USE_CROSS_COMPILE
45 #define PERLIO_NOT_STDIO 0
46 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
52 * This file provides those parts of PerlIO abstraction
53 * which are not #defined in perlio.h.
54 * Which these are depends on various Configure #ifdef's
58 #define PERL_IN_PERLIO_C
61 #ifdef PERL_IMPLICIT_CONTEXT
69 /* Missing proto on LynxOS */
73 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
75 /* Call the callback or PerlIOBase, and return failure. */
76 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
77 if (PerlIOValid(f)) { \
78 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
79 if (tab && tab->callback) \
80 return (*tab->callback) args; \
82 return PerlIOBase_ ## base args; \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or fail, and return failure. */
89 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 return (*tab->callback) args; \
94 SETERRNO(EINVAL, LIB_INVARG); \
97 SETERRNO(EBADF, SS_IVCHAN); \
100 /* Call the callback or PerlIOBase, and be void. */
101 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 PerlIOBase_ ## base args; \
110 SETERRNO(EBADF, SS_IVCHAN)
112 /* Call the callback or fail, and be void. */
113 #define Perl_PerlIO_or_fail_void(f, callback, args) \
114 if (PerlIOValid(f)) { \
115 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
116 if (tab && tab->callback) \
117 (*tab->callback) args; \
119 SETERRNO(EINVAL, LIB_INVARG); \
122 SETERRNO(EBADF, SS_IVCHAN)
124 #if defined(__osf__) && _XOPEN_SOURCE < 500
125 extern int fseeko(FILE *, off_t, int);
126 extern off_t ftello(FILE *);
131 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
134 perlsio_binmode(FILE *fp, int iotype, int mode)
137 * This used to be contents of do_binmode in doio.c
140 # if defined(atarist)
141 PERL_UNUSED_ARG(iotype);
144 ((FILE *) fp)->_flag |= _IOBIN;
146 ((FILE *) fp)->_flag &= ~_IOBIN;
152 PERL_UNUSED_ARG(iotype);
154 if (PerlLIO_setmode(fp, mode) != -1) {
156 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
158 # if defined(WIN32) && defined(__BORLANDC__)
160 * The translation mode of the stream is maintained independent
162 * the translation mode of the fd in the Borland RTL (heavy
163 * digging through their runtime sources reveal). User has to
165 * the mode explicitly for the stream (though they don't
167 * this anywhere). GSAR 97-5-24
173 fp->flags &= ~_F_BIN;
181 # if defined(USEMYBINMODE)
183 # if defined(__CYGWIN__)
184 PERL_UNUSED_ARG(iotype);
186 if (my_binmode(fp, iotype, mode) != FALSE)
192 PERL_UNUSED_ARG(iotype);
193 PERL_UNUSED_ARG(mode);
201 #define O_ACCMODE 3 /* Assume traditional implementation */
205 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
207 const int result = rawmode & O_ACCMODE;
212 ptype = IoTYPE_RDONLY;
215 ptype = IoTYPE_WRONLY;
223 *writing = (result != O_RDONLY);
225 if (result == O_RDONLY) {
229 else if (rawmode & O_APPEND) {
231 if (result != O_WRONLY)
236 if (result == O_WRONLY)
243 if (rawmode & O_BINARY)
249 #ifndef PERLIO_LAYERS
251 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
253 if (!names || !*names
254 || strEQ(names, ":crlf")
255 || strEQ(names, ":raw")
256 || strEQ(names, ":bytes")
260 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
268 PerlIO_destruct(pTHX)
273 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
276 PERL_UNUSED_ARG(iotype);
277 PERL_UNUSED_ARG(mode);
278 PERL_UNUSED_ARG(names);
281 return perlsio_binmode(fp, iotype, mode);
286 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
288 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
291 #ifdef PERL_IMPLICIT_SYS
292 return PerlSIO_fdupopen(f);
295 return win32_fdupopen(f);
298 const int fd = PerlLIO_dup(PerlIO_fileno(f));
302 const int omode = djgpp_get_stream_mode(f);
304 const int omode = fcntl(fd, F_GETFL);
306 PerlIO_intmode2str(omode,mode,NULL);
307 /* the r+ is a hack */
308 return PerlIO_fdopen(fd, mode);
313 SETERRNO(EBADF, SS_IVCHAN);
323 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
327 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
328 int imode, int perm, PerlIO *old, int narg, SV **args)
332 Perl_croak(aTHX_ "More than one argument to open");
334 if (*args == &PL_sv_undef)
335 return PerlIO_tmpfile();
337 const char *name = SvPV_nolen_const(*args);
338 if (*mode == IoTYPE_NUMERIC) {
339 fd = PerlLIO_open3(name, imode, perm);
341 return PerlIO_fdopen(fd, mode + 1);
344 return PerlIO_reopen(name, mode, old);
347 return PerlIO_open(name, mode);
352 return PerlIO_fdopen(fd, (char *) mode);
357 XS(XS_PerlIO__Layer__find)
361 Perl_croak(aTHX_ "Usage class->find(name[,load])");
363 const char * const name = SvPV_nolen_const(ST(1));
364 ST(0) = (strEQ(name, "crlf")
365 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
372 Perl_boot_core_PerlIO(pTHX)
374 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
380 #ifdef PERLIO_IS_STDIO
387 * Does nothing (yet) except force this file to be included in perl
388 * binary. That allows this file to force inclusion of other functions
389 * that may be required by loadable extensions e.g. for
390 * FileHandle::tmpfile
394 #undef PerlIO_tmpfile
401 #else /* PERLIO_IS_STDIO */
409 * This section is just to make sure these functions get pulled in from
413 #undef PerlIO_tmpfile
425 * Force this file to be included in perl binary. Which allows this
426 * file to force inclusion of other functions that may be required by
427 * loadable extensions e.g. for FileHandle::tmpfile
431 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
432 * results in a lot of lseek()s to regular files and lot of small
435 sfset(sfstdout, SF_SHARE, 0);
438 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
440 PerlIO_importFILE(FILE *stdio, const char *mode)
442 const int fd = fileno(stdio);
443 if (!mode || !*mode) {
446 return PerlIO_fdopen(fd, mode);
450 PerlIO_findFILE(PerlIO *pio)
452 const int fd = PerlIO_fileno(pio);
453 FILE * const f = fdopen(fd, "r+");
455 if (!f && errno == EINVAL)
457 if (!f && errno == EINVAL)
464 /*======================================================================================*/
466 * Implement all the PerlIO interface ourselves.
472 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
479 #include <sys/mman.h>
483 PerlIO_debug(const char *fmt, ...)
488 if (!PL_perlio_debug_fd) {
489 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
490 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
493 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
495 PL_perlio_debug_fd = -1;
497 /* tainting or set*id, so ignore the environment, and ensure we
498 skip these tests next time through. */
499 PL_perlio_debug_fd = -1;
502 if (PL_perlio_debug_fd > 0) {
505 const char * const s = CopFILE(PL_curcop);
506 /* Use fixed buffer as sv_catpvf etc. needs SVs */
508 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
509 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
510 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
512 const char *s = CopFILE(PL_curcop);
514 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
515 (IV) CopLINE(PL_curcop));
516 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
518 s = SvPV_const(sv, len);
519 PerlLIO_write(PL_perlio_debug_fd, s, len);
526 /*--------------------------------------------------------------------------------------*/
529 * Inner level routines
532 /* check that the head field of each layer points back to the head */
535 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
537 PerlIO_verify_head(pTHX_ PerlIO *f)
543 p = head = PerlIOBase(f)->head;
546 assert(p->head == head);
547 if (p == (PerlIOl*)f)
554 # define VERIFY_HEAD(f)
559 * Table of pointers to the PerlIO structs (malloc'ed)
561 #define PERLIO_TABLE_SIZE 64
564 PerlIO_init_table(pTHX)
568 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
574 PerlIO_allocate(pTHX)
578 * Find a free slot in the table, allocating new table as necessary
583 while ((f = *last)) {
585 last = (PerlIOl **) (f);
586 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
587 if (!((++f)->next)) {
588 f->flags = 0; /* lockcnt */
595 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
599 *last = (PerlIOl*) f++;
600 f->flags = 0; /* lockcnt */
606 #undef PerlIO_fdupopen
608 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
610 if (PerlIOValid(f)) {
611 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
612 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
614 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
616 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
620 SETERRNO(EBADF, SS_IVCHAN);
626 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
628 PerlIOl * const table = *tablep;
631 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
632 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
633 PerlIOl * const f = table + i;
635 PerlIO_close(&(f->next));
645 PerlIO_list_alloc(pTHX)
649 Newxz(list, 1, PerlIO_list_t);
655 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
658 if (--list->refcnt == 0) {
661 for (i = 0; i < list->cur; i++)
662 SvREFCNT_dec(list->array[i].arg);
663 Safefree(list->array);
671 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
677 if (list->cur >= list->len) {
680 Renew(list->array, list->len, PerlIO_pair_t);
682 Newx(list->array, list->len, PerlIO_pair_t);
684 p = &(list->array[list->cur++]);
686 if ((p->arg = arg)) {
687 SvREFCNT_inc_simple_void_NN(arg);
692 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
694 PerlIO_list_t *list = NULL;
697 list = PerlIO_list_alloc(aTHX);
698 for (i=0; i < proto->cur; i++) {
699 SV *arg = proto->array[i].arg;
702 arg = sv_dup(arg, param);
704 PERL_UNUSED_ARG(param);
706 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
713 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
716 PerlIOl **table = &proto->Iperlio;
719 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
720 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
721 PerlIO_init_table(aTHX);
722 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
723 while ((f = *table)) {
725 table = (PerlIOl **) (f++);
726 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
728 (void) fp_dup(&(f->next), 0, param);
735 PERL_UNUSED_ARG(proto);
736 PERL_UNUSED_ARG(param);
741 PerlIO_destruct(pTHX)
744 PerlIOl **table = &PL_perlio;
747 PerlIO_debug("Destruct %p\n",(void*)aTHX);
749 while ((f = *table)) {
751 table = (PerlIOl **) (f++);
752 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
753 PerlIO *x = &(f->next);
756 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
757 PerlIO_debug("Destruct popping %s\n", l->tab->name);
771 PerlIO_pop(pTHX_ PerlIO *f)
773 const PerlIOl *l = *f;
776 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
777 l->tab ? l->tab->name : "(Null)");
778 if (l->tab && l->tab->Popped) {
780 * If popped returns non-zero do not free its layer structure
781 * it has either done so itself, or it is shared and still in
784 if ((*l->tab->Popped) (aTHX_ f) != 0)
787 if (PerlIO_lockcnt(f)) {
788 /* we're in use; defer freeing the structure */
789 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
790 PerlIOBase(f)->tab = NULL;
800 /* Return as an array the stack of layers on a filehandle. Note that
801 * the stack is returned top-first in the array, and there are three
802 * times as many array elements as there are layers in the stack: the
803 * first element of a layer triplet is the name, the second one is the
804 * arguments, and the third one is the flags. */
807 PerlIO_get_layers(pTHX_ PerlIO *f)
810 AV * const av = newAV();
812 if (PerlIOValid(f)) {
813 PerlIOl *l = PerlIOBase(f);
816 /* There is some collusion in the implementation of
817 XS_PerlIO_get_layers - it knows that name and flags are
818 generated as fresh SVs here, and takes advantage of that to
819 "copy" them by taking a reference. If it changes here, it needs
820 to change there too. */
821 SV * const name = l->tab && l->tab->name ?
822 newSVpv(l->tab->name, 0) : &PL_sv_undef;
823 SV * const arg = l->tab && l->tab->Getarg ?
824 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
827 av_push(av, newSViv((IV)l->flags));
835 /*--------------------------------------------------------------------------------------*/
837 * XS Interface for perl code
841 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
845 if ((SSize_t) len <= 0)
847 for (i = 0; i < PL_known_layers->cur; i++) {
848 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
849 if (memEQ(f->name, name, len) && f->name[len] == 0) {
850 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
854 if (load && PL_subname && PL_def_layerlist
855 && PL_def_layerlist->cur >= 2) {
856 if (PL_in_load_module) {
857 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
860 SV * const pkgsv = newSVpvs("PerlIO");
861 SV * const layer = newSVpvn(name, len);
862 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
864 SAVEBOOL(PL_in_load_module);
866 SAVEGENERICSV(PL_warnhook);
867 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
869 PL_in_load_module = TRUE;
871 * The two SVs are magically freed by load_module
873 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
875 return PerlIO_find_layer(aTHX_ name, len, 0);
878 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
882 #ifdef USE_ATTRIBUTES_FOR_PERLIO
885 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
888 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
889 PerlIO * const ifp = IoIFP(io);
890 PerlIO * const ofp = IoOFP(io);
891 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
892 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
898 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
901 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
902 PerlIO * const ifp = IoIFP(io);
903 PerlIO * const ofp = IoOFP(io);
904 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
905 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
911 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
913 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
918 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
920 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
924 MGVTBL perlio_vtab = {
932 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
935 SV * const sv = SvRV(ST(1));
936 AV * const av = newAV();
940 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
942 mg = mg_find(sv, PERL_MAGIC_ext);
943 mg->mg_virtual = &perlio_vtab;
945 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
946 for (i = 2; i < items; i++) {
948 const char * const name = SvPV_const(ST(i), len);
949 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
951 av_push(av, SvREFCNT_inc_simple_NN(layer));
962 #endif /* USE_ATTIBUTES_FOR_PERLIO */
965 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
967 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
968 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
972 XS(XS_PerlIO__Layer__NoWarnings)
974 /* This is used as a %SIG{__WARN__} handler to suppress warnings
975 during loading of layers.
981 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
985 XS(XS_PerlIO__Layer__find)
991 Perl_croak(aTHX_ "Usage class->find(name[,load])");
994 const char * const name = SvPV_const(ST(1), len);
995 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
996 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
998 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
1005 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
1008 if (!PL_known_layers)
1009 PL_known_layers = PerlIO_list_alloc(aTHX);
1010 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
1011 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
1015 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1019 const char *s = names;
1021 while (isSPACE(*s) || *s == ':')
1026 const char *as = NULL;
1028 if (!isIDFIRST(*s)) {
1030 * Message is consistent with how attribute lists are
1031 * passed. Even though this means "foo : : bar" is
1032 * seen as an invalid separator character.
1034 const char q = ((*s == '\'') ? '"' : '\'');
1035 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1036 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1038 SETERRNO(EINVAL, LIB_INVARG);
1043 } while (isALNUM(*e));
1052 alen = (e - 1) - as;
1059 * It's a nul terminated string, not allowed
1060 * to \ the terminating null. Anything other
1061 * character is passed over.
1071 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1072 "Argument list not closed for PerlIO layer \"%.*s\"",
1084 PerlIO_funcs * const layer =
1085 PerlIO_find_layer(aTHX_ s, llen, 1);
1089 arg = newSVpvn(as, alen);
1090 PerlIO_list_push(aTHX_ av, layer,
1091 (arg) ? arg : &PL_sv_undef);
1095 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1108 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1111 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1112 #ifdef PERLIO_USING_CRLF
1115 if (PerlIO_stdio.Set_ptrcnt)
1116 tab = &PerlIO_stdio;
1118 PerlIO_debug("Pushing %s\n", tab->name);
1119 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1124 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1126 return av->array[n].arg;
1130 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1132 if (n >= 0 && n < av->cur) {
1133 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1134 av->array[n].funcs->name);
1135 return av->array[n].funcs;
1138 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1143 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1145 PERL_UNUSED_ARG(mode);
1146 PERL_UNUSED_ARG(arg);
1147 PERL_UNUSED_ARG(tab);
1148 if (PerlIOValid(f)) {
1150 PerlIO_pop(aTHX_ f);
1156 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1157 sizeof(PerlIO_funcs),
1160 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1180 NULL, /* get_base */
1181 NULL, /* get_bufsiz */
1184 NULL, /* set_ptrcnt */
1188 PerlIO_default_layers(pTHX)
1191 if (!PL_def_layerlist) {
1192 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1193 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1194 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1195 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1197 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1199 osLayer = &PerlIO_win32;
1202 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1203 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1204 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1205 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1207 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1209 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1210 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1211 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1212 PerlIO_list_push(aTHX_ PL_def_layerlist,
1213 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1216 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1219 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1222 if (PL_def_layerlist->cur < 2) {
1223 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1225 return PL_def_layerlist;
1229 Perl_boot_core_PerlIO(pTHX)
1231 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1232 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1235 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1236 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1240 PerlIO_default_layer(pTHX_ I32 n)
1243 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1246 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1249 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1250 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1253 PerlIO_stdstreams(pTHX)
1257 PerlIO_init_table(aTHX);
1258 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1259 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1260 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1265 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1268 if (tab->fsize != sizeof(PerlIO_funcs)) {
1270 "%s (%"UVuf") does not match %s (%"UVuf")",
1271 "PerlIO layer function table size", (UV)tab->fsize,
1272 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1276 if (tab->size < sizeof(PerlIOl)) {
1278 "%s (%"UVuf") smaller than %s (%"UVuf")",
1279 "PerlIO layer instance size", (UV)tab->size,
1280 "size expected by this perl", (UV)sizeof(PerlIOl) );
1282 /* Real layer with a data area */
1285 Newxz(temp, tab->size, char);
1289 l->tab = (PerlIO_funcs*) tab;
1290 l->head = ((PerlIOl*)f)->head;
1292 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1293 (void*)f, tab->name,
1294 (mode) ? mode : "(Null)", (void*)arg);
1295 if (*l->tab->Pushed &&
1297 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1298 PerlIO_pop(aTHX_ f);
1307 /* Pseudo-layer where push does its own stack adjust */
1308 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1309 (mode) ? mode : "(Null)", (void*)arg);
1311 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1319 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1320 IV n, const char *mode, int fd, int imode, int perm,
1321 PerlIO *old, int narg, SV **args)
1323 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1324 if (tab && tab->Open) {
1325 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1326 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1332 SETERRNO(EINVAL, LIB_INVARG);
1337 PerlIOBase_binmode(pTHX_ PerlIO *f)
1339 if (PerlIOValid(f)) {
1340 /* Is layer suitable for raw stream ? */
1341 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1342 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1343 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1346 /* Not suitable - pop it */
1347 PerlIO_pop(aTHX_ f);
1355 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1357 PERL_UNUSED_ARG(mode);
1358 PERL_UNUSED_ARG(arg);
1359 PERL_UNUSED_ARG(tab);
1361 if (PerlIOValid(f)) {
1366 * Strip all layers that are not suitable for a raw stream
1369 while (t && (l = *t)) {
1370 if (l->tab && l->tab->Binmode) {
1371 /* Has a handler - normal case */
1372 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1374 /* Layer still there - move down a layer */
1383 /* No handler - pop it */
1384 PerlIO_pop(aTHX_ t);
1387 if (PerlIOValid(f)) {
1388 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1389 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1397 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1398 PerlIO_list_t *layers, IV n, IV max)
1402 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1404 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1415 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1419 save_scalar(PL_errgv);
1421 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1422 code = PerlIO_parse_layers(aTHX_ layers, names);
1424 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1426 PerlIO_list_free(aTHX_ layers);
1433 /*--------------------------------------------------------------------------------------*/
1435 * Given the abstraction above the public API functions
1439 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1441 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1442 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1443 PerlIOBase(f)->tab->name : "(Null)",
1444 iotype, mode, (names) ? names : "(Null)");
1447 /* Do not flush etc. if (e.g.) switching encodings.
1448 if a pushed layer knows it needs to flush lower layers
1449 (for example :unix which is never going to call them)
1450 it can do the flush when it is pushed.
1452 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1455 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1456 #ifdef PERLIO_USING_CRLF
1457 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1458 O_BINARY so we can look for it in mode.
1460 if (!(mode & O_BINARY)) {
1462 /* FIXME?: Looking down the layer stack seems wrong,
1463 but is a way of reaching past (say) an encoding layer
1464 to flip CRLF-ness of the layer(s) below
1467 /* Perhaps we should turn on bottom-most aware layer
1468 e.g. Ilya's idea that UNIX TTY could serve
1470 if (PerlIOBase(f)->tab &&
1471 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1473 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1474 /* Not in text mode - flush any pending stuff and flip it */
1476 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1478 /* Only need to turn it on in one layer so we are done */
1483 /* Not finding a CRLF aware layer presumably means we are binary
1484 which is not what was requested - so we failed
1485 We _could_ push :crlf layer but so could caller
1490 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1491 So code that used to be here is now in PerlIORaw_pushed().
1493 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1498 PerlIO__close(pTHX_ PerlIO *f)
1500 if (PerlIOValid(f)) {
1501 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1502 if (tab && tab->Close)
1503 return (*tab->Close)(aTHX_ f);
1505 return PerlIOBase_close(aTHX_ f);
1508 SETERRNO(EBADF, SS_IVCHAN);
1514 Perl_PerlIO_close(pTHX_ PerlIO *f)
1516 const int code = PerlIO__close(aTHX_ f);
1517 while (PerlIOValid(f)) {
1518 PerlIO_pop(aTHX_ f);
1519 if (PerlIO_lockcnt(f))
1520 /* we're in use; the 'pop' deferred freeing the structure */
1527 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1530 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1534 static PerlIO_funcs *
1535 PerlIO_layer_from_ref(pTHX_ SV *sv)
1539 * For any scalar type load the handler which is bundled with perl
1541 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1542 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1543 /* This isn't supposed to happen, since PerlIO::scalar is core,
1544 * but could happen anyway in smaller installs or with PAR */
1546 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1551 * For other types allow if layer is known but don't try and load it
1553 switch (SvTYPE(sv)) {
1555 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1557 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1559 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1561 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1568 PerlIO_resolve_layers(pTHX_ const char *layers,
1569 const char *mode, int narg, SV **args)
1572 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1575 PerlIO_stdstreams(aTHX);
1577 SV * const arg = *args;
1579 * If it is a reference but not an object see if we have a handler
1582 if (SvROK(arg) && !sv_isobject(arg)) {
1583 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1585 def = PerlIO_list_alloc(aTHX);
1586 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1590 * Don't fail if handler cannot be found :via(...) etc. may do
1591 * something sensible else we will just stringfy and open
1596 if (!layers || !*layers)
1597 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1598 if (layers && *layers) {
1601 av = PerlIO_clone_list(aTHX_ def, NULL);
1606 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1610 PerlIO_list_free(aTHX_ av);
1622 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1623 int imode, int perm, PerlIO *f, int narg, SV **args)
1626 if (!f && narg == 1 && *args == &PL_sv_undef) {
1627 if ((f = PerlIO_tmpfile())) {
1628 if (!layers || !*layers)
1629 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1630 if (layers && *layers)
1631 PerlIO_apply_layers(aTHX_ f, mode, layers);
1635 PerlIO_list_t *layera;
1637 PerlIO_funcs *tab = NULL;
1638 if (PerlIOValid(f)) {
1640 * This is "reopen" - it is not tested as perl does not use it
1644 layera = PerlIO_list_alloc(aTHX);
1647 if (l->tab && l->tab->Getarg)
1648 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1649 PerlIO_list_push(aTHX_ layera, l->tab,
1650 (arg) ? arg : &PL_sv_undef);
1652 l = *PerlIONext(&l);
1656 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1662 * Start at "top" of layer stack
1664 n = layera->cur - 1;
1666 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1675 * Found that layer 'n' can do opens - call it
1677 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1678 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1680 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1681 tab->name, layers ? layers : "(Null)", mode, fd,
1682 imode, perm, (void*)f, narg, (void*)args);
1684 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1687 SETERRNO(EINVAL, LIB_INVARG);
1691 if (n + 1 < layera->cur) {
1693 * More layers above the one that we used to open -
1696 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1697 /* If pushing layers fails close the file */
1704 PerlIO_list_free(aTHX_ layera);
1711 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1713 PERL_ARGS_ASSERT_PERLIO_READ;
1715 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1719 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1721 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1723 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1727 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1729 PERL_ARGS_ASSERT_PERLIO_WRITE;
1731 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1735 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1737 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1741 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1743 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1747 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1752 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1754 if (tab && tab->Flush)
1755 return (*tab->Flush) (aTHX_ f);
1757 return 0; /* If no Flush defined, silently succeed. */
1760 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1761 SETERRNO(EBADF, SS_IVCHAN);
1767 * Is it good API design to do flush-all on NULL, a potentially
1768 * erroneous input? Maybe some magical value (PerlIO*
1769 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1770 * things on fflush(NULL), but should we be bound by their design
1773 PerlIOl **table = &PL_perlio;
1776 while ((ff = *table)) {
1778 table = (PerlIOl **) (ff++);
1779 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1780 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1790 PerlIOBase_flush_linebuf(pTHX)
1793 PerlIOl **table = &PL_perlio;
1795 while ((f = *table)) {
1797 table = (PerlIOl **) (f++);
1798 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1800 && (PerlIOBase(&(f->next))->
1801 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1802 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1803 PerlIO_flush(&(f->next));
1810 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1812 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1816 PerlIO_isutf8(PerlIO *f)
1819 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1821 SETERRNO(EBADF, SS_IVCHAN);
1827 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1829 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1833 Perl_PerlIO_error(pTHX_ PerlIO *f)
1835 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1839 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1841 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1845 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1847 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1851 PerlIO_has_base(PerlIO *f)
1853 if (PerlIOValid(f)) {
1854 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1857 return (tab->Get_base != NULL);
1864 PerlIO_fast_gets(PerlIO *f)
1866 if (PerlIOValid(f)) {
1867 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1868 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1871 return (tab->Set_ptrcnt != NULL);
1879 PerlIO_has_cntptr(PerlIO *f)
1881 if (PerlIOValid(f)) {
1882 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1885 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1892 PerlIO_canset_cnt(PerlIO *f)
1894 if (PerlIOValid(f)) {
1895 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1898 return (tab->Set_ptrcnt != NULL);
1905 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1907 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1911 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1913 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1917 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1919 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1923 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1925 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1929 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1931 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1935 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1937 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1941 /*--------------------------------------------------------------------------------------*/
1943 * utf8 and raw dummy layers
1947 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1949 PERL_UNUSED_CONTEXT;
1950 PERL_UNUSED_ARG(mode);
1951 PERL_UNUSED_ARG(arg);
1952 if (PerlIOValid(f)) {
1953 if (tab && tab->kind & PERLIO_K_UTF8)
1954 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1956 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1962 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1963 sizeof(PerlIO_funcs),
1966 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1986 NULL, /* get_base */
1987 NULL, /* get_bufsiz */
1990 NULL, /* set_ptrcnt */
1993 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1994 sizeof(PerlIO_funcs),
1997 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
2017 NULL, /* get_base */
2018 NULL, /* get_bufsiz */
2021 NULL, /* set_ptrcnt */
2024 PERLIO_FUNCS_DECL(PerlIO_raw) = {
2025 sizeof(PerlIO_funcs),
2048 NULL, /* get_base */
2049 NULL, /* get_bufsiz */
2052 NULL, /* set_ptrcnt */
2054 /*--------------------------------------------------------------------------------------*/
2055 /*--------------------------------------------------------------------------------------*/
2057 * "Methods" of the "base class"
2061 PerlIOBase_fileno(pTHX_ PerlIO *f)
2063 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2067 PerlIO_modestr(PerlIO * f, char *buf)
2070 if (PerlIOValid(f)) {
2071 const IV flags = PerlIOBase(f)->flags;
2072 if (flags & PERLIO_F_APPEND) {
2074 if (flags & PERLIO_F_CANREAD) {
2078 else if (flags & PERLIO_F_CANREAD) {
2080 if (flags & PERLIO_F_CANWRITE)
2083 else if (flags & PERLIO_F_CANWRITE) {
2085 if (flags & PERLIO_F_CANREAD) {
2089 #ifdef PERLIO_USING_CRLF
2090 if (!(flags & PERLIO_F_CRLF))
2100 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2102 PerlIOl * const l = PerlIOBase(f);
2103 PERL_UNUSED_CONTEXT;
2104 PERL_UNUSED_ARG(arg);
2106 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2107 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2108 if (tab && tab->Set_ptrcnt != NULL)
2109 l->flags |= PERLIO_F_FASTGETS;
2111 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2115 l->flags |= PERLIO_F_CANREAD;
2118 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2121 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2124 SETERRNO(EINVAL, LIB_INVARG);
2130 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2133 l->flags &= ~PERLIO_F_CRLF;
2136 l->flags |= PERLIO_F_CRLF;
2139 SETERRNO(EINVAL, LIB_INVARG);
2146 l->flags |= l->next->flags &
2147 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2152 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2153 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2154 l->flags, PerlIO_modestr(f, temp));
2160 PerlIOBase_popped(pTHX_ PerlIO *f)
2162 PERL_UNUSED_CONTEXT;
2168 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2171 * Save the position as current head considers it
2173 const Off_t old = PerlIO_tell(f);
2174 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2175 PerlIOSelf(f, PerlIOBuf)->posn = old;
2176 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2180 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2182 STDCHAR *buf = (STDCHAR *) vbuf;
2184 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2185 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2186 SETERRNO(EBADF, SS_IVCHAN);
2192 SSize_t avail = PerlIO_get_cnt(f);
2195 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2197 STDCHAR *ptr = PerlIO_get_ptr(f);
2198 Copy(ptr, buf, take, STDCHAR);
2199 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2202 if (avail == 0) /* set_ptrcnt could have reset avail */
2205 if (count > 0 && avail <= 0) {
2206 if (PerlIO_fill(f) != 0)
2211 return (buf - (STDCHAR *) vbuf);
2217 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2219 PERL_UNUSED_CONTEXT;
2225 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2227 PERL_UNUSED_CONTEXT;
2233 PerlIOBase_close(pTHX_ PerlIO *f)
2236 if (PerlIOValid(f)) {
2237 PerlIO *n = PerlIONext(f);
2238 code = PerlIO_flush(f);
2239 PerlIOBase(f)->flags &=
2240 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2241 while (PerlIOValid(n)) {
2242 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2243 if (tab && tab->Close) {
2244 if ((*tab->Close)(aTHX_ n) != 0)
2249 PerlIOBase(n)->flags &=
2250 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2256 SETERRNO(EBADF, SS_IVCHAN);
2262 PerlIOBase_eof(pTHX_ PerlIO *f)
2264 PERL_UNUSED_CONTEXT;
2265 if (PerlIOValid(f)) {
2266 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2272 PerlIOBase_error(pTHX_ PerlIO *f)
2274 PERL_UNUSED_CONTEXT;
2275 if (PerlIOValid(f)) {
2276 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2282 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2284 if (PerlIOValid(f)) {
2285 PerlIO * const n = PerlIONext(f);
2286 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2293 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2295 PERL_UNUSED_CONTEXT;
2296 if (PerlIOValid(f)) {
2297 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2302 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2308 arg = sv_dup(arg, param);
2309 SvREFCNT_inc_simple_void_NN(arg);
2313 return newSVsv(arg);
2316 PERL_UNUSED_ARG(param);
2317 return newSVsv(arg);
2322 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2324 PerlIO * const nexto = PerlIONext(o);
2325 if (PerlIOValid(nexto)) {
2326 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2327 if (tab && tab->Dup)
2328 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2330 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2333 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2336 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2337 self ? self->name : "(Null)",
2338 (void*)f, (void*)o, (void*)param);
2339 if (self && self->Getarg)
2340 arg = (*self->Getarg)(aTHX_ o, param, flags);
2341 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2342 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2343 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2349 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2351 /* Must be called with PL_perlio_mutex locked. */
2353 S_more_refcounted_fds(pTHX_ const int new_fd) {
2355 const int old_max = PL_perlio_fd_refcnt_size;
2356 const int new_max = 16 + (new_fd & ~15);
2359 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2360 old_max, new_fd, new_max);
2362 if (new_fd < old_max) {
2366 assert (new_max > new_fd);
2368 /* Use plain realloc() since we need this memory to be really
2369 * global and visible to all the interpreters and/or threads. */
2370 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2374 MUTEX_UNLOCK(&PL_perlio_mutex);
2376 /* Can't use PerlIO to write as it allocates memory */
2377 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2378 PL_no_mem, strlen(PL_no_mem));
2382 PL_perlio_fd_refcnt_size = new_max;
2383 PL_perlio_fd_refcnt = new_array;
2385 PerlIO_debug("Zeroing %p, %d\n",
2386 (void*)(new_array + old_max),
2389 Zero(new_array + old_max, new_max - old_max, int);
2396 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2397 PERL_UNUSED_CONTEXT;
2401 PerlIOUnix_refcnt_inc(int fd)
2408 MUTEX_LOCK(&PL_perlio_mutex);
2410 if (fd >= PL_perlio_fd_refcnt_size)
2411 S_more_refcounted_fds(aTHX_ fd);
2413 PL_perlio_fd_refcnt[fd]++;
2414 if (PL_perlio_fd_refcnt[fd] <= 0) {
2415 /* diag_listed_as: refcnt_inc: fd %d%s */
2416 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2417 fd, PL_perlio_fd_refcnt[fd]);
2419 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2420 fd, PL_perlio_fd_refcnt[fd]);
2423 MUTEX_UNLOCK(&PL_perlio_mutex);
2426 /* diag_listed_as: refcnt_inc: fd %d%s */
2427 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2432 PerlIOUnix_refcnt_dec(int fd)
2439 MUTEX_LOCK(&PL_perlio_mutex);
2441 if (fd >= PL_perlio_fd_refcnt_size) {
2442 /* diag_listed_as: refcnt_dec: fd %d%s */
2443 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2444 fd, PL_perlio_fd_refcnt_size);
2446 if (PL_perlio_fd_refcnt[fd] <= 0) {
2447 /* diag_listed_as: refcnt_dec: fd %d%s */
2448 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2449 fd, PL_perlio_fd_refcnt[fd]);
2451 cnt = --PL_perlio_fd_refcnt[fd];
2452 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2454 MUTEX_UNLOCK(&PL_perlio_mutex);
2457 /* diag_listed_as: refcnt_dec: fd %d%s */
2458 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2464 PerlIOUnix_refcnt(int fd)
2471 MUTEX_LOCK(&PL_perlio_mutex);
2473 if (fd >= PL_perlio_fd_refcnt_size) {
2474 /* diag_listed_as: refcnt: fd %d%s */
2475 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2476 fd, PL_perlio_fd_refcnt_size);
2478 if (PL_perlio_fd_refcnt[fd] <= 0) {
2479 /* diag_listed_as: refcnt: fd %d%s */
2480 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2481 fd, PL_perlio_fd_refcnt[fd]);
2483 cnt = PL_perlio_fd_refcnt[fd];
2485 MUTEX_UNLOCK(&PL_perlio_mutex);
2488 /* diag_listed_as: refcnt: fd %d%s */
2489 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2495 PerlIO_cleanup(pTHX)
2500 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2502 PerlIO_debug("Cleanup layers\n");
2505 /* Raise STDIN..STDERR refcount so we don't close them */
2506 for (i=0; i < 3; i++)
2507 PerlIOUnix_refcnt_inc(i);
2508 PerlIO_cleantable(aTHX_ &PL_perlio);
2509 /* Restore STDIN..STDERR refcount */
2510 for (i=0; i < 3; i++)
2511 PerlIOUnix_refcnt_dec(i);
2513 if (PL_known_layers) {
2514 PerlIO_list_free(aTHX_ PL_known_layers);
2515 PL_known_layers = NULL;
2517 if (PL_def_layerlist) {
2518 PerlIO_list_free(aTHX_ PL_def_layerlist);
2519 PL_def_layerlist = NULL;
2523 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2527 /* XXX we can't rely on an interpreter being present at this late stage,
2528 XXX so we can't use a function like PerlLIO_write that relies on one
2529 being present (at least in win32) :-(.
2534 /* By now all filehandles should have been closed, so any
2535 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2537 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2538 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2539 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2541 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2542 if (PL_perlio_fd_refcnt[i]) {
2544 my_snprintf(buf, sizeof(buf),
2545 "PerlIO_teardown: fd %d refcnt=%d\n",
2546 i, PL_perlio_fd_refcnt[i]);
2547 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2553 /* Not bothering with PL_perlio_mutex since by now
2554 * all the interpreters are gone. */
2555 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2556 && PL_perlio_fd_refcnt) {
2557 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2558 PL_perlio_fd_refcnt = NULL;
2559 PL_perlio_fd_refcnt_size = 0;
2563 /*--------------------------------------------------------------------------------------*/
2565 * Bottom-most level for UNIX-like case
2569 struct _PerlIO base; /* The generic part */
2570 int fd; /* UNIX like file descriptor */
2571 int oflags; /* open/fcntl flags */
2575 S_lockcnt_dec(pTHX_ const void* f)
2577 PerlIO_lockcnt((PerlIO*)f)--;
2581 /* call the signal handler, and if that handler happens to clear
2582 * this handle, free what we can and return true */
2585 S_perlio_async_run(pTHX_ PerlIO* f) {
2587 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2588 PerlIO_lockcnt(f)++;
2590 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2592 /* we've just run some perl-level code that could have done
2593 * anything, including closing the file or clearing this layer.
2594 * If so, free any lower layers that have already been
2595 * cleared, then return an error. */
2596 while (PerlIOValid(f) &&
2597 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2599 const PerlIOl *l = *f;
2607 PerlIOUnix_oflags(const char *mode)
2610 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2615 if (*++mode == '+') {
2622 oflags = O_CREAT | O_TRUNC;
2623 if (*++mode == '+') {
2632 oflags = O_CREAT | O_APPEND;
2633 if (*++mode == '+') {
2646 else if (*mode == 't') {
2648 oflags &= ~O_BINARY;
2652 * Always open in binary mode
2655 if (*mode || oflags == -1) {
2656 SETERRNO(EINVAL, LIB_INVARG);
2663 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2665 PERL_UNUSED_CONTEXT;
2666 return PerlIOSelf(f, PerlIOUnix)->fd;
2670 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2672 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2675 if (PerlLIO_fstat(fd, &st) == 0) {
2676 if (!S_ISREG(st.st_mode)) {
2677 PerlIO_debug("%d is not regular file\n",fd);
2678 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2681 PerlIO_debug("%d _is_ a regular file\n",fd);
2687 PerlIOUnix_refcnt_inc(fd);
2688 PERL_UNUSED_CONTEXT;
2692 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2694 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2695 if (*PerlIONext(f)) {
2696 /* We never call down so do any pending stuff now */
2697 PerlIO_flush(PerlIONext(f));
2699 * XXX could (or should) we retrieve the oflags from the open file
2700 * handle rather than believing the "mode" we are passed in? XXX
2701 * Should the value on NULL mode be 0 or -1?
2703 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2704 mode ? PerlIOUnix_oflags(mode) : -1);
2706 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2712 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2714 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2716 PERL_UNUSED_CONTEXT;
2717 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2719 SETERRNO(ESPIPE, LIB_INVARG);
2721 SETERRNO(EINVAL, LIB_INVARG);
2725 new_loc = PerlLIO_lseek(fd, offset, whence);
2726 if (new_loc == (Off_t) - 1)
2728 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2733 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2734 IV n, const char *mode, int fd, int imode,
2735 int perm, PerlIO *f, int narg, SV **args)
2737 if (PerlIOValid(f)) {
2738 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2739 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2742 if (*mode == IoTYPE_NUMERIC)
2745 imode = PerlIOUnix_oflags(mode);
2747 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2753 const char *path = SvPV_nolen_const(*args);
2754 fd = PerlLIO_open3(path, imode, perm);
2758 if (*mode == IoTYPE_IMPLICIT)
2761 f = PerlIO_allocate(aTHX);
2763 if (!PerlIOValid(f)) {
2764 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2768 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2769 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2770 if (*mode == IoTYPE_APPEND)
2771 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2778 * FIXME: pop layers ???
2786 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2788 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2790 if (flags & PERLIO_DUP_FD) {
2791 fd = PerlLIO_dup(fd);
2794 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2796 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2797 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2806 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2810 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2812 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2813 #ifdef PERLIO_STD_SPECIAL
2815 return PERLIO_STD_IN(fd, vbuf, count);
2817 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2818 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2822 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2823 if (len >= 0 || errno != EINTR) {
2825 if (errno != EAGAIN) {
2826 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2829 else if (len == 0 && count != 0) {
2830 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2836 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2843 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2847 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2849 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2850 #ifdef PERLIO_STD_SPECIAL
2851 if (fd == 1 || fd == 2)
2852 return PERLIO_STD_OUT(fd, vbuf, count);
2855 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2856 if (len >= 0 || errno != EINTR) {
2858 if (errno != EAGAIN) {
2859 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2865 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2872 PerlIOUnix_tell(pTHX_ PerlIO *f)
2874 PERL_UNUSED_CONTEXT;
2876 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2881 PerlIOUnix_close(pTHX_ PerlIO *f)
2884 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2886 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2887 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2888 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2893 SETERRNO(EBADF,SS_IVCHAN);
2896 while (PerlLIO_close(fd) != 0) {
2897 if (errno != EINTR) {
2902 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2906 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2911 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2912 sizeof(PerlIO_funcs),
2919 PerlIOBase_binmode, /* binmode */
2929 PerlIOBase_noop_ok, /* flush */
2930 PerlIOBase_noop_fail, /* fill */
2933 PerlIOBase_clearerr,
2934 PerlIOBase_setlinebuf,
2935 NULL, /* get_base */
2936 NULL, /* get_bufsiz */
2939 NULL, /* set_ptrcnt */
2942 /*--------------------------------------------------------------------------------------*/
2947 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2948 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2949 broken by the last second glibc 2.3 fix
2951 #define STDIO_BUFFER_WRITABLE
2956 struct _PerlIO base;
2957 FILE *stdio; /* The stream */
2961 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2963 PERL_UNUSED_CONTEXT;
2965 if (PerlIOValid(f)) {
2966 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2968 return PerlSIO_fileno(s);
2975 PerlIOStdio_mode(const char *mode, char *tmode)
2977 char * const ret = tmode;
2983 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2991 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2994 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2995 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2996 if (toptab == tab) {
2997 /* Top is already stdio - pop self (duplicate) and use original */
2998 PerlIO_pop(aTHX_ f);
3001 const int fd = PerlIO_fileno(n);
3004 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
3005 mode = PerlIOStdio_mode(mode, tmode)))) {
3006 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3007 /* We never call down so do any pending stuff now */
3008 PerlIO_flush(PerlIONext(f));
3015 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3020 PerlIO_importFILE(FILE *stdio, const char *mode)
3026 if (!mode || !*mode) {
3027 /* We need to probe to see how we can open the stream
3028 so start with read/write and then try write and read
3029 we dup() so that we can fclose without loosing the fd.
3031 Note that the errno value set by a failing fdopen
3032 varies between stdio implementations.
3034 const int fd = PerlLIO_dup(fileno(stdio));
3035 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3037 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3040 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3043 /* Don't seem to be able to open */
3049 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3050 s = PerlIOSelf(f, PerlIOStdio);
3052 PerlIOUnix_refcnt_inc(fileno(stdio));
3059 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3060 IV n, const char *mode, int fd, int imode,
3061 int perm, PerlIO *f, int narg, SV **args)
3064 if (PerlIOValid(f)) {
3065 const char * const path = SvPV_nolen_const(*args);
3066 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3068 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3069 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3074 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3079 const char * const path = SvPV_nolen_const(*args);
3080 if (*mode == IoTYPE_NUMERIC) {
3082 fd = PerlLIO_open3(path, imode, perm);
3086 bool appended = FALSE;
3088 /* Cygwin wants its 'b' early. */
3090 mode = PerlIOStdio_mode(mode, tmode);
3092 stdio = PerlSIO_fopen(path, mode);
3095 f = PerlIO_allocate(aTHX);
3098 mode = PerlIOStdio_mode(mode, tmode);
3099 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3101 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3102 PerlIOUnix_refcnt_inc(fileno(stdio));
3104 PerlSIO_fclose(stdio);
3116 if (*mode == IoTYPE_IMPLICIT) {
3123 stdio = PerlSIO_stdin;
3126 stdio = PerlSIO_stdout;
3129 stdio = PerlSIO_stderr;
3134 stdio = PerlSIO_fdopen(fd, mode =
3135 PerlIOStdio_mode(mode, tmode));
3139 f = PerlIO_allocate(aTHX);
3141 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3142 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3143 PerlIOUnix_refcnt_inc(fileno(stdio));
3153 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3155 /* This assumes no layers underneath - which is what
3156 happens, but is not how I remember it. NI-S 2001/10/16
3158 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3159 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3160 const int fd = fileno(stdio);
3162 if (flags & PERLIO_DUP_FD) {
3163 const int dfd = PerlLIO_dup(fileno(stdio));
3165 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3170 /* FIXME: To avoid messy error recovery if dup fails
3171 re-use the existing stdio as though flag was not set
3175 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3177 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3179 PerlIOUnix_refcnt_inc(fileno(stdio));
3186 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3188 PERL_UNUSED_CONTEXT;
3190 /* XXX this could use PerlIO_canset_fileno() and
3191 * PerlIO_set_fileno() support from Configure
3193 # if defined(__UCLIBC__)
3194 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3197 # elif defined(__GLIBC__)
3198 /* There may be a better way for GLIBC:
3199 - libio.h defines a flag to not close() on cleanup
3203 # elif defined(__sun__)
3206 # elif defined(__hpux)
3210 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3211 your platform does not have special entry try this one.
3212 [For OSF only have confirmation for Tru64 (alpha)
3213 but assume other OSFs will be similar.]
3215 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3218 # elif defined(__FreeBSD__)
3219 /* There may be a better way on FreeBSD:
3220 - we could insert a dummy func in the _close function entry
3221 f->_close = (int (*)(void *)) dummy_close;
3225 # elif defined(__OpenBSD__)
3226 /* There may be a better way on OpenBSD:
3227 - we could insert a dummy func in the _close function entry
3228 f->_close = (int (*)(void *)) dummy_close;
3232 # elif defined(__EMX__)
3233 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3236 # elif defined(__CYGWIN__)
3237 /* There may be a better way on CYGWIN:
3238 - we could insert a dummy func in the _close function entry
3239 f->_close = (int (*)(void *)) dummy_close;
3243 # elif defined(WIN32)
3244 # if defined(__BORLANDC__)
3245 f->fd = PerlLIO_dup(fileno(f));
3246 # elif defined(UNDER_CE)
3247 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3256 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3257 (which isn't thread safe) instead
3259 # error "Don't know how to set FILE.fileno on your platform"
3267 PerlIOStdio_close(pTHX_ PerlIO *f)
3269 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3275 const int fd = fileno(stdio);
3283 #ifdef SOCKS5_VERSION_NAME
3284 /* Socks lib overrides close() but stdio isn't linked to
3285 that library (though we are) - so we must call close()
3286 on sockets on stdio's behalf.
3289 Sock_size_t optlen = sizeof(int);
3290 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3293 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3294 that a subsequent fileno() on it returns -1. Don't want to croak()
3295 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3296 trying to close an already closed handle which somehow it still has
3297 a reference to. (via.xs, I'm looking at you). */
3298 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3299 /* File descriptor still in use */
3303 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3304 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3306 if (stdio == stdout || stdio == stderr)
3307 return PerlIO_flush(f);
3308 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3309 Use Sarathy's trick from maint-5.6 to invalidate the
3310 fileno slot of the FILE *
3312 result = PerlIO_flush(f);
3314 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3317 MUTEX_LOCK(&PL_perlio_mutex);
3318 /* Right. We need a mutex here because for a brief while we
3319 will have the situation that fd is actually closed. Hence if
3320 a second thread were to get into this block, its dup() would
3321 likely return our fd as its dupfd. (after all, it is closed)
3322 Then if we get to the dup2() first, we blat the fd back
3323 (messing up its temporary as a side effect) only for it to
3324 then close its dupfd (== our fd) in its close(dupfd) */
3326 /* There is, of course, a race condition, that any other thread
3327 trying to input/output/whatever on this fd will be stuffed
3328 for the duration of this little manoeuvrer. Perhaps we
3329 should hold an IO mutex for the duration of every IO
3330 operation if we know that invalidate doesn't work on this
3331 platform, but that would suck, and could kill performance.
3333 Except that correctness trumps speed.
3334 Advice from klortho #11912. */
3336 dupfd = PerlLIO_dup(fd);
3339 MUTEX_UNLOCK(&PL_perlio_mutex);
3340 /* Oh cXap. This isn't going to go well. Not sure if we can
3341 recover from here, or if closing this particular FILE *
3342 is a good idea now. */
3347 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3349 result = PerlSIO_fclose(stdio);
3350 /* We treat error from stdio as success if we invalidated
3351 errno may NOT be expected EBADF
3353 if (invalidate && result != 0) {
3357 #ifdef SOCKS5_VERSION_NAME
3358 /* in SOCKS' case, let close() determine return value */
3362 PerlLIO_dup2(dupfd,fd);
3363 PerlLIO_close(dupfd);
3365 MUTEX_UNLOCK(&PL_perlio_mutex);
3373 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3378 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3380 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3383 STDCHAR *buf = (STDCHAR *) vbuf;
3385 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3386 * stdio does not do that for fread()
3388 const int ch = PerlSIO_fgetc(s);
3395 got = PerlSIO_fread(vbuf, 1, count, s);
3396 if (got == 0 && PerlSIO_ferror(s))
3398 if (got >= 0 || errno != EINTR)
3400 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3402 SETERRNO(0,0); /* just in case */
3408 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3411 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3413 #ifdef STDIO_BUFFER_WRITABLE
3414 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3415 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3416 STDCHAR *base = PerlIO_get_base(f);
3417 SSize_t cnt = PerlIO_get_cnt(f);
3418 STDCHAR *ptr = PerlIO_get_ptr(f);
3419 SSize_t avail = ptr - base;
3421 if (avail > count) {
3425 Move(buf-avail,ptr,avail,STDCHAR);
3428 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3429 if (PerlSIO_feof(s) && unread >= 0)
3430 PerlSIO_clearerr(s);
3435 if (PerlIO_has_cntptr(f)) {
3436 /* We can get pointer to buffer but not its base
3437 Do ungetc() but check chars are ending up in the
3440 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3441 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3443 const int ch = *--buf & 0xFF;
3444 if (ungetc(ch,s) != ch) {
3445 /* ungetc did not work */
3448 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3449 /* Did not change pointer as expected */
3450 fgetc(s); /* get char back again */
3460 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3466 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3470 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3473 got = PerlSIO_fwrite(vbuf, 1, count,
3474 PerlIOSelf(f, PerlIOStdio)->stdio);
3475 if (got >= 0 || errno != EINTR)
3477 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3479 SETERRNO(0,0); /* just in case */
3485 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3487 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3488 PERL_UNUSED_CONTEXT;
3490 return PerlSIO_fseek(stdio, offset, whence);
3494 PerlIOStdio_tell(pTHX_ PerlIO *f)
3496 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3497 PERL_UNUSED_CONTEXT;
3499 return PerlSIO_ftell(stdio);
3503 PerlIOStdio_flush(pTHX_ PerlIO *f)
3505 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3506 PERL_UNUSED_CONTEXT;
3508 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3509 return PerlSIO_fflush(stdio);
3515 * FIXME: This discards ungetc() and pre-read stuff which is not
3516 * right if this is just a "sync" from a layer above Suspect right
3517 * design is to do _this_ but not have layer above flush this
3518 * layer read-to-read
3521 * Not writeable - sync by attempting a seek
3524 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3532 PerlIOStdio_eof(pTHX_ PerlIO *f)
3534 PERL_UNUSED_CONTEXT;
3536 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3540 PerlIOStdio_error(pTHX_ PerlIO *f)
3542 PERL_UNUSED_CONTEXT;
3544 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3548 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3550 PERL_UNUSED_CONTEXT;
3552 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3556 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3558 PERL_UNUSED_CONTEXT;
3560 #ifdef HAS_SETLINEBUF
3561 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3563 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3569 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3571 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3572 return (STDCHAR*)PerlSIO_get_base(stdio);
3576 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3578 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3579 return PerlSIO_get_bufsiz(stdio);
3583 #ifdef USE_STDIO_PTR
3585 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3587 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3588 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3592 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3594 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3595 return PerlSIO_get_cnt(stdio);
3599 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3601 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3603 #ifdef STDIO_PTR_LVALUE
3604 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3605 #ifdef STDIO_PTR_LVAL_SETS_CNT
3606 assert(PerlSIO_get_cnt(stdio) == (cnt));
3608 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3610 * Setting ptr _does_ change cnt - we are done
3614 #else /* STDIO_PTR_LVALUE */
3616 #endif /* STDIO_PTR_LVALUE */
3619 * Now (or only) set cnt
3621 #ifdef STDIO_CNT_LVALUE
3622 PerlSIO_set_cnt(stdio, cnt);
3623 #else /* STDIO_CNT_LVALUE */
3624 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3625 PerlSIO_set_ptr(stdio,
3626 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3628 #else /* STDIO_PTR_LVAL_SETS_CNT */
3630 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3631 #endif /* STDIO_CNT_LVALUE */
3638 PerlIOStdio_fill(pTHX_ PerlIO *f)
3642 PERL_UNUSED_CONTEXT;
3643 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3645 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3648 * fflush()ing read-only streams can cause trouble on some stdio-s
3650 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3651 if (PerlSIO_fflush(stdio) != 0)
3655 c = PerlSIO_fgetc(stdio);
3658 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3660 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3665 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3667 #ifdef STDIO_BUFFER_WRITABLE
3668 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3669 /* Fake ungetc() to the real buffer in case system's ungetc
3672 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3673 SSize_t cnt = PerlSIO_get_cnt(stdio);
3674 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3675 if (ptr == base+1) {
3676 *--ptr = (STDCHAR) c;
3677 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3678 if (PerlSIO_feof(stdio))
3679 PerlSIO_clearerr(stdio);
3685 if (PerlIO_has_cntptr(f)) {
3687 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3694 /* An ungetc()d char is handled separately from the regular
3695 * buffer, so we stuff it in the buffer ourselves.
3696 * Should never get called as should hit code above
3698 *(--((*stdio)->_ptr)) = (unsigned char) c;
3701 /* If buffer snoop scheme above fails fall back to
3704 if (PerlSIO_ungetc(c, stdio) != c)
3712 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3713 sizeof(PerlIO_funcs),
3715 sizeof(PerlIOStdio),
3716 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3720 PerlIOBase_binmode, /* binmode */
3734 PerlIOStdio_clearerr,
3735 PerlIOStdio_setlinebuf,
3737 PerlIOStdio_get_base,
3738 PerlIOStdio_get_bufsiz,
3743 #ifdef USE_STDIO_PTR
3744 PerlIOStdio_get_ptr,
3745 PerlIOStdio_get_cnt,
3746 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3747 PerlIOStdio_set_ptrcnt,
3750 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3755 #endif /* USE_STDIO_PTR */
3758 /* Note that calls to PerlIO_exportFILE() are reversed using
3759 * PerlIO_releaseFILE(), not importFILE. */
3761 PerlIO_exportFILE(PerlIO * f, const char *mode)
3765 if (PerlIOValid(f)) {
3768 if (!mode || !*mode) {
3769 mode = PerlIO_modestr(f, buf);
3771 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3775 /* De-link any lower layers so new :stdio sticks */
3777 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3778 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3780 PerlIOUnix_refcnt_inc(fileno(stdio));
3781 /* Link previous lower layers under new one */
3785 /* restore layers list */
3795 PerlIO_findFILE(PerlIO *f)
3800 if (l->tab == &PerlIO_stdio) {
3801 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3804 l = *PerlIONext(&l);
3806 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3807 /* However, we're not really exporting a FILE * to someone else (who
3808 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3809 So we need to undo its reference count increase on the underlying file
3810 descriptor. We have to do this, because if the loop above returns you
3811 the FILE *, then *it* didn't increase any reference count. So there's
3812 only one way to be consistent. */
3813 stdio = PerlIO_exportFILE(f, NULL);
3815 const int fd = fileno(stdio);
3817 PerlIOUnix_refcnt_dec(fd);
3822 /* Use this to reverse PerlIO_exportFILE calls. */
3824 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3829 if (l->tab == &PerlIO_stdio) {
3830 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3831 if (s->stdio == f) {
3833 const int fd = fileno(f);
3835 PerlIOUnix_refcnt_dec(fd);
3836 PerlIO_pop(aTHX_ p);
3845 /*--------------------------------------------------------------------------------------*/
3847 * perlio buffer layer
3851 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3853 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3854 const int fd = PerlIO_fileno(f);
3855 if (fd >= 0 && PerlLIO_isatty(fd)) {
3856 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3858 if (*PerlIONext(f)) {
3859 const Off_t posn = PerlIO_tell(PerlIONext(f));
3860 if (posn != (Off_t) - 1) {
3864 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3868 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3869 IV n, const char *mode, int fd, int imode, int perm,
3870 PerlIO *f, int narg, SV **args)
3872 if (PerlIOValid(f)) {
3873 PerlIO *next = PerlIONext(f);
3875 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3876 if (tab && tab->Open)
3878 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3880 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3885 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3887 if (*mode == IoTYPE_IMPLICIT) {
3893 if (tab && tab->Open)
3894 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3897 SETERRNO(EINVAL, LIB_INVARG);
3899 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3901 * if push fails during open, open fails. close will pop us.
3906 fd = PerlIO_fileno(f);
3907 if (init && fd == 2) {
3909 * Initial stderr is unbuffered
3911 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3913 #ifdef PERLIO_USING_CRLF
3914 # ifdef PERLIO_IS_BINMODE_FD
3915 if (PERLIO_IS_BINMODE_FD(fd))
3916 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3920 * do something about failing setmode()? --jhi
3922 PerlLIO_setmode(fd, O_BINARY);
3926 /* Enable line buffering with record-oriented regular files
3927 * so we don't introduce an extraneous record boundary when
3928 * the buffer fills up.
3930 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3932 if (PerlLIO_fstat(fd, &st) == 0
3933 && S_ISREG(st.st_mode)
3934 && (st.st_fab_rfm == FAB$C_VAR
3935 || st.st_fab_rfm == FAB$C_VFC)) {
3936 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3947 * This "flush" is akin to sfio's sync in that it handles files in either
3948 * read or write state. For write state, we put the postponed data through
3949 * the next layers. For read state, we seek() the next layers to the
3950 * offset given by current position in the buffer, and discard the buffer
3951 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3952 * in any case?). Then the pass the stick further in chain.
3955 PerlIOBuf_flush(pTHX_ PerlIO *f)
3957 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3959 PerlIO *n = PerlIONext(f);
3960 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3962 * write() the buffer
3964 const STDCHAR *buf = b->buf;
3965 const STDCHAR *p = buf;
3966 while (p < b->ptr) {
3967 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3971 else if (count < 0 || PerlIO_error(n)) {
3972 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3977 b->posn += (p - buf);
3979 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3980 STDCHAR *buf = PerlIO_get_base(f);
3982 * Note position change
3984 b->posn += (b->ptr - buf);
3985 if (b->ptr < b->end) {
3986 /* We did not consume all of it - try and seek downstream to
3987 our logical position
3989 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3990 /* Reload n as some layers may pop themselves on seek */
3991 b->posn = PerlIO_tell(n = PerlIONext(f));
3994 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3995 data is lost for good - so return saying "ok" having undone
3998 b->posn -= (b->ptr - buf);
4003 b->ptr = b->end = b->buf;
4004 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4005 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4006 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4011 /* This discards the content of the buffer after b->ptr, and rereads
4012 * the buffer from the position off in the layer downstream; here off
4013 * is at offset corresponding to b->ptr - b->buf.
4016 PerlIOBuf_fill(pTHX_ PerlIO *f)
4018 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4019 PerlIO *n = PerlIONext(f);
4022 * Down-stream flush is defined not to loose read data so is harmless.
4023 * we would not normally be fill'ing if there was data left in anycase.
4025 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4027 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4028 PerlIOBase_flush_linebuf(aTHX);
4031 PerlIO_get_base(f); /* allocate via vtable */
4033 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4035 b->ptr = b->end = b->buf;
4037 if (!PerlIOValid(n)) {
4038 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4042 if (PerlIO_fast_gets(n)) {
4044 * Layer below is also buffered. We do _NOT_ want to call its
4045 * ->Read() because that will loop till it gets what we asked for
4046 * which may hang on a pipe etc. Instead take anything it has to
4047 * hand, or ask it to fill _once_.
4049 avail = PerlIO_get_cnt(n);
4051 avail = PerlIO_fill(n);
4053 avail = PerlIO_get_cnt(n);
4055 if (!PerlIO_error(n) && PerlIO_eof(n))
4060 STDCHAR *ptr = PerlIO_get_ptr(n);
4061 const SSize_t cnt = avail;
4062 if (avail > (SSize_t)b->bufsiz)
4064 Copy(ptr, b->buf, avail, STDCHAR);
4065 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4069 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4073 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4075 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4078 b->end = b->buf + avail;
4079 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4084 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4086 if (PerlIOValid(f)) {
4087 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4090 return PerlIOBase_read(aTHX_ f, vbuf, count);
4096 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4098 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4099 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4102 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4107 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4109 * Buffer is already a read buffer, we can overwrite any chars
4110 * which have been read back to buffer start
4112 avail = (b->ptr - b->buf);
4116 * Buffer is idle, set it up so whole buffer is available for
4120 b->end = b->buf + avail;
4122 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4124 * Buffer extends _back_ from where we are now
4126 b->posn -= b->bufsiz;
4128 if (avail > (SSize_t) count) {
4130 * If we have space for more than count, just move count
4138 * In simple stdio-like ungetc() case chars will be already
4141 if (buf != b->ptr) {
4142 Copy(buf, b->ptr, avail, STDCHAR);
4146 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4150 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4156 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4158 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4159 const STDCHAR *buf = (const STDCHAR *) vbuf;
4160 const STDCHAR *flushptr = buf;
4164 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4166 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4167 if (PerlIO_flush(f) != 0) {
4171 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4172 flushptr = buf + count;
4173 while (flushptr > buf && *(flushptr - 1) != '\n')
4177 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4178 if ((SSize_t) count < avail)
4180 if (flushptr > buf && flushptr <= buf + avail)
4181 avail = flushptr - buf;
4182 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4184 Copy(buf, b->ptr, avail, STDCHAR);
4189 if (buf == flushptr)
4192 if (b->ptr >= (b->buf + b->bufsiz))
4193 if (PerlIO_flush(f) == -1)
4196 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4202 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4205 if ((code = PerlIO_flush(f)) == 0) {
4206 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4207 code = PerlIO_seek(PerlIONext(f), offset, whence);
4209 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4210 b->posn = PerlIO_tell(PerlIONext(f));
4217 PerlIOBuf_tell(pTHX_ PerlIO *f)
4219 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4221 * b->posn is file position where b->buf was read, or will be written
4223 Off_t posn = b->posn;
4224 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4225 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4227 /* As O_APPEND files are normally shared in some sense it is better
4232 /* when file is NOT shared then this is sufficient */
4233 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4235 posn = b->posn = PerlIO_tell(PerlIONext(f));
4239 * If buffer is valid adjust position by amount in buffer
4241 posn += (b->ptr - b->buf);
4247 PerlIOBuf_popped(pTHX_ PerlIO *f)
4249 const IV code = PerlIOBase_popped(aTHX_ f);
4250 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4251 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4254 b->ptr = b->end = b->buf = NULL;
4255 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4260 PerlIOBuf_close(pTHX_ PerlIO *f)
4262 const IV code = PerlIOBase_close(aTHX_ f);
4263 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4264 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4267 b->ptr = b->end = b->buf = NULL;
4268 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4273 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4275 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4282 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4284 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4287 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4288 return (b->end - b->ptr);
4293 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4295 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4296 PERL_UNUSED_CONTEXT;
4300 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4301 Newxz(b->buf,b->bufsiz, STDCHAR);
4303 b->buf = (STDCHAR *) & b->oneword;
4304 b->bufsiz = sizeof(b->oneword);
4306 b->end = b->ptr = b->buf;
4312 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4314 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4317 return (b->end - b->buf);
4321 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4323 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4325 PERL_UNUSED_ARG(cnt);
4330 assert(PerlIO_get_cnt(f) == cnt);
4331 assert(b->ptr >= b->buf);
4332 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4336 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4338 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4343 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4344 sizeof(PerlIO_funcs),
4347 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4351 PerlIOBase_binmode, /* binmode */
4365 PerlIOBase_clearerr,
4366 PerlIOBase_setlinebuf,
4371 PerlIOBuf_set_ptrcnt,
4374 /*--------------------------------------------------------------------------------------*/
4376 * Temp layer to hold unread chars when cannot do it any other way
4380 PerlIOPending_fill(pTHX_ PerlIO *f)
4383 * Should never happen
4390 PerlIOPending_close(pTHX_ PerlIO *f)
4393 * A tad tricky - flush pops us, then we close new top
4396 return PerlIO_close(f);
4400 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4403 * A tad tricky - flush pops us, then we seek new top
4406 return PerlIO_seek(f, offset, whence);
4411 PerlIOPending_flush(pTHX_ PerlIO *f)
4413 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4414 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4418 PerlIO_pop(aTHX_ f);
4423 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4429 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4434 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4436 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4437 PerlIOl * const l = PerlIOBase(f);
4439 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4440 * etc. get muddled when it changes mid-string when we auto-pop.
4442 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4443 (PerlIOBase(PerlIONext(f))->
4444 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4449 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4451 SSize_t avail = PerlIO_get_cnt(f);
4453 if ((SSize_t)count < avail)
4456 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4457 if (got >= 0 && got < (SSize_t)count) {
4458 const SSize_t more =
4459 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4460 if (more >= 0 || got == 0)
4466 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4467 sizeof(PerlIO_funcs),
4470 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4471 PerlIOPending_pushed,
4474 PerlIOBase_binmode, /* binmode */
4483 PerlIOPending_close,
4484 PerlIOPending_flush,
4488 PerlIOBase_clearerr,
4489 PerlIOBase_setlinebuf,
4494 PerlIOPending_set_ptrcnt,
4499 /*--------------------------------------------------------------------------------------*/
4501 * crlf - translation On read translate CR,LF to "\n" we do this by
4502 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4503 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4505 * c->nl points on the first byte of CR LF pair when it is temporarily
4506 * replaced by LF, or to the last CR of the buffer. In the former case
4507 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4508 * that it ends at c->nl; these two cases can be distinguished by
4509 * *c->nl. c->nl is set during _getcnt() call, and unset during
4510 * _unread() and _flush() calls.
4511 * It only matters for read operations.
4515 PerlIOBuf base; /* PerlIOBuf stuff */
4516 STDCHAR *nl; /* Position of crlf we "lied" about in the
4520 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4521 * Otherwise the :crlf layer would always revert back to
4525 S_inherit_utf8_flag(PerlIO *f)
4527 PerlIO *g = PerlIONext(f);
4528 if (PerlIOValid(g)) {
4529 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4530 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4536 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4539 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4540 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4542 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4543 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4544 PerlIOBase(f)->flags);
4547 /* If the old top layer is a CRLF layer, reactivate it (if
4548 * necessary) and remove this new layer from the stack */
4549 PerlIO *g = PerlIONext(f);
4550 if (PerlIOValid(g)) {
4551 PerlIOl *b = PerlIOBase(g);
4552 if (b && b->tab == &PerlIO_crlf) {
4553 if (!(b->flags & PERLIO_F_CRLF))
4554 b->flags |= PERLIO_F_CRLF;
4555 S_inherit_utf8_flag(g);
4556 PerlIO_pop(aTHX_ f);
4561 S_inherit_utf8_flag(f);
4567 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4569 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4570 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4574 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4575 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4577 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4578 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4580 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4585 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4586 b->end = b->ptr = b->buf + b->bufsiz;
4587 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4588 b->posn -= b->bufsiz;
4590 while (count > 0 && b->ptr > b->buf) {
4591 const int ch = *--buf;
4593 if (b->ptr - 2 >= b->buf) {
4600 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4601 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4617 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4619 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4621 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4624 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4625 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4626 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4627 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4629 while (nl < b->end && *nl != 0xd)
4631 if (nl < b->end && *nl == 0xd) {
4633 if (nl + 1 < b->end) {
4640 * Not CR,LF but just CR
4648 * Blast - found CR as last char in buffer
4653 * They may not care, defer work as long as
4657 return (nl - b->ptr);
4661 b->ptr++; /* say we have read it as far as
4662 * flush() is concerned */
4663 b->buf++; /* Leave space in front of buffer */
4664 /* Note as we have moved buf up flush's
4666 will naturally make posn point at CR
4668 b->bufsiz--; /* Buffer is thus smaller */
4669 code = PerlIO_fill(f); /* Fetch some more */
4670 b->bufsiz++; /* Restore size for next time */
4671 b->buf--; /* Point at space */
4672 b->ptr = nl = b->buf; /* Which is what we hand
4674 *nl = 0xd; /* Fill in the CR */
4676 goto test; /* fill() call worked */
4678 * CR at EOF - just fall through
4680 /* Should we clear EOF though ??? */
4685 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4691 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4693 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4694 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4700 if (ptr == b->end && *c->nl == 0xd) {
4701 /* Deferred CR at end of buffer case - we lied about count */
4714 * Test code - delete when it works ...
4716 IV flags = PerlIOBase(f)->flags;
4717 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4718 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4719 /* Deferred CR at end of buffer case - we lied about count */
4725 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4726 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4727 flags, c->nl, b->end, cnt);
4734 * They have taken what we lied about
4742 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4746 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4748 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4749 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4751 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4752 const STDCHAR *buf = (const STDCHAR *) vbuf;
4753 const STDCHAR * const ebuf = buf + count;
4756 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4758 while (buf < ebuf) {
4759 const STDCHAR * const eptr = b->buf + b->bufsiz;
4760 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4761 while (buf < ebuf && b->ptr < eptr) {
4763 if ((b->ptr + 2) > eptr) {
4771 *(b->ptr)++ = 0xd; /* CR */
4772 *(b->ptr)++ = 0xa; /* LF */
4774 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4781 *(b->ptr)++ = *buf++;
4783 if (b->ptr >= eptr) {
4789 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4791 return (buf - (STDCHAR *) vbuf);
4796 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4798 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4803 return PerlIOBuf_flush(aTHX_ f);
4807 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4809 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4810 /* In text mode - flush any pending stuff and flip it */
4811 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4812 #ifndef PERLIO_USING_CRLF
4813 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4814 PerlIO_pop(aTHX_ f);
4820 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4821 sizeof(PerlIO_funcs),
4824 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4826 PerlIOBuf_popped, /* popped */
4828 PerlIOCrlf_binmode, /* binmode */
4832 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4833 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4834 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4842 PerlIOBase_clearerr,
4843 PerlIOBase_setlinebuf,
4848 PerlIOCrlf_set_ptrcnt,
4852 /*--------------------------------------------------------------------------------------*/
4854 * mmap as "buffer" layer
4858 PerlIOBuf base; /* PerlIOBuf stuff */
4859 Mmap_t mptr; /* Mapped address */
4860 Size_t len; /* mapped length */
4861 STDCHAR *bbuf; /* malloced buffer if map fails */
4865 PerlIOMmap_map(pTHX_ PerlIO *f)
4868 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4869 const IV flags = PerlIOBase(f)->flags;
4873 if (flags & PERLIO_F_CANREAD) {
4874 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4875 const int fd = PerlIO_fileno(f);
4877 code = Fstat(fd, &st);
4878 if (code == 0 && S_ISREG(st.st_mode)) {
4879 SSize_t len = st.st_size - b->posn;
4882 if (PL_mmap_page_size <= 0)
4883 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4887 * This is a hack - should never happen - open should
4890 b->posn = PerlIO_tell(PerlIONext(f));
4892 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4893 len = st.st_size - posn;
4894 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4895 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4896 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4897 madvise(m->mptr, len, MADV_SEQUENTIAL);
4899 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4900 madvise(m->mptr, len, MADV_WILLNEED);
4902 PerlIOBase(f)->flags =
4903 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4904 b->end = ((STDCHAR *) m->mptr) + len;
4905 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4914 PerlIOBase(f)->flags =
4915 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4917 b->ptr = b->end = b->ptr;
4926 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4928 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4931 PerlIOBuf * const b = &m->base;
4933 /* The munmap address argument is tricky: depending on the
4934 * standard it is either "void *" or "caddr_t" (which is
4935 * usually "char *" (signed or unsigned). If we cast it
4936 * to "void *", those that have it caddr_t and an uptight
4937 * C++ compiler, will freak out. But casting it as char*
4938 * should work. Maybe. (Using Mmap_t figured out by
4939 * Configure doesn't always work, apparently.) */
4940 code = munmap((char*)m->mptr, m->len);
4944 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4947 b->ptr = b->end = b->buf;
4948 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4954 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4956 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4957 PerlIOBuf * const b = &m->base;
4958 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4960 * Already have a readbuffer in progress
4966 * We have a write buffer or flushed PerlIOBuf read buffer
4968 m->bbuf = b->buf; /* save it in case we need it again */
4969 b->buf = NULL; /* Clear to trigger below */
4972 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4975 * Map did not work - recover PerlIOBuf buffer if we have one
4980 b->ptr = b->end = b->buf;
4983 return PerlIOBuf_get_base(aTHX_ f);
4987 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4989 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4990 PerlIOBuf * const b = &m->base;
4991 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4993 if (b->ptr && (b->ptr - count) >= b->buf
4994 && memEQ(b->ptr - count, vbuf, count)) {
4996 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
5001 * Loose the unwritable mapped buffer
5005 * If flush took the "buffer" see if we have one from before
5007 if (!b->buf && m->bbuf)
5010 PerlIOBuf_get_base(aTHX_ f);
5014 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
5018 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
5020 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5021 PerlIOBuf * const b = &m->base;
5023 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
5025 * No, or wrong sort of, buffer
5028 if (PerlIOMmap_unmap(aTHX_ f) != 0)
5032 * If unmap took the "buffer" see if we have one from before
5034 if (!b->buf && m->bbuf)
5037 PerlIOBuf_get_base(aTHX_ f);
5041 return PerlIOBuf_write(aTHX_ f, vbuf, count);
5045 PerlIOMmap_flush(pTHX_ PerlIO *f)
5047 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5048 PerlIOBuf * const b = &m->base;
5049 IV code = PerlIOBuf_flush(aTHX_ f);
5051 * Now we are "synced" at PerlIOBuf level
5058 if (PerlIOMmap_unmap(aTHX_ f) != 0)
5063 * We seem to have a PerlIOBuf buffer which was not mapped
5064 * remember it in case we need one later
5073 PerlIOMmap_fill(pTHX_ PerlIO *f)
5075 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
5076 IV code = PerlIO_flush(f);
5077 if (code == 0 && !b->buf) {
5078 code = PerlIOMmap_map(aTHX_ f);
5080 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
5081 code = PerlIOBuf_fill(aTHX_ f);
5087 PerlIOMmap_close(pTHX_ PerlIO *f)
5089 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5090 PerlIOBuf * const b = &m->base;
5091 IV code = PerlIO_flush(f);
5095 b->ptr = b->end = b->buf;
5097 if (PerlIOBuf_close(aTHX_ f) != 0)
5103 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
5105 return PerlIOBase_dup(aTHX_ f, o, param, flags);
5109 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
5110 sizeof(PerlIO_funcs),
5113 PERLIO_K_BUFFERED|PERLIO_K_RAW,
5117 PerlIOBase_binmode, /* binmode */
5131 PerlIOBase_clearerr,
5132 PerlIOBase_setlinebuf,
5133 PerlIOMmap_get_base,
5137 PerlIOBuf_set_ptrcnt,
5140 #endif /* HAS_MMAP */
5143 Perl_PerlIO_stdin(pTHX)
5147 PerlIO_stdstreams(aTHX);
5149 return (PerlIO*)&PL_perlio[1];
5153 Perl_PerlIO_stdout(pTHX)
5157 PerlIO_stdstreams(aTHX);
5159 return (PerlIO*)&PL_perlio[2];
5163 Perl_PerlIO_stderr(pTHX)
5167 PerlIO_stdstreams(aTHX);
5169 return (PerlIO*)&PL_perlio[3];
5172 /*--------------------------------------------------------------------------------------*/
5175 PerlIO_getname(PerlIO *f, char *buf)
5180 bool exported = FALSE;
5181 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5183 stdio = PerlIO_exportFILE(f,0);
5187 name = fgetname(stdio, buf);
5188 if (exported) PerlIO_releaseFILE(f,stdio);
5193 PERL_UNUSED_ARG(buf);
5194 Perl_croak(aTHX_ "Don't know how to get file name");
5200 /*--------------------------------------------------------------------------------------*/
5202 * Functions which can be called on any kind of PerlIO implemented in
5206 #undef PerlIO_fdopen
5208 PerlIO_fdopen(int fd, const char *mode)
5211 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5216 PerlIO_open(const char *path, const char *mode)
5219 SV *name = sv_2mortal(newSVpv(path, 0));
5220 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5223 #undef Perlio_reopen
5225 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5228 SV *name = sv_2mortal(newSVpv(path,0));
5229 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5234 PerlIO_getc(PerlIO *f)
5238 if ( 1 == PerlIO_read(f, buf, 1) ) {
5239 return (unsigned char) buf[0];
5244 #undef PerlIO_ungetc
5246 PerlIO_ungetc(PerlIO *f, int ch)
5251 if (PerlIO_unread(f, &buf, 1) == 1)
5259 PerlIO_putc(PerlIO *f, int ch)
5263 return PerlIO_write(f, &buf, 1);
5268 PerlIO_puts(PerlIO *f, const char *s)
5271 return PerlIO_write(f, s, strlen(s));
5274 #undef PerlIO_rewind
5276 PerlIO_rewind(PerlIO *f)
5279 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5283 #undef PerlIO_vprintf
5285 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5294 Perl_va_copy(ap, apc);
5295 sv = vnewSVpvf(fmt, &apc);
5297 sv = vnewSVpvf(fmt, &ap);
5299 s = SvPV_const(sv, len);
5300 wrote = PerlIO_write(f, s, len);
5305 #undef PerlIO_printf
5307 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5312 result = PerlIO_vprintf(f, fmt, ap);
5317 #undef PerlIO_stdoutf
5319 PerlIO_stdoutf(const char *fmt, ...)
5325 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5330 #undef PerlIO_tmpfile
5332 PerlIO_tmpfile(void)
5337 const int fd = win32_tmpfd();
5339 f = PerlIO_fdopen(fd, "w+b");
5341 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5343 char tempname[] = "/tmp/PerlIO_XXXXXX";
5344 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5347 * I have no idea how portable mkstemp() is ... NI-S
5349 if (tmpdir && *tmpdir) {
5350 /* if TMPDIR is set and not empty, we try that first */
5351 sv = newSVpv(tmpdir, 0);
5352 sv_catpv(sv, tempname + 4);
5353 fd = mkstemp(SvPVX(sv));
5357 /* else we try /tmp */
5358 fd = mkstemp(tempname);
5361 f = PerlIO_fdopen(fd, "w+");
5363 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5364 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5367 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5368 FILE * const stdio = PerlSIO_tmpfile();
5371 f = PerlIO_fdopen(fileno(stdio), "w+");
5373 # endif /* else HAS_MKSTEMP */
5374 #endif /* else WIN32 */
5381 #endif /* USE_SFIO */
5382 #endif /* PERLIO_IS_STDIO */
5384 /*======================================================================================*/
5386 * Now some functions in terms of above which may be needed even if we are
5387 * not in true PerlIO mode
5390 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5393 const char *direction = NULL;
5396 * Need to supply default layer info from open.pm
5402 if (mode && mode[0] != 'r') {
5403 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5404 direction = "open>";
5406 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5407 direction = "open<";
5412 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5415 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5420 #undef PerlIO_setpos
5422 PerlIO_setpos(PerlIO *f, SV *pos)
5427 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5428 if (f && len == sizeof(Off_t))
5429 return PerlIO_seek(f, *posn, SEEK_SET);
5431 SETERRNO(EINVAL, SS_IVCHAN);
5435 #undef PerlIO_setpos
5437 PerlIO_setpos(PerlIO *f, SV *pos)
5442 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5443 if (f && len == sizeof(Fpos_t)) {
5444 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5445 return fsetpos64(f, fpos);
5447 return fsetpos(f, fpos);
5451 SETERRNO(EINVAL, SS_IVCHAN);
5457 #undef PerlIO_getpos
5459 PerlIO_getpos(PerlIO *f, SV *pos)
5462 Off_t posn = PerlIO_tell(f);
5463 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5464 return (posn == (Off_t) - 1) ? -1 : 0;
5467 #undef PerlIO_getpos
5469 PerlIO_getpos(PerlIO *f, SV *pos)
5474 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5475 code = fgetpos64(f, &fpos);
5477 code = fgetpos(f, &fpos);
5479 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5484 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5487 vprintf(char *pat, char *args)
5489 _doprnt(pat, args, stdout);
5490 return 0; /* wrong, but perl doesn't use the return
5495 vfprintf(FILE *fd, char *pat, char *args)
5497 _doprnt(pat, args, fd);
5498 return 0; /* wrong, but perl doesn't use the return
5504 #ifndef PerlIO_vsprintf
5506 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5509 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5510 PERL_UNUSED_CONTEXT;
5512 #ifndef PERL_MY_VSNPRINTF_GUARDED
5513 if (val < 0 || (n > 0 ? val >= n : 0)) {
5514 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5521 #ifndef PerlIO_sprintf
5523 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5528 result = PerlIO_vsprintf(s, n, fmt, ap);
5536 * c-indentation-style: bsd
5538 * indent-tabs-mode: t
5541 * ex: set ts=8 sts=4 sw=4 noet: