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 (%d) does not match %s (%d)",
1271 "PerlIO layer function table size", tab->fsize,
1272 "size expected by this perl", sizeof(PerlIO_funcs) );
1276 if (tab->size < sizeof(PerlIOl)) {
1278 "%s (%d) smaller than %s (%d)",
1279 "PerlIO layer instance size", tab->size,
1280 "size expected by this perl", 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,
1986 NULL, /* get_base */
1987 NULL, /* get_bufsiz */
1990 NULL, /* set_ptrcnt */
1993 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1994 sizeof(PerlIO_funcs),
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 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2416 fd, PL_perlio_fd_refcnt[fd]);
2418 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2419 fd, PL_perlio_fd_refcnt[fd]);
2422 MUTEX_UNLOCK(&PL_perlio_mutex);
2425 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2430 PerlIOUnix_refcnt_dec(int fd)
2437 MUTEX_LOCK(&PL_perlio_mutex);
2439 if (fd >= PL_perlio_fd_refcnt_size) {
2440 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2441 fd, PL_perlio_fd_refcnt_size);
2443 if (PL_perlio_fd_refcnt[fd] <= 0) {
2444 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2445 fd, PL_perlio_fd_refcnt[fd]);
2447 cnt = --PL_perlio_fd_refcnt[fd];
2448 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2450 MUTEX_UNLOCK(&PL_perlio_mutex);
2453 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2459 PerlIO_cleanup(pTHX)
2464 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2466 PerlIO_debug("Cleanup layers\n");
2469 /* Raise STDIN..STDERR refcount so we don't close them */
2470 for (i=0; i < 3; i++)
2471 PerlIOUnix_refcnt_inc(i);
2472 PerlIO_cleantable(aTHX_ &PL_perlio);
2473 /* Restore STDIN..STDERR refcount */
2474 for (i=0; i < 3; i++)
2475 PerlIOUnix_refcnt_dec(i);
2477 if (PL_known_layers) {
2478 PerlIO_list_free(aTHX_ PL_known_layers);
2479 PL_known_layers = NULL;
2481 if (PL_def_layerlist) {
2482 PerlIO_list_free(aTHX_ PL_def_layerlist);
2483 PL_def_layerlist = NULL;
2487 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2491 /* XXX we can't rely on an interpreter being present at this late stage,
2492 XXX so we can't use a function like PerlLIO_write that relies on one
2493 being present (at least in win32) :-(.
2498 /* By now all filehandles should have been closed, so any
2499 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2501 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2502 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2503 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2505 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2506 if (PL_perlio_fd_refcnt[i]) {
2508 my_snprintf(buf, sizeof(buf),
2509 "PerlIO_teardown: fd %d refcnt=%d\n",
2510 i, PL_perlio_fd_refcnt[i]);
2511 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2517 /* Not bothering with PL_perlio_mutex since by now
2518 * all the interpreters are gone. */
2519 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2520 && PL_perlio_fd_refcnt) {
2521 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2522 PL_perlio_fd_refcnt = NULL;
2523 PL_perlio_fd_refcnt_size = 0;
2527 /*--------------------------------------------------------------------------------------*/
2529 * Bottom-most level for UNIX-like case
2533 struct _PerlIO base; /* The generic part */
2534 int fd; /* UNIX like file descriptor */
2535 int oflags; /* open/fcntl flags */
2539 S_lockcnt_dec(pTHX_ const void* f)
2541 PerlIO_lockcnt((PerlIO*)f)--;
2545 /* call the signal handler, and if that handler happens to clear
2546 * this handle, free what we can and return true */
2549 S_perlio_async_run(pTHX_ PerlIO* f) {
2551 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2552 PerlIO_lockcnt(f)++;
2554 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2556 /* we've just run some perl-level code that could have done
2557 * anything, including closing the file or clearing this layer.
2558 * If so, free any lower layers that have already been
2559 * cleared, then return an error. */
2560 while (PerlIOValid(f) &&
2561 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2563 const PerlIOl *l = *f;
2571 PerlIOUnix_oflags(const char *mode)
2574 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2579 if (*++mode == '+') {
2586 oflags = O_CREAT | O_TRUNC;
2587 if (*++mode == '+') {
2596 oflags = O_CREAT | O_APPEND;
2597 if (*++mode == '+') {
2610 else if (*mode == 't') {
2612 oflags &= ~O_BINARY;
2616 * Always open in binary mode
2619 if (*mode || oflags == -1) {
2620 SETERRNO(EINVAL, LIB_INVARG);
2627 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2629 PERL_UNUSED_CONTEXT;
2630 return PerlIOSelf(f, PerlIOUnix)->fd;
2634 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2636 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2639 if (PerlLIO_fstat(fd, &st) == 0) {
2640 if (!S_ISREG(st.st_mode)) {
2641 PerlIO_debug("%d is not regular file\n",fd);
2642 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2645 PerlIO_debug("%d _is_ a regular file\n",fd);
2651 PerlIOUnix_refcnt_inc(fd);
2652 PERL_UNUSED_CONTEXT;
2656 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2658 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2659 if (*PerlIONext(f)) {
2660 /* We never call down so do any pending stuff now */
2661 PerlIO_flush(PerlIONext(f));
2663 * XXX could (or should) we retrieve the oflags from the open file
2664 * handle rather than believing the "mode" we are passed in? XXX
2665 * Should the value on NULL mode be 0 or -1?
2667 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2668 mode ? PerlIOUnix_oflags(mode) : -1);
2670 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2676 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2678 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2680 PERL_UNUSED_CONTEXT;
2681 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2683 SETERRNO(ESPIPE, LIB_INVARG);
2685 SETERRNO(EINVAL, LIB_INVARG);
2689 new_loc = PerlLIO_lseek(fd, offset, whence);
2690 if (new_loc == (Off_t) - 1)
2692 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2697 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2698 IV n, const char *mode, int fd, int imode,
2699 int perm, PerlIO *f, int narg, SV **args)
2701 if (PerlIOValid(f)) {
2702 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2703 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2706 if (*mode == IoTYPE_NUMERIC)
2709 imode = PerlIOUnix_oflags(mode);
2711 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2717 const char *path = SvPV_nolen_const(*args);
2718 fd = PerlLIO_open3(path, imode, perm);
2722 if (*mode == IoTYPE_IMPLICIT)
2725 f = PerlIO_allocate(aTHX);
2727 if (!PerlIOValid(f)) {
2728 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2732 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2733 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2734 if (*mode == IoTYPE_APPEND)
2735 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2742 * FIXME: pop layers ???
2750 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2752 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2754 if (flags & PERLIO_DUP_FD) {
2755 fd = PerlLIO_dup(fd);
2758 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2760 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2761 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2770 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2774 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2776 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2777 #ifdef PERLIO_STD_SPECIAL
2779 return PERLIO_STD_IN(fd, vbuf, count);
2781 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2782 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2786 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2787 if (len >= 0 || errno != EINTR) {
2789 if (errno != EAGAIN) {
2790 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2793 else if (len == 0 && count != 0) {
2794 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2800 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2807 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2811 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2813 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2814 #ifdef PERLIO_STD_SPECIAL
2815 if (fd == 1 || fd == 2)
2816 return PERLIO_STD_OUT(fd, vbuf, count);
2819 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2820 if (len >= 0 || errno != EINTR) {
2822 if (errno != EAGAIN) {
2823 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2829 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2836 PerlIOUnix_tell(pTHX_ PerlIO *f)
2838 PERL_UNUSED_CONTEXT;
2840 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2845 PerlIOUnix_close(pTHX_ PerlIO *f)
2848 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2850 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2851 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2852 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2857 SETERRNO(EBADF,SS_IVCHAN);
2860 while (PerlLIO_close(fd) != 0) {
2861 if (errno != EINTR) {
2866 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2870 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2875 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2876 sizeof(PerlIO_funcs),
2883 PerlIOBase_binmode, /* binmode */
2893 PerlIOBase_noop_ok, /* flush */
2894 PerlIOBase_noop_fail, /* fill */
2897 PerlIOBase_clearerr,
2898 PerlIOBase_setlinebuf,
2899 NULL, /* get_base */
2900 NULL, /* get_bufsiz */
2903 NULL, /* set_ptrcnt */
2906 /*--------------------------------------------------------------------------------------*/
2911 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2912 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2913 broken by the last second glibc 2.3 fix
2915 #define STDIO_BUFFER_WRITABLE
2920 struct _PerlIO base;
2921 FILE *stdio; /* The stream */
2925 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2927 PERL_UNUSED_CONTEXT;
2929 if (PerlIOValid(f)) {
2930 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2932 return PerlSIO_fileno(s);
2939 PerlIOStdio_mode(const char *mode, char *tmode)
2941 char * const ret = tmode;
2947 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2955 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2958 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2959 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2960 if (toptab == tab) {
2961 /* Top is already stdio - pop self (duplicate) and use original */
2962 PerlIO_pop(aTHX_ f);
2965 const int fd = PerlIO_fileno(n);
2968 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2969 mode = PerlIOStdio_mode(mode, tmode)))) {
2970 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2971 /* We never call down so do any pending stuff now */
2972 PerlIO_flush(PerlIONext(f));
2979 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2984 PerlIO_importFILE(FILE *stdio, const char *mode)
2990 if (!mode || !*mode) {
2991 /* We need to probe to see how we can open the stream
2992 so start with read/write and then try write and read
2993 we dup() so that we can fclose without loosing the fd.
2995 Note that the errno value set by a failing fdopen
2996 varies between stdio implementations.
2998 const int fd = PerlLIO_dup(fileno(stdio));
2999 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3001 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3004 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3007 /* Don't seem to be able to open */
3013 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3014 s = PerlIOSelf(f, PerlIOStdio);
3016 PerlIOUnix_refcnt_inc(fileno(stdio));
3023 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3024 IV n, const char *mode, int fd, int imode,
3025 int perm, PerlIO *f, int narg, SV **args)
3028 if (PerlIOValid(f)) {
3029 const char * const path = SvPV_nolen_const(*args);
3030 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3032 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3033 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3038 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3043 const char * const path = SvPV_nolen_const(*args);
3044 if (*mode == IoTYPE_NUMERIC) {
3046 fd = PerlLIO_open3(path, imode, perm);
3050 bool appended = FALSE;
3052 /* Cygwin wants its 'b' early. */
3054 mode = PerlIOStdio_mode(mode, tmode);
3056 stdio = PerlSIO_fopen(path, mode);
3059 f = PerlIO_allocate(aTHX);
3062 mode = PerlIOStdio_mode(mode, tmode);
3063 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3065 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3066 PerlIOUnix_refcnt_inc(fileno(stdio));
3068 PerlSIO_fclose(stdio);
3080 if (*mode == IoTYPE_IMPLICIT) {
3087 stdio = PerlSIO_stdin;
3090 stdio = PerlSIO_stdout;
3093 stdio = PerlSIO_stderr;
3098 stdio = PerlSIO_fdopen(fd, mode =
3099 PerlIOStdio_mode(mode, tmode));
3103 f = PerlIO_allocate(aTHX);
3105 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3106 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3107 PerlIOUnix_refcnt_inc(fileno(stdio));
3117 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3119 /* This assumes no layers underneath - which is what
3120 happens, but is not how I remember it. NI-S 2001/10/16
3122 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3123 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3124 const int fd = fileno(stdio);
3126 if (flags & PERLIO_DUP_FD) {
3127 const int dfd = PerlLIO_dup(fileno(stdio));
3129 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3134 /* FIXME: To avoid messy error recovery if dup fails
3135 re-use the existing stdio as though flag was not set
3139 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3141 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3143 PerlIOUnix_refcnt_inc(fileno(stdio));
3150 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3152 PERL_UNUSED_CONTEXT;
3154 /* XXX this could use PerlIO_canset_fileno() and
3155 * PerlIO_set_fileno() support from Configure
3157 # if defined(__UCLIBC__)
3158 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3161 # elif defined(__GLIBC__)
3162 /* There may be a better way for GLIBC:
3163 - libio.h defines a flag to not close() on cleanup
3167 # elif defined(__sun__)
3170 # elif defined(__hpux)
3174 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3175 your platform does not have special entry try this one.
3176 [For OSF only have confirmation for Tru64 (alpha)
3177 but assume other OSFs will be similar.]
3179 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3182 # elif defined(__FreeBSD__)
3183 /* There may be a better way on FreeBSD:
3184 - we could insert a dummy func in the _close function entry
3185 f->_close = (int (*)(void *)) dummy_close;
3189 # elif defined(__OpenBSD__)
3190 /* There may be a better way on OpenBSD:
3191 - we could insert a dummy func in the _close function entry
3192 f->_close = (int (*)(void *)) dummy_close;
3196 # elif defined(__EMX__)
3197 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3200 # elif defined(__CYGWIN__)
3201 /* There may be a better way on CYGWIN:
3202 - we could insert a dummy func in the _close function entry
3203 f->_close = (int (*)(void *)) dummy_close;
3207 # elif defined(WIN32)
3208 # if defined(__BORLANDC__)
3209 f->fd = PerlLIO_dup(fileno(f));
3210 # elif defined(UNDER_CE)
3211 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3220 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3221 (which isn't thread safe) instead
3223 # error "Don't know how to set FILE.fileno on your platform"
3231 PerlIOStdio_close(pTHX_ PerlIO *f)
3233 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3239 const int fd = fileno(stdio);
3247 #ifdef SOCKS5_VERSION_NAME
3248 /* Socks lib overrides close() but stdio isn't linked to
3249 that library (though we are) - so we must call close()
3250 on sockets on stdio's behalf.
3253 Sock_size_t optlen = sizeof(int);
3254 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3257 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3258 that a subsequent fileno() on it returns -1. Don't want to croak()
3259 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3260 trying to close an already closed handle which somehow it still has
3261 a reference to. (via.xs, I'm looking at you). */
3262 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3263 /* File descriptor still in use */
3267 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3268 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3270 if (stdio == stdout || stdio == stderr)
3271 return PerlIO_flush(f);
3272 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3273 Use Sarathy's trick from maint-5.6 to invalidate the
3274 fileno slot of the FILE *
3276 result = PerlIO_flush(f);
3278 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3281 MUTEX_LOCK(&PL_perlio_mutex);
3282 /* Right. We need a mutex here because for a brief while we
3283 will have the situation that fd is actually closed. Hence if
3284 a second thread were to get into this block, its dup() would
3285 likely return our fd as its dupfd. (after all, it is closed)
3286 Then if we get to the dup2() first, we blat the fd back
3287 (messing up its temporary as a side effect) only for it to
3288 then close its dupfd (== our fd) in its close(dupfd) */
3290 /* There is, of course, a race condition, that any other thread
3291 trying to input/output/whatever on this fd will be stuffed
3292 for the duration of this little manoeuvrer. Perhaps we
3293 should hold an IO mutex for the duration of every IO
3294 operation if we know that invalidate doesn't work on this
3295 platform, but that would suck, and could kill performance.
3297 Except that correctness trumps speed.
3298 Advice from klortho #11912. */
3300 dupfd = PerlLIO_dup(fd);
3303 MUTEX_UNLOCK(&PL_perlio_mutex);
3304 /* Oh cXap. This isn't going to go well. Not sure if we can
3305 recover from here, or if closing this particular FILE *
3306 is a good idea now. */
3311 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3313 result = PerlSIO_fclose(stdio);
3314 /* We treat error from stdio as success if we invalidated
3315 errno may NOT be expected EBADF
3317 if (invalidate && result != 0) {
3321 #ifdef SOCKS5_VERSION_NAME
3322 /* in SOCKS' case, let close() determine return value */
3326 PerlLIO_dup2(dupfd,fd);
3327 PerlLIO_close(dupfd);
3329 MUTEX_UNLOCK(&PL_perlio_mutex);
3337 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3342 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3344 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3347 STDCHAR *buf = (STDCHAR *) vbuf;
3349 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3350 * stdio does not do that for fread()
3352 const int ch = PerlSIO_fgetc(s);
3359 got = PerlSIO_fread(vbuf, 1, count, s);
3360 if (got == 0 && PerlSIO_ferror(s))
3362 if (got >= 0 || errno != EINTR)
3364 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3366 SETERRNO(0,0); /* just in case */
3372 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3375 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3377 #ifdef STDIO_BUFFER_WRITABLE
3378 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3379 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3380 STDCHAR *base = PerlIO_get_base(f);
3381 SSize_t cnt = PerlIO_get_cnt(f);
3382 STDCHAR *ptr = PerlIO_get_ptr(f);
3383 SSize_t avail = ptr - base;
3385 if (avail > count) {
3389 Move(buf-avail,ptr,avail,STDCHAR);
3392 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3393 if (PerlSIO_feof(s) && unread >= 0)
3394 PerlSIO_clearerr(s);
3399 if (PerlIO_has_cntptr(f)) {
3400 /* We can get pointer to buffer but not its base
3401 Do ungetc() but check chars are ending up in the
3404 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3405 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3407 const int ch = *--buf & 0xFF;
3408 if (ungetc(ch,s) != ch) {
3409 /* ungetc did not work */
3412 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3413 /* Did not change pointer as expected */
3414 fgetc(s); /* get char back again */
3424 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3430 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3434 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3437 got = PerlSIO_fwrite(vbuf, 1, count,
3438 PerlIOSelf(f, PerlIOStdio)->stdio);
3439 if (got >= 0 || errno != EINTR)
3441 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3443 SETERRNO(0,0); /* just in case */
3449 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3451 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3452 PERL_UNUSED_CONTEXT;
3454 return PerlSIO_fseek(stdio, offset, whence);
3458 PerlIOStdio_tell(pTHX_ PerlIO *f)
3460 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3461 PERL_UNUSED_CONTEXT;
3463 return PerlSIO_ftell(stdio);
3467 PerlIOStdio_flush(pTHX_ PerlIO *f)
3469 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3470 PERL_UNUSED_CONTEXT;
3472 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3473 return PerlSIO_fflush(stdio);
3479 * FIXME: This discards ungetc() and pre-read stuff which is not
3480 * right if this is just a "sync" from a layer above Suspect right
3481 * design is to do _this_ but not have layer above flush this
3482 * layer read-to-read
3485 * Not writeable - sync by attempting a seek
3488 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3496 PerlIOStdio_eof(pTHX_ PerlIO *f)
3498 PERL_UNUSED_CONTEXT;
3500 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3504 PerlIOStdio_error(pTHX_ PerlIO *f)
3506 PERL_UNUSED_CONTEXT;
3508 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3512 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3514 PERL_UNUSED_CONTEXT;
3516 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3520 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3522 PERL_UNUSED_CONTEXT;
3524 #ifdef HAS_SETLINEBUF
3525 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3527 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3533 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3535 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3536 return (STDCHAR*)PerlSIO_get_base(stdio);
3540 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3542 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3543 return PerlSIO_get_bufsiz(stdio);
3547 #ifdef USE_STDIO_PTR
3549 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3551 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3552 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3556 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3558 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3559 return PerlSIO_get_cnt(stdio);
3563 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3565 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3567 #ifdef STDIO_PTR_LVALUE
3568 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3569 #ifdef STDIO_PTR_LVAL_SETS_CNT
3570 assert(PerlSIO_get_cnt(stdio) == (cnt));
3572 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3574 * Setting ptr _does_ change cnt - we are done
3578 #else /* STDIO_PTR_LVALUE */
3580 #endif /* STDIO_PTR_LVALUE */
3583 * Now (or only) set cnt
3585 #ifdef STDIO_CNT_LVALUE
3586 PerlSIO_set_cnt(stdio, cnt);
3587 #else /* STDIO_CNT_LVALUE */
3588 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3589 PerlSIO_set_ptr(stdio,
3590 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3592 #else /* STDIO_PTR_LVAL_SETS_CNT */
3594 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3595 #endif /* STDIO_CNT_LVALUE */
3602 PerlIOStdio_fill(pTHX_ PerlIO *f)
3606 PERL_UNUSED_CONTEXT;
3607 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3609 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3612 * fflush()ing read-only streams can cause trouble on some stdio-s
3614 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3615 if (PerlSIO_fflush(stdio) != 0)
3619 c = PerlSIO_fgetc(stdio);
3622 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3624 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3629 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3631 #ifdef STDIO_BUFFER_WRITABLE
3632 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3633 /* Fake ungetc() to the real buffer in case system's ungetc
3636 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3637 SSize_t cnt = PerlSIO_get_cnt(stdio);
3638 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3639 if (ptr == base+1) {
3640 *--ptr = (STDCHAR) c;
3641 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3642 if (PerlSIO_feof(stdio))
3643 PerlSIO_clearerr(stdio);
3649 if (PerlIO_has_cntptr(f)) {
3651 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3658 /* An ungetc()d char is handled separately from the regular
3659 * buffer, so we stuff it in the buffer ourselves.
3660 * Should never get called as should hit code above
3662 *(--((*stdio)->_ptr)) = (unsigned char) c;
3665 /* If buffer snoop scheme above fails fall back to
3668 if (PerlSIO_ungetc(c, stdio) != c)
3676 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3677 sizeof(PerlIO_funcs),
3679 sizeof(PerlIOStdio),
3680 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3684 PerlIOBase_binmode, /* binmode */
3698 PerlIOStdio_clearerr,
3699 PerlIOStdio_setlinebuf,
3701 PerlIOStdio_get_base,
3702 PerlIOStdio_get_bufsiz,
3707 #ifdef USE_STDIO_PTR
3708 PerlIOStdio_get_ptr,
3709 PerlIOStdio_get_cnt,
3710 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3711 PerlIOStdio_set_ptrcnt,
3714 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3719 #endif /* USE_STDIO_PTR */
3722 /* Note that calls to PerlIO_exportFILE() are reversed using
3723 * PerlIO_releaseFILE(), not importFILE. */
3725 PerlIO_exportFILE(PerlIO * f, const char *mode)
3729 if (PerlIOValid(f)) {
3732 if (!mode || !*mode) {
3733 mode = PerlIO_modestr(f, buf);
3735 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3739 /* De-link any lower layers so new :stdio sticks */
3741 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3742 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3744 PerlIOUnix_refcnt_inc(fileno(stdio));
3745 /* Link previous lower layers under new one */
3749 /* restore layers list */
3759 PerlIO_findFILE(PerlIO *f)
3764 if (l->tab == &PerlIO_stdio) {
3765 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3768 l = *PerlIONext(&l);
3770 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3771 /* However, we're not really exporting a FILE * to someone else (who
3772 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3773 So we need to undo its reference count increase on the underlying file
3774 descriptor. We have to do this, because if the loop above returns you
3775 the FILE *, then *it* didn't increase any reference count. So there's
3776 only one way to be consistent. */
3777 stdio = PerlIO_exportFILE(f, NULL);
3779 const int fd = fileno(stdio);
3781 PerlIOUnix_refcnt_dec(fd);
3786 /* Use this to reverse PerlIO_exportFILE calls. */
3788 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3793 if (l->tab == &PerlIO_stdio) {
3794 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3795 if (s->stdio == f) {
3797 const int fd = fileno(f);
3799 PerlIOUnix_refcnt_dec(fd);
3800 PerlIO_pop(aTHX_ p);
3809 /*--------------------------------------------------------------------------------------*/
3811 * perlio buffer layer
3815 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3817 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3818 const int fd = PerlIO_fileno(f);
3819 if (fd >= 0 && PerlLIO_isatty(fd)) {
3820 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3822 if (*PerlIONext(f)) {
3823 const Off_t posn = PerlIO_tell(PerlIONext(f));
3824 if (posn != (Off_t) - 1) {
3828 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3832 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3833 IV n, const char *mode, int fd, int imode, int perm,
3834 PerlIO *f, int narg, SV **args)
3836 if (PerlIOValid(f)) {
3837 PerlIO *next = PerlIONext(f);
3839 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3840 if (tab && tab->Open)
3842 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3844 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3849 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3851 if (*mode == IoTYPE_IMPLICIT) {
3857 if (tab && tab->Open)
3858 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3861 SETERRNO(EINVAL, LIB_INVARG);
3863 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3865 * if push fails during open, open fails. close will pop us.
3870 fd = PerlIO_fileno(f);
3871 if (init && fd == 2) {
3873 * Initial stderr is unbuffered
3875 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3877 #ifdef PERLIO_USING_CRLF
3878 # ifdef PERLIO_IS_BINMODE_FD
3879 if (PERLIO_IS_BINMODE_FD(fd))
3880 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3884 * do something about failing setmode()? --jhi
3886 PerlLIO_setmode(fd, O_BINARY);
3890 /* Enable line buffering with record-oriented regular files
3891 * so we don't introduce an extraneous record boundary when
3892 * the buffer fills up.
3894 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3896 if (PerlLIO_fstat(fd, &st) == 0
3897 && S_ISREG(st.st_mode)
3898 && (st.st_fab_rfm == FAB$C_VAR
3899 || st.st_fab_rfm == FAB$C_VFC)) {
3900 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3911 * This "flush" is akin to sfio's sync in that it handles files in either
3912 * read or write state. For write state, we put the postponed data through
3913 * the next layers. For read state, we seek() the next layers to the
3914 * offset given by current position in the buffer, and discard the buffer
3915 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3916 * in any case?). Then the pass the stick further in chain.
3919 PerlIOBuf_flush(pTHX_ PerlIO *f)
3921 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3923 PerlIO *n = PerlIONext(f);
3924 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3926 * write() the buffer
3928 const STDCHAR *buf = b->buf;
3929 const STDCHAR *p = buf;
3930 while (p < b->ptr) {
3931 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3935 else if (count < 0 || PerlIO_error(n)) {
3936 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3941 b->posn += (p - buf);
3943 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3944 STDCHAR *buf = PerlIO_get_base(f);
3946 * Note position change
3948 b->posn += (b->ptr - buf);
3949 if (b->ptr < b->end) {
3950 /* We did not consume all of it - try and seek downstream to
3951 our logical position
3953 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3954 /* Reload n as some layers may pop themselves on seek */
3955 b->posn = PerlIO_tell(n = PerlIONext(f));
3958 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3959 data is lost for good - so return saying "ok" having undone
3962 b->posn -= (b->ptr - buf);
3967 b->ptr = b->end = b->buf;
3968 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3969 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3970 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3975 /* This discards the content of the buffer after b->ptr, and rereads
3976 * the buffer from the position off in the layer downstream; here off
3977 * is at offset corresponding to b->ptr - b->buf.
3980 PerlIOBuf_fill(pTHX_ PerlIO *f)
3982 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3983 PerlIO *n = PerlIONext(f);
3986 * Down-stream flush is defined not to loose read data so is harmless.
3987 * we would not normally be fill'ing if there was data left in anycase.
3989 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3991 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3992 PerlIOBase_flush_linebuf(aTHX);
3995 PerlIO_get_base(f); /* allocate via vtable */
3997 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3999 b->ptr = b->end = b->buf;
4001 if (!PerlIOValid(n)) {
4002 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4006 if (PerlIO_fast_gets(n)) {
4008 * Layer below is also buffered. We do _NOT_ want to call its
4009 * ->Read() because that will loop till it gets what we asked for
4010 * which may hang on a pipe etc. Instead take anything it has to
4011 * hand, or ask it to fill _once_.
4013 avail = PerlIO_get_cnt(n);
4015 avail = PerlIO_fill(n);
4017 avail = PerlIO_get_cnt(n);
4019 if (!PerlIO_error(n) && PerlIO_eof(n))
4024 STDCHAR *ptr = PerlIO_get_ptr(n);
4025 const SSize_t cnt = avail;
4026 if (avail > (SSize_t)b->bufsiz)
4028 Copy(ptr, b->buf, avail, STDCHAR);
4029 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4033 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4037 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4039 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4042 b->end = b->buf + avail;
4043 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4048 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4050 if (PerlIOValid(f)) {
4051 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4054 return PerlIOBase_read(aTHX_ f, vbuf, count);
4060 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4062 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4063 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4066 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4071 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4073 * Buffer is already a read buffer, we can overwrite any chars
4074 * which have been read back to buffer start
4076 avail = (b->ptr - b->buf);
4080 * Buffer is idle, set it up so whole buffer is available for
4084 b->end = b->buf + avail;
4086 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4088 * Buffer extends _back_ from where we are now
4090 b->posn -= b->bufsiz;
4092 if (avail > (SSize_t) count) {
4094 * If we have space for more than count, just move count
4102 * In simple stdio-like ungetc() case chars will be already
4105 if (buf != b->ptr) {
4106 Copy(buf, b->ptr, avail, STDCHAR);
4110 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4114 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4120 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4122 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4123 const STDCHAR *buf = (const STDCHAR *) vbuf;
4124 const STDCHAR *flushptr = buf;
4128 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4130 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4131 if (PerlIO_flush(f) != 0) {
4135 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4136 flushptr = buf + count;
4137 while (flushptr > buf && *(flushptr - 1) != '\n')
4141 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4142 if ((SSize_t) count < avail)
4144 if (flushptr > buf && flushptr <= buf + avail)
4145 avail = flushptr - buf;
4146 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4148 Copy(buf, b->ptr, avail, STDCHAR);
4153 if (buf == flushptr)
4156 if (b->ptr >= (b->buf + b->bufsiz))
4157 if (PerlIO_flush(f) == -1)
4160 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4166 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4169 if ((code = PerlIO_flush(f)) == 0) {
4170 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4171 code = PerlIO_seek(PerlIONext(f), offset, whence);
4173 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4174 b->posn = PerlIO_tell(PerlIONext(f));
4181 PerlIOBuf_tell(pTHX_ PerlIO *f)
4183 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4185 * b->posn is file position where b->buf was read, or will be written
4187 Off_t posn = b->posn;
4188 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4189 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4191 /* As O_APPEND files are normally shared in some sense it is better
4196 /* when file is NOT shared then this is sufficient */
4197 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4199 posn = b->posn = PerlIO_tell(PerlIONext(f));
4203 * If buffer is valid adjust position by amount in buffer
4205 posn += (b->ptr - b->buf);
4211 PerlIOBuf_popped(pTHX_ PerlIO *f)
4213 const IV code = PerlIOBase_popped(aTHX_ f);
4214 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4215 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4218 b->ptr = b->end = b->buf = NULL;
4219 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4224 PerlIOBuf_close(pTHX_ PerlIO *f)
4226 const IV code = PerlIOBase_close(aTHX_ f);
4227 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4228 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4231 b->ptr = b->end = b->buf = NULL;
4232 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4237 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4239 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4246 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4248 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4251 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4252 return (b->end - b->ptr);
4257 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4259 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4260 PERL_UNUSED_CONTEXT;
4264 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4265 Newxz(b->buf,b->bufsiz, STDCHAR);
4267 b->buf = (STDCHAR *) & b->oneword;
4268 b->bufsiz = sizeof(b->oneword);
4270 b->end = b->ptr = b->buf;
4276 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4278 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4281 return (b->end - b->buf);
4285 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4287 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4289 PERL_UNUSED_ARG(cnt);
4294 assert(PerlIO_get_cnt(f) == cnt);
4295 assert(b->ptr >= b->buf);
4296 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4300 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4302 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4307 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4308 sizeof(PerlIO_funcs),
4311 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4315 PerlIOBase_binmode, /* binmode */
4329 PerlIOBase_clearerr,
4330 PerlIOBase_setlinebuf,
4335 PerlIOBuf_set_ptrcnt,
4338 /*--------------------------------------------------------------------------------------*/
4340 * Temp layer to hold unread chars when cannot do it any other way
4344 PerlIOPending_fill(pTHX_ PerlIO *f)
4347 * Should never happen
4354 PerlIOPending_close(pTHX_ PerlIO *f)
4357 * A tad tricky - flush pops us, then we close new top
4360 return PerlIO_close(f);
4364 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4367 * A tad tricky - flush pops us, then we seek new top
4370 return PerlIO_seek(f, offset, whence);
4375 PerlIOPending_flush(pTHX_ PerlIO *f)
4377 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4378 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4382 PerlIO_pop(aTHX_ f);
4387 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4393 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4398 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4400 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4401 PerlIOl * const l = PerlIOBase(f);
4403 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4404 * etc. get muddled when it changes mid-string when we auto-pop.
4406 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4407 (PerlIOBase(PerlIONext(f))->
4408 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4413 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4415 SSize_t avail = PerlIO_get_cnt(f);
4417 if ((SSize_t)count < avail)
4420 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4421 if (got >= 0 && got < (SSize_t)count) {
4422 const SSize_t more =
4423 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4424 if (more >= 0 || got == 0)
4430 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4431 sizeof(PerlIO_funcs),
4434 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4435 PerlIOPending_pushed,
4438 PerlIOBase_binmode, /* binmode */
4447 PerlIOPending_close,
4448 PerlIOPending_flush,
4452 PerlIOBase_clearerr,
4453 PerlIOBase_setlinebuf,
4458 PerlIOPending_set_ptrcnt,
4463 /*--------------------------------------------------------------------------------------*/
4465 * crlf - translation On read translate CR,LF to "\n" we do this by
4466 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4467 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4469 * c->nl points on the first byte of CR LF pair when it is temporarily
4470 * replaced by LF, or to the last CR of the buffer. In the former case
4471 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4472 * that it ends at c->nl; these two cases can be distinguished by
4473 * *c->nl. c->nl is set during _getcnt() call, and unset during
4474 * _unread() and _flush() calls.
4475 * It only matters for read operations.
4479 PerlIOBuf base; /* PerlIOBuf stuff */
4480 STDCHAR *nl; /* Position of crlf we "lied" about in the
4484 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4485 * Otherwise the :crlf layer would always revert back to
4489 S_inherit_utf8_flag(PerlIO *f)
4491 PerlIO *g = PerlIONext(f);
4492 if (PerlIOValid(g)) {
4493 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4494 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4500 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4503 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4504 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4506 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4507 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4508 PerlIOBase(f)->flags);
4511 /* Enable the first CRLF capable layer you can find, but if none
4512 * found, the one we just pushed is fine. This results in at
4513 * any given moment at most one CRLF-capable layer being enabled
4514 * in the whole layer stack. */
4515 PerlIO *g = PerlIONext(f);
4516 while (PerlIOValid(g)) {
4517 PerlIOl *b = PerlIOBase(g);
4518 if (b && b->tab == &PerlIO_crlf) {
4519 if (!(b->flags & PERLIO_F_CRLF))
4520 b->flags |= PERLIO_F_CRLF;
4521 S_inherit_utf8_flag(g);
4522 PerlIO_pop(aTHX_ f);
4528 S_inherit_utf8_flag(f);
4534 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4536 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4537 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4541 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4542 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4544 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4545 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4547 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4552 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4553 b->end = b->ptr = b->buf + b->bufsiz;
4554 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4555 b->posn -= b->bufsiz;
4557 while (count > 0 && b->ptr > b->buf) {
4558 const int ch = *--buf;
4560 if (b->ptr - 2 >= b->buf) {
4567 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4568 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4584 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4586 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4588 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4591 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4592 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4593 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4594 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4596 while (nl < b->end && *nl != 0xd)
4598 if (nl < b->end && *nl == 0xd) {
4600 if (nl + 1 < b->end) {
4607 * Not CR,LF but just CR
4615 * Blast - found CR as last char in buffer
4620 * They may not care, defer work as long as
4624 return (nl - b->ptr);
4628 b->ptr++; /* say we have read it as far as
4629 * flush() is concerned */
4630 b->buf++; /* Leave space in front of buffer */
4631 /* Note as we have moved buf up flush's
4633 will naturally make posn point at CR
4635 b->bufsiz--; /* Buffer is thus smaller */
4636 code = PerlIO_fill(f); /* Fetch some more */
4637 b->bufsiz++; /* Restore size for next time */
4638 b->buf--; /* Point at space */
4639 b->ptr = nl = b->buf; /* Which is what we hand
4641 *nl = 0xd; /* Fill in the CR */
4643 goto test; /* fill() call worked */
4645 * CR at EOF - just fall through
4647 /* Should we clear EOF though ??? */
4652 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4658 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4660 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4661 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4667 if (ptr == b->end && *c->nl == 0xd) {
4668 /* Deferred CR at end of buffer case - we lied about count */
4681 * Test code - delete when it works ...
4683 IV flags = PerlIOBase(f)->flags;
4684 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4685 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4686 /* Deferred CR at end of buffer case - we lied about count */
4692 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4693 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4694 flags, c->nl, b->end, cnt);
4701 * They have taken what we lied about
4709 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4713 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4715 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4716 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4718 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4719 const STDCHAR *buf = (const STDCHAR *) vbuf;
4720 const STDCHAR * const ebuf = buf + count;
4723 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4725 while (buf < ebuf) {
4726 const STDCHAR * const eptr = b->buf + b->bufsiz;
4727 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4728 while (buf < ebuf && b->ptr < eptr) {
4730 if ((b->ptr + 2) > eptr) {
4738 *(b->ptr)++ = 0xd; /* CR */
4739 *(b->ptr)++ = 0xa; /* LF */
4741 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4748 *(b->ptr)++ = *buf++;
4750 if (b->ptr >= eptr) {
4756 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4758 return (buf - (STDCHAR *) vbuf);
4763 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4765 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4770 return PerlIOBuf_flush(aTHX_ f);
4774 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4776 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4777 /* In text mode - flush any pending stuff and flip it */
4778 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4779 #ifndef PERLIO_USING_CRLF
4780 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4781 PerlIO_pop(aTHX_ f);
4787 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4788 sizeof(PerlIO_funcs),
4791 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4793 PerlIOBuf_popped, /* popped */
4795 PerlIOCrlf_binmode, /* binmode */
4799 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4800 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4801 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4809 PerlIOBase_clearerr,
4810 PerlIOBase_setlinebuf,
4815 PerlIOCrlf_set_ptrcnt,
4819 /*--------------------------------------------------------------------------------------*/
4821 * mmap as "buffer" layer
4825 PerlIOBuf base; /* PerlIOBuf stuff */
4826 Mmap_t mptr; /* Mapped address */
4827 Size_t len; /* mapped length */
4828 STDCHAR *bbuf; /* malloced buffer if map fails */
4832 PerlIOMmap_map(pTHX_ PerlIO *f)
4835 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4836 const IV flags = PerlIOBase(f)->flags;
4840 if (flags & PERLIO_F_CANREAD) {
4841 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4842 const int fd = PerlIO_fileno(f);
4844 code = Fstat(fd, &st);
4845 if (code == 0 && S_ISREG(st.st_mode)) {
4846 SSize_t len = st.st_size - b->posn;
4849 if (PL_mmap_page_size <= 0)
4850 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4854 * This is a hack - should never happen - open should
4857 b->posn = PerlIO_tell(PerlIONext(f));
4859 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4860 len = st.st_size - posn;
4861 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4862 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4863 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4864 madvise(m->mptr, len, MADV_SEQUENTIAL);
4866 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4867 madvise(m->mptr, len, MADV_WILLNEED);
4869 PerlIOBase(f)->flags =
4870 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4871 b->end = ((STDCHAR *) m->mptr) + len;
4872 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4881 PerlIOBase(f)->flags =
4882 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4884 b->ptr = b->end = b->ptr;
4893 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4895 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4898 PerlIOBuf * const b = &m->base;
4900 /* The munmap address argument is tricky: depending on the
4901 * standard it is either "void *" or "caddr_t" (which is
4902 * usually "char *" (signed or unsigned). If we cast it
4903 * to "void *", those that have it caddr_t and an uptight
4904 * C++ compiler, will freak out. But casting it as char*
4905 * should work. Maybe. (Using Mmap_t figured out by
4906 * Configure doesn't always work, apparently.) */
4907 code = munmap((char*)m->mptr, m->len);
4911 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4914 b->ptr = b->end = b->buf;
4915 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4921 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4923 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4924 PerlIOBuf * const b = &m->base;
4925 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4927 * Already have a readbuffer in progress
4933 * We have a write buffer or flushed PerlIOBuf read buffer
4935 m->bbuf = b->buf; /* save it in case we need it again */
4936 b->buf = NULL; /* Clear to trigger below */
4939 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4942 * Map did not work - recover PerlIOBuf buffer if we have one
4947 b->ptr = b->end = b->buf;
4950 return PerlIOBuf_get_base(aTHX_ f);
4954 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4956 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4957 PerlIOBuf * const b = &m->base;
4958 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4960 if (b->ptr && (b->ptr - count) >= b->buf
4961 && memEQ(b->ptr - count, vbuf, count)) {
4963 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4968 * Loose the unwritable mapped buffer
4972 * If flush took the "buffer" see if we have one from before
4974 if (!b->buf && m->bbuf)
4977 PerlIOBuf_get_base(aTHX_ f);
4981 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4985 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4987 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4988 PerlIOBuf * const b = &m->base;
4990 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4992 * No, or wrong sort of, buffer
4995 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4999 * If unmap took the "buffer" see if we have one from before
5001 if (!b->buf && m->bbuf)
5004 PerlIOBuf_get_base(aTHX_ f);
5008 return PerlIOBuf_write(aTHX_ f, vbuf, count);
5012 PerlIOMmap_flush(pTHX_ PerlIO *f)
5014 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5015 PerlIOBuf * const b = &m->base;
5016 IV code = PerlIOBuf_flush(aTHX_ f);
5018 * Now we are "synced" at PerlIOBuf level
5025 if (PerlIOMmap_unmap(aTHX_ f) != 0)
5030 * We seem to have a PerlIOBuf buffer which was not mapped
5031 * remember it in case we need one later
5040 PerlIOMmap_fill(pTHX_ PerlIO *f)
5042 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
5043 IV code = PerlIO_flush(f);
5044 if (code == 0 && !b->buf) {
5045 code = PerlIOMmap_map(aTHX_ f);
5047 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
5048 code = PerlIOBuf_fill(aTHX_ f);
5054 PerlIOMmap_close(pTHX_ PerlIO *f)
5056 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5057 PerlIOBuf * const b = &m->base;
5058 IV code = PerlIO_flush(f);
5062 b->ptr = b->end = b->buf;
5064 if (PerlIOBuf_close(aTHX_ f) != 0)
5070 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
5072 return PerlIOBase_dup(aTHX_ f, o, param, flags);
5076 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
5077 sizeof(PerlIO_funcs),
5080 PERLIO_K_BUFFERED|PERLIO_K_RAW,
5084 PerlIOBase_binmode, /* binmode */
5098 PerlIOBase_clearerr,
5099 PerlIOBase_setlinebuf,
5100 PerlIOMmap_get_base,
5104 PerlIOBuf_set_ptrcnt,
5107 #endif /* HAS_MMAP */
5110 Perl_PerlIO_stdin(pTHX)
5114 PerlIO_stdstreams(aTHX);
5116 return (PerlIO*)&PL_perlio[1];
5120 Perl_PerlIO_stdout(pTHX)
5124 PerlIO_stdstreams(aTHX);
5126 return (PerlIO*)&PL_perlio[2];
5130 Perl_PerlIO_stderr(pTHX)
5134 PerlIO_stdstreams(aTHX);
5136 return (PerlIO*)&PL_perlio[3];
5139 /*--------------------------------------------------------------------------------------*/
5142 PerlIO_getname(PerlIO *f, char *buf)
5147 bool exported = FALSE;
5148 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5150 stdio = PerlIO_exportFILE(f,0);
5154 name = fgetname(stdio, buf);
5155 if (exported) PerlIO_releaseFILE(f,stdio);
5160 PERL_UNUSED_ARG(buf);
5161 Perl_croak(aTHX_ "Don't know how to get file name");
5167 /*--------------------------------------------------------------------------------------*/
5169 * Functions which can be called on any kind of PerlIO implemented in
5173 #undef PerlIO_fdopen
5175 PerlIO_fdopen(int fd, const char *mode)
5178 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5183 PerlIO_open(const char *path, const char *mode)
5186 SV *name = sv_2mortal(newSVpv(path, 0));
5187 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5190 #undef Perlio_reopen
5192 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5195 SV *name = sv_2mortal(newSVpv(path,0));
5196 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5201 PerlIO_getc(PerlIO *f)
5205 if ( 1 == PerlIO_read(f, buf, 1) ) {
5206 return (unsigned char) buf[0];
5211 #undef PerlIO_ungetc
5213 PerlIO_ungetc(PerlIO *f, int ch)
5218 if (PerlIO_unread(f, &buf, 1) == 1)
5226 PerlIO_putc(PerlIO *f, int ch)
5230 return PerlIO_write(f, &buf, 1);
5235 PerlIO_puts(PerlIO *f, const char *s)
5238 return PerlIO_write(f, s, strlen(s));
5241 #undef PerlIO_rewind
5243 PerlIO_rewind(PerlIO *f)
5246 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5250 #undef PerlIO_vprintf
5252 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5261 Perl_va_copy(ap, apc);
5262 sv = vnewSVpvf(fmt, &apc);
5264 sv = vnewSVpvf(fmt, &ap);
5266 s = SvPV_const(sv, len);
5267 wrote = PerlIO_write(f, s, len);
5272 #undef PerlIO_printf
5274 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5279 result = PerlIO_vprintf(f, fmt, ap);
5284 #undef PerlIO_stdoutf
5286 PerlIO_stdoutf(const char *fmt, ...)
5292 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5297 #undef PerlIO_tmpfile
5299 PerlIO_tmpfile(void)
5304 const int fd = win32_tmpfd();
5306 f = PerlIO_fdopen(fd, "w+b");
5308 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5310 char tempname[] = "/tmp/PerlIO_XXXXXX";
5311 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5314 * I have no idea how portable mkstemp() is ... NI-S
5316 if (tmpdir && *tmpdir) {
5317 /* if TMPDIR is set and not empty, we try that first */
5318 sv = newSVpv(tmpdir, 0);
5319 sv_catpv(sv, tempname + 4);
5320 fd = mkstemp(SvPVX(sv));
5324 /* else we try /tmp */
5325 fd = mkstemp(tempname);
5328 f = PerlIO_fdopen(fd, "w+");
5330 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5331 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5334 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5335 FILE * const stdio = PerlSIO_tmpfile();
5338 f = PerlIO_fdopen(fileno(stdio), "w+");
5340 # endif /* else HAS_MKSTEMP */
5341 #endif /* else WIN32 */
5348 #endif /* USE_SFIO */
5349 #endif /* PERLIO_IS_STDIO */
5351 /*======================================================================================*/
5353 * Now some functions in terms of above which may be needed even if we are
5354 * not in true PerlIO mode
5357 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5360 const char *direction = NULL;
5363 * Need to supply default layer info from open.pm
5369 if (mode && mode[0] != 'r') {
5370 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5371 direction = "open>";
5373 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5374 direction = "open<";
5379 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5382 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5387 #undef PerlIO_setpos
5389 PerlIO_setpos(PerlIO *f, SV *pos)
5394 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5395 if (f && len == sizeof(Off_t))
5396 return PerlIO_seek(f, *posn, SEEK_SET);
5398 SETERRNO(EINVAL, SS_IVCHAN);
5402 #undef PerlIO_setpos
5404 PerlIO_setpos(PerlIO *f, SV *pos)
5409 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5410 if (f && len == sizeof(Fpos_t)) {
5411 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5412 return fsetpos64(f, fpos);
5414 return fsetpos(f, fpos);
5418 SETERRNO(EINVAL, SS_IVCHAN);
5424 #undef PerlIO_getpos
5426 PerlIO_getpos(PerlIO *f, SV *pos)
5429 Off_t posn = PerlIO_tell(f);
5430 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5431 return (posn == (Off_t) - 1) ? -1 : 0;
5434 #undef PerlIO_getpos
5436 PerlIO_getpos(PerlIO *f, SV *pos)
5441 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5442 code = fgetpos64(f, &fpos);
5444 code = fgetpos(f, &fpos);
5446 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5451 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5454 vprintf(char *pat, char *args)
5456 _doprnt(pat, args, stdout);
5457 return 0; /* wrong, but perl doesn't use the return
5462 vfprintf(FILE *fd, char *pat, char *args)
5464 _doprnt(pat, args, fd);
5465 return 0; /* wrong, but perl doesn't use the return
5471 #ifndef PerlIO_vsprintf
5473 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5476 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5477 PERL_UNUSED_CONTEXT;
5479 #ifndef PERL_MY_VSNPRINTF_GUARDED
5480 if (val < 0 || (n > 0 ? val >= n : 0)) {
5481 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5488 #ifndef PerlIO_sprintf
5490 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5495 result = PerlIO_vsprintf(s, n, fmt, ap);
5503 * c-indentation-style: bsd
5505 * indent-tabs-mode: t
5508 * ex: set ts=8 sts=4 sw=4 noet: