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 /* Call the callback or PerlIOBase, and return failure. */
74 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
75 if (PerlIOValid(f)) { \
76 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
77 if (tab && tab->callback) \
78 return (*tab->callback) args; \
80 return PerlIOBase_ ## base args; \
83 SETERRNO(EBADF, SS_IVCHAN); \
86 /* Call the callback or fail, and return failure. */
87 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
88 if (PerlIOValid(f)) { \
89 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
90 if (tab && tab->callback) \
91 return (*tab->callback) args; \
92 SETERRNO(EINVAL, LIB_INVARG); \
95 SETERRNO(EBADF, SS_IVCHAN); \
98 /* Call the callback or PerlIOBase, and be void. */
99 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
100 if (PerlIOValid(f)) { \
101 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
102 if (tab && tab->callback) \
103 (*tab->callback) args; \
105 PerlIOBase_ ## base args; \
108 SETERRNO(EBADF, SS_IVCHAN)
110 /* Call the callback or fail, and be void. */
111 #define Perl_PerlIO_or_fail_void(f, callback, args) \
112 if (PerlIOValid(f)) { \
113 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
114 if (tab && tab->callback) \
115 (*tab->callback) args; \
117 SETERRNO(EINVAL, LIB_INVARG); \
120 SETERRNO(EBADF, SS_IVCHAN)
122 #if defined(__osf__) && _XOPEN_SOURCE < 500
123 extern int fseeko(FILE *, off_t, int);
124 extern off_t ftello(FILE *);
129 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
132 perlsio_binmode(FILE *fp, int iotype, int mode)
135 * This used to be contents of do_binmode in doio.c
138 # if defined(atarist) || defined(__MINT__)
139 PERL_UNUSED_ARG(iotype);
142 ((FILE *) fp)->_flag |= _IOBIN;
144 ((FILE *) fp)->_flag &= ~_IOBIN;
150 PERL_UNUSED_ARG(iotype);
152 if (PerlLIO_setmode(fp, mode) != -1) {
154 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
156 # if defined(WIN32) && defined(__BORLANDC__)
158 * The translation mode of the stream is maintained independent
160 * the translation mode of the fd in the Borland RTL (heavy
161 * digging through their runtime sources reveal). User has to
163 * the mode explicitly for the stream (though they don't
165 * this anywhere). GSAR 97-5-24
171 fp->flags &= ~_F_BIN;
179 # if defined(USEMYBINMODE)
181 # if defined(__CYGWIN__)
182 PERL_UNUSED_ARG(iotype);
184 if (my_binmode(fp, iotype, mode) != FALSE)
190 PERL_UNUSED_ARG(iotype);
191 PERL_UNUSED_ARG(mode);
199 #define O_ACCMODE 3 /* Assume traditional implementation */
203 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
205 const int result = rawmode & O_ACCMODE;
210 ptype = IoTYPE_RDONLY;
213 ptype = IoTYPE_WRONLY;
221 *writing = (result != O_RDONLY);
223 if (result == O_RDONLY) {
227 else if (rawmode & O_APPEND) {
229 if (result != O_WRONLY)
234 if (result == O_WRONLY)
241 if (rawmode & O_BINARY)
247 #ifndef PERLIO_LAYERS
249 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
251 if (!names || !*names
252 || strEQ(names, ":crlf")
253 || strEQ(names, ":raw")
254 || strEQ(names, ":bytes")
258 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
266 PerlIO_destruct(pTHX)
271 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
274 PERL_UNUSED_ARG(iotype);
275 PERL_UNUSED_ARG(mode);
276 PERL_UNUSED_ARG(names);
279 return perlsio_binmode(fp, iotype, mode);
284 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
286 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
289 #ifdef PERL_IMPLICIT_SYS
290 return PerlSIO_fdupopen(f);
293 return win32_fdupopen(f);
296 const int fd = PerlLIO_dup(PerlIO_fileno(f));
300 const int omode = djgpp_get_stream_mode(f);
302 const int omode = fcntl(fd, F_GETFL);
304 PerlIO_intmode2str(omode,mode,NULL);
305 /* the r+ is a hack */
306 return PerlIO_fdopen(fd, mode);
311 SETERRNO(EBADF, SS_IVCHAN);
321 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
325 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
326 int imode, int perm, PerlIO *old, int narg, SV **args)
330 Perl_croak(aTHX_ "More than one argument to open");
332 if (*args == &PL_sv_undef)
333 return PerlIO_tmpfile();
335 const char *name = SvPV_nolen_const(*args);
336 if (*mode == IoTYPE_NUMERIC) {
337 fd = PerlLIO_open3(name, imode, perm);
339 return PerlIO_fdopen(fd, mode + 1);
342 return PerlIO_reopen(name, mode, old);
345 return PerlIO_open(name, mode);
350 return PerlIO_fdopen(fd, (char *) mode);
355 XS(XS_PerlIO__Layer__find)
359 Perl_croak(aTHX_ "Usage class->find(name[,load])");
361 const char * const name = SvPV_nolen_const(ST(1));
362 ST(0) = (strEQ(name, "crlf")
363 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
370 Perl_boot_core_PerlIO(pTHX)
372 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
378 #ifdef PERLIO_IS_STDIO
385 * Does nothing (yet) except force this file to be included in perl
386 * binary. That allows this file to force inclusion of other functions
387 * that may be required by loadable extensions e.g. for
388 * FileHandle::tmpfile
392 #undef PerlIO_tmpfile
399 #else /* PERLIO_IS_STDIO */
407 * This section is just to make sure these functions get pulled in from
411 #undef PerlIO_tmpfile
423 * Force this file to be included in perl binary. Which allows this
424 * file to force inclusion of other functions that may be required by
425 * loadable extensions e.g. for FileHandle::tmpfile
429 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
430 * results in a lot of lseek()s to regular files and lot of small
433 sfset(sfstdout, SF_SHARE, 0);
436 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
438 PerlIO_importFILE(FILE *stdio, const char *mode)
440 const int fd = fileno(stdio);
441 if (!mode || !*mode) {
444 return PerlIO_fdopen(fd, mode);
448 PerlIO_findFILE(PerlIO *pio)
450 const int fd = PerlIO_fileno(pio);
451 FILE * const f = fdopen(fd, "r+");
453 if (!f && errno == EINVAL)
455 if (!f && errno == EINVAL)
462 /*======================================================================================*/
464 * Implement all the PerlIO interface ourselves.
470 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
477 #include <sys/mman.h>
481 PerlIO_debug(const char *fmt, ...)
486 if (!PL_perlio_debug_fd) {
487 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
488 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
491 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
493 PL_perlio_debug_fd = -1;
495 /* tainting or set*id, so ignore the environment, and ensure we
496 skip these tests next time through. */
497 PL_perlio_debug_fd = -1;
500 if (PL_perlio_debug_fd > 0) {
503 const char * const s = CopFILE(PL_curcop);
504 /* Use fixed buffer as sv_catpvf etc. needs SVs */
506 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
507 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
508 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
510 const char *s = CopFILE(PL_curcop);
512 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
513 (IV) CopLINE(PL_curcop));
514 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
516 s = SvPV_const(sv, len);
517 PerlLIO_write(PL_perlio_debug_fd, s, len);
524 /*--------------------------------------------------------------------------------------*/
527 * Inner level routines
531 * Table of pointers to the PerlIO structs (malloc'ed)
533 #define PERLIO_TABLE_SIZE 64
536 PerlIO_allocate(pTHX)
540 * Find a free slot in the table, allocating new table as necessary
545 while ((f = *last)) {
547 last = (PerlIO **) (f);
548 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
554 Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
562 #undef PerlIO_fdupopen
564 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
566 if (PerlIOValid(f)) {
567 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
568 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
570 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
572 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
576 SETERRNO(EBADF, SS_IVCHAN);
582 PerlIO_cleantable(pTHX_ PerlIO **tablep)
584 PerlIO * const table = *tablep;
587 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
588 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
589 PerlIO * const f = table + i;
601 PerlIO_list_alloc(pTHX)
605 Newxz(list, 1, PerlIO_list_t);
611 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
614 if (--list->refcnt == 0) {
617 for (i = 0; i < list->cur; i++) {
618 if (list->array[i].arg)
619 SvREFCNT_dec(list->array[i].arg);
621 Safefree(list->array);
629 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
635 if (list->cur >= list->len) {
638 Renew(list->array, list->len, PerlIO_pair_t);
640 Newx(list->array, list->len, PerlIO_pair_t);
642 p = &(list->array[list->cur++]);
644 if ((p->arg = arg)) {
645 SvREFCNT_inc_simple_void_NN(arg);
650 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
652 PerlIO_list_t *list = NULL;
655 list = PerlIO_list_alloc(aTHX);
656 for (i=0; i < proto->cur; i++) {
657 SV *arg = proto->array[i].arg;
660 arg = sv_dup(arg, param);
662 PERL_UNUSED_ARG(param);
664 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
671 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
674 PerlIO **table = &proto->Iperlio;
677 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
678 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
679 PerlIO_allocate(aTHX); /* root slot is never used */
680 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
681 while ((f = *table)) {
683 table = (PerlIO **) (f++);
684 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
686 (void) fp_dup(f, 0, param);
693 PERL_UNUSED_ARG(proto);
694 PERL_UNUSED_ARG(param);
699 PerlIO_destruct(pTHX)
702 PerlIO **table = &PL_perlio;
705 PerlIO_debug("Destruct %p\n",(void*)aTHX);
707 while ((f = *table)) {
709 table = (PerlIO **) (f++);
710 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
714 if (l->tab->kind & PERLIO_K_DESTRUCT) {
715 PerlIO_debug("Destruct popping %s\n", l->tab->name);
729 PerlIO_pop(pTHX_ PerlIO *f)
731 const PerlIOl *l = *f;
733 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
734 if (l->tab->Popped) {
736 * If popped returns non-zero do not free its layer structure
737 * it has either done so itself, or it is shared and still in
740 if ((*l->tab->Popped) (aTHX_ f) != 0)
748 /* Return as an array the stack of layers on a filehandle. Note that
749 * the stack is returned top-first in the array, and there are three
750 * times as many array elements as there are layers in the stack: the
751 * first element of a layer triplet is the name, the second one is the
752 * arguments, and the third one is the flags. */
755 PerlIO_get_layers(pTHX_ PerlIO *f)
758 AV * const av = newAV();
760 if (PerlIOValid(f)) {
761 PerlIOl *l = PerlIOBase(f);
764 /* There is some collusion in the implementation of
765 XS_PerlIO_get_layers - it knows that name and flags are
766 generated as fresh SVs here, and takes advantage of that to
767 "copy" them by taking a reference. If it changes here, it needs
768 to change there too. */
769 SV * const name = l->tab && l->tab->name ?
770 newSVpv(l->tab->name, 0) : &PL_sv_undef;
771 SV * const arg = l->tab && l->tab->Getarg ?
772 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
775 av_push(av, newSViv((IV)l->flags));
783 /*--------------------------------------------------------------------------------------*/
785 * XS Interface for perl code
789 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
793 if ((SSize_t) len <= 0)
795 for (i = 0; i < PL_known_layers->cur; i++) {
796 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
797 if (memEQ(f->name, name, len) && f->name[len] == 0) {
798 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
802 if (load && PL_subname && PL_def_layerlist
803 && PL_def_layerlist->cur >= 2) {
804 if (PL_in_load_module) {
805 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
808 SV * const pkgsv = newSVpvs("PerlIO");
809 SV * const layer = newSVpvn(name, len);
810 CV * const cv = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
812 SAVEINT(PL_in_load_module);
814 SAVEGENERICSV(PL_warnhook);
815 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
819 * The two SVs are magically freed by load_module
821 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
824 return PerlIO_find_layer(aTHX_ name, len, 0);
827 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
831 #ifdef USE_ATTRIBUTES_FOR_PERLIO
834 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
837 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
838 PerlIO * const ifp = IoIFP(io);
839 PerlIO * const ofp = IoOFP(io);
840 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
841 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
847 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
850 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
851 PerlIO * const ifp = IoIFP(io);
852 PerlIO * const ofp = IoOFP(io);
853 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
854 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
860 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
862 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
867 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
869 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
873 MGVTBL perlio_vtab = {
881 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
884 SV * const sv = SvRV(ST(1));
885 AV * const av = newAV();
889 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
891 mg = mg_find(sv, PERL_MAGIC_ext);
892 mg->mg_virtual = &perlio_vtab;
894 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
895 for (i = 2; i < items; i++) {
897 const char * const name = SvPV_const(ST(i), len);
898 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
900 av_push(av, SvREFCNT_inc_simple_NN(layer));
911 #endif /* USE_ATTIBUTES_FOR_PERLIO */
914 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
916 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
917 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
921 XS(XS_PerlIO__Layer__NoWarnings)
923 /* This is used as a %SIG{__WARN__} handler to supress warnings
924 during loading of layers.
930 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
934 XS(XS_PerlIO__Layer__find)
940 Perl_croak(aTHX_ "Usage class->find(name[,load])");
943 const char * const name = SvPV_const(ST(1), len);
944 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
945 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
947 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
954 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
957 if (!PL_known_layers)
958 PL_known_layers = PerlIO_list_alloc(aTHX);
959 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
960 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
964 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
968 const char *s = names;
970 while (isSPACE(*s) || *s == ':')
975 const char *as = NULL;
977 if (!isIDFIRST(*s)) {
979 * Message is consistent with how attribute lists are
980 * passed. Even though this means "foo : : bar" is
981 * seen as an invalid separator character.
983 const char q = ((*s == '\'') ? '"' : '\'');
984 if (ckWARN(WARN_LAYER))
985 Perl_warner(aTHX_ packWARN(WARN_LAYER),
986 "Invalid separator character %c%c%c in PerlIO layer specification %s",
988 SETERRNO(EINVAL, LIB_INVARG);
993 } while (isALNUM(*e));
1002 alen = (e - 1) - as;
1009 * It's a nul terminated string, not allowed
1010 * to \ the terminating null. Anything other
1011 * character is passed over.
1021 if (ckWARN(WARN_LAYER))
1022 Perl_warner(aTHX_ packWARN(WARN_LAYER),
1023 "Argument list not closed for PerlIO layer \"%.*s\"",
1035 PerlIO_funcs * const layer =
1036 PerlIO_find_layer(aTHX_ s, llen, 1);
1040 arg = newSVpvn(as, alen);
1041 PerlIO_list_push(aTHX_ av, layer,
1042 (arg) ? arg : &PL_sv_undef);
1047 if (ckWARN(WARN_LAYER))
1048 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1061 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1064 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1065 #ifdef PERLIO_USING_CRLF
1068 if (PerlIO_stdio.Set_ptrcnt)
1069 tab = &PerlIO_stdio;
1071 PerlIO_debug("Pushing %s\n", tab->name);
1072 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1077 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1079 return av->array[n].arg;
1083 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1085 if (n >= 0 && n < av->cur) {
1086 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1087 av->array[n].funcs->name);
1088 return av->array[n].funcs;
1091 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1096 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1098 PERL_UNUSED_ARG(mode);
1099 PERL_UNUSED_ARG(arg);
1100 PERL_UNUSED_ARG(tab);
1101 if (PerlIOValid(f)) {
1103 PerlIO_pop(aTHX_ f);
1109 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1110 sizeof(PerlIO_funcs),
1113 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1133 NULL, /* get_base */
1134 NULL, /* get_bufsiz */
1137 NULL, /* set_ptrcnt */
1141 PerlIO_default_layers(pTHX)
1144 if (!PL_def_layerlist) {
1145 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1146 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1147 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1148 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1150 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1152 osLayer = &PerlIO_win32;
1155 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1156 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1157 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1158 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1160 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1162 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1163 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1164 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1165 PerlIO_list_push(aTHX_ PL_def_layerlist,
1166 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1169 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1172 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1175 if (PL_def_layerlist->cur < 2) {
1176 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1178 return PL_def_layerlist;
1182 Perl_boot_core_PerlIO(pTHX)
1184 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1185 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1188 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1189 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1193 PerlIO_default_layer(pTHX_ I32 n)
1196 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1199 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1202 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1203 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1206 PerlIO_stdstreams(pTHX)
1210 PerlIO_allocate(aTHX);
1211 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1212 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1213 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1218 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1220 if (tab->fsize != sizeof(PerlIO_funcs)) {
1222 Perl_croak(aTHX_ "Layer does not match this perl");
1226 if (tab->size < sizeof(PerlIOl)) {
1229 /* Real layer with a data area */
1232 Newxz(temp, tab->size, char);
1236 l->tab = (PerlIO_funcs*) tab;
1238 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1239 (void*)f, tab->name,
1240 (mode) ? mode : "(Null)", (void*)arg);
1241 if (*l->tab->Pushed &&
1243 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1244 PerlIO_pop(aTHX_ f);
1253 /* Pseudo-layer where push does its own stack adjust */
1254 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1255 (mode) ? mode : "(Null)", (void*)arg);
1257 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1265 PerlIOBase_binmode(pTHX_ PerlIO *f)
1267 if (PerlIOValid(f)) {
1268 /* Is layer suitable for raw stream ? */
1269 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1270 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1271 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1274 /* Not suitable - pop it */
1275 PerlIO_pop(aTHX_ f);
1283 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1285 PERL_UNUSED_ARG(mode);
1286 PERL_UNUSED_ARG(arg);
1287 PERL_UNUSED_ARG(tab);
1289 if (PerlIOValid(f)) {
1294 * Strip all layers that are not suitable for a raw stream
1297 while (t && (l = *t)) {
1298 if (l->tab->Binmode) {
1299 /* Has a handler - normal case */
1300 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1302 /* Layer still there - move down a layer */
1311 /* No handler - pop it */
1312 PerlIO_pop(aTHX_ t);
1315 if (PerlIOValid(f)) {
1316 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1324 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1325 PerlIO_list_t *layers, IV n, IV max)
1329 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1331 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1342 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1346 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1347 code = PerlIO_parse_layers(aTHX_ layers, names);
1349 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1351 PerlIO_list_free(aTHX_ layers);
1357 /*--------------------------------------------------------------------------------------*/
1359 * Given the abstraction above the public API functions
1363 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1365 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1366 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1367 iotype, mode, (names) ? names : "(Null)");
1370 /* Do not flush etc. if (e.g.) switching encodings.
1371 if a pushed layer knows it needs to flush lower layers
1372 (for example :unix which is never going to call them)
1373 it can do the flush when it is pushed.
1375 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1378 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1379 #ifdef PERLIO_USING_CRLF
1380 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1381 O_BINARY so we can look for it in mode.
1383 if (!(mode & O_BINARY)) {
1385 /* FIXME?: Looking down the layer stack seems wrong,
1386 but is a way of reaching past (say) an encoding layer
1387 to flip CRLF-ness of the layer(s) below
1390 /* Perhaps we should turn on bottom-most aware layer
1391 e.g. Ilya's idea that UNIX TTY could serve
1393 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1394 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1395 /* Not in text mode - flush any pending stuff and flip it */
1397 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1399 /* Only need to turn it on in one layer so we are done */
1404 /* Not finding a CRLF aware layer presumably means we are binary
1405 which is not what was requested - so we failed
1406 We _could_ push :crlf layer but so could caller
1411 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1412 So code that used to be here is now in PerlIORaw_pushed().
1414 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1419 PerlIO__close(pTHX_ PerlIO *f)
1421 if (PerlIOValid(f)) {
1422 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1423 if (tab && tab->Close)
1424 return (*tab->Close)(aTHX_ f);
1426 return PerlIOBase_close(aTHX_ f);
1429 SETERRNO(EBADF, SS_IVCHAN);
1435 Perl_PerlIO_close(pTHX_ PerlIO *f)
1437 const int code = PerlIO__close(aTHX_ f);
1438 while (PerlIOValid(f)) {
1439 PerlIO_pop(aTHX_ f);
1445 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1448 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1452 static PerlIO_funcs *
1453 PerlIO_layer_from_ref(pTHX_ SV *sv)
1457 * For any scalar type load the handler which is bundled with perl
1459 if (SvTYPE(sv) < SVt_PVAV) {
1460 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1461 /* This isn't supposed to happen, since PerlIO::scalar is core,
1462 * but could happen anyway in smaller installs or with PAR */
1463 if (!f && ckWARN(WARN_LAYER))
1464 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1469 * For other types allow if layer is known but don't try and load it
1471 switch (SvTYPE(sv)) {
1473 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1475 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1477 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1479 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1486 PerlIO_resolve_layers(pTHX_ const char *layers,
1487 const char *mode, int narg, SV **args)
1490 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1493 PerlIO_stdstreams(aTHX);
1495 SV * const arg = *args;
1497 * If it is a reference but not an object see if we have a handler
1500 if (SvROK(arg) && !sv_isobject(arg)) {
1501 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1503 def = PerlIO_list_alloc(aTHX);
1504 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1508 * Don't fail if handler cannot be found :via(...) etc. may do
1509 * something sensible else we will just stringfy and open
1514 if (!layers || !*layers)
1515 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1516 if (layers && *layers) {
1519 av = PerlIO_clone_list(aTHX_ def, NULL);
1524 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1528 PerlIO_list_free(aTHX_ av);
1540 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1541 int imode, int perm, PerlIO *f, int narg, SV **args)
1544 if (!f && narg == 1 && *args == &PL_sv_undef) {
1545 if ((f = PerlIO_tmpfile())) {
1546 if (!layers || !*layers)
1547 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1548 if (layers && *layers)
1549 PerlIO_apply_layers(aTHX_ f, mode, layers);
1553 PerlIO_list_t *layera;
1555 PerlIO_funcs *tab = NULL;
1556 if (PerlIOValid(f)) {
1558 * This is "reopen" - it is not tested as perl does not use it
1562 layera = PerlIO_list_alloc(aTHX);
1566 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1567 PerlIO_list_push(aTHX_ layera, l->tab,
1568 (arg) ? arg : &PL_sv_undef);
1571 l = *PerlIONext(&l);
1575 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1581 * Start at "top" of layer stack
1583 n = layera->cur - 1;
1585 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1594 * Found that layer 'n' can do opens - call it
1596 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1597 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1599 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1600 tab->name, layers ? layers : "(Null)", mode, fd,
1601 imode, perm, (void*)f, narg, (void*)args);
1603 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1606 SETERRNO(EINVAL, LIB_INVARG);
1610 if (n + 1 < layera->cur) {
1612 * More layers above the one that we used to open -
1615 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1616 /* If pushing layers fails close the file */
1623 PerlIO_list_free(aTHX_ layera);
1630 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1632 PERL_ARGS_ASSERT_PERLIO_READ;
1634 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1638 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1640 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1642 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1646 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1648 PERL_ARGS_ASSERT_PERLIO_WRITE;
1650 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1654 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1656 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1660 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1662 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1666 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1671 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1673 if (tab && tab->Flush)
1674 return (*tab->Flush) (aTHX_ f);
1676 return 0; /* If no Flush defined, silently succeed. */
1679 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1680 SETERRNO(EBADF, SS_IVCHAN);
1686 * Is it good API design to do flush-all on NULL, a potentially
1687 * errorneous input? Maybe some magical value (PerlIO*
1688 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1689 * things on fflush(NULL), but should we be bound by their design
1692 PerlIO **table = &PL_perlio;
1694 while ((f = *table)) {
1696 table = (PerlIO **) (f++);
1697 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1698 if (*f && PerlIO_flush(f) != 0)
1708 PerlIOBase_flush_linebuf(pTHX)
1711 PerlIO **table = &PL_perlio;
1713 while ((f = *table)) {
1715 table = (PerlIO **) (f++);
1716 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1719 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1720 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1728 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1730 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1734 PerlIO_isutf8(PerlIO *f)
1737 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1739 SETERRNO(EBADF, SS_IVCHAN);
1745 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1747 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1751 Perl_PerlIO_error(pTHX_ PerlIO *f)
1753 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1757 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1759 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1763 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1765 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1769 PerlIO_has_base(PerlIO *f)
1771 if (PerlIOValid(f)) {
1772 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1775 return (tab->Get_base != NULL);
1776 SETERRNO(EINVAL, LIB_INVARG);
1779 SETERRNO(EBADF, SS_IVCHAN);
1785 PerlIO_fast_gets(PerlIO *f)
1787 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1788 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1791 return (tab->Set_ptrcnt != NULL);
1792 SETERRNO(EINVAL, LIB_INVARG);
1795 SETERRNO(EBADF, SS_IVCHAN);
1801 PerlIO_has_cntptr(PerlIO *f)
1803 if (PerlIOValid(f)) {
1804 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1807 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1808 SETERRNO(EINVAL, LIB_INVARG);
1811 SETERRNO(EBADF, SS_IVCHAN);
1817 PerlIO_canset_cnt(PerlIO *f)
1819 if (PerlIOValid(f)) {
1820 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1823 return (tab->Set_ptrcnt != NULL);
1824 SETERRNO(EINVAL, LIB_INVARG);
1827 SETERRNO(EBADF, SS_IVCHAN);
1833 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1835 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1839 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1841 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1845 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1847 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1851 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1853 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1857 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1859 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1863 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1865 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1869 /*--------------------------------------------------------------------------------------*/
1871 * utf8 and raw dummy layers
1875 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1877 PERL_UNUSED_CONTEXT;
1878 PERL_UNUSED_ARG(mode);
1879 PERL_UNUSED_ARG(arg);
1880 if (PerlIOValid(f)) {
1881 if (tab->kind & PERLIO_K_UTF8)
1882 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1884 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1890 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1891 sizeof(PerlIO_funcs),
1894 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1914 NULL, /* get_base */
1915 NULL, /* get_bufsiz */
1918 NULL, /* set_ptrcnt */
1921 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1922 sizeof(PerlIO_funcs),
1945 NULL, /* get_base */
1946 NULL, /* get_bufsiz */
1949 NULL, /* set_ptrcnt */
1953 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1954 IV n, const char *mode, int fd, int imode, int perm,
1955 PerlIO *old, int narg, SV **args)
1957 PerlIO_funcs * const tab = PerlIO_default_btm();
1958 PERL_UNUSED_ARG(self);
1959 if (tab && tab->Open)
1960 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1962 SETERRNO(EINVAL, LIB_INVARG);
1966 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1967 sizeof(PerlIO_funcs),
1990 NULL, /* get_base */
1991 NULL, /* get_bufsiz */
1994 NULL, /* set_ptrcnt */
1996 /*--------------------------------------------------------------------------------------*/
1997 /*--------------------------------------------------------------------------------------*/
1999 * "Methods" of the "base class"
2003 PerlIOBase_fileno(pTHX_ PerlIO *f)
2005 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2009 PerlIO_modestr(PerlIO * f, char *buf)
2012 if (PerlIOValid(f)) {
2013 const IV flags = PerlIOBase(f)->flags;
2014 if (flags & PERLIO_F_APPEND) {
2016 if (flags & PERLIO_F_CANREAD) {
2020 else if (flags & PERLIO_F_CANREAD) {
2022 if (flags & PERLIO_F_CANWRITE)
2025 else if (flags & PERLIO_F_CANWRITE) {
2027 if (flags & PERLIO_F_CANREAD) {
2031 #ifdef PERLIO_USING_CRLF
2032 if (!(flags & PERLIO_F_CRLF))
2042 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2044 PerlIOl * const l = PerlIOBase(f);
2045 PERL_UNUSED_CONTEXT;
2046 PERL_UNUSED_ARG(arg);
2048 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2049 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2050 if (tab->Set_ptrcnt != NULL)
2051 l->flags |= PERLIO_F_FASTGETS;
2053 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2057 l->flags |= PERLIO_F_CANREAD;
2060 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2063 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2066 SETERRNO(EINVAL, LIB_INVARG);
2072 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2075 l->flags &= ~PERLIO_F_CRLF;
2078 l->flags |= PERLIO_F_CRLF;
2081 SETERRNO(EINVAL, LIB_INVARG);
2088 l->flags |= l->next->flags &
2089 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2094 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2095 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2096 l->flags, PerlIO_modestr(f, temp));
2102 PerlIOBase_popped(pTHX_ PerlIO *f)
2104 PERL_UNUSED_CONTEXT;
2110 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2113 * Save the position as current head considers it
2115 const Off_t old = PerlIO_tell(f);
2116 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2117 PerlIOSelf(f, PerlIOBuf)->posn = old;
2118 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2122 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2124 STDCHAR *buf = (STDCHAR *) vbuf;
2126 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2127 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2128 SETERRNO(EBADF, SS_IVCHAN);
2134 SSize_t avail = PerlIO_get_cnt(f);
2137 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2139 STDCHAR *ptr = PerlIO_get_ptr(f);
2140 Copy(ptr, buf, take, STDCHAR);
2141 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2144 if (avail == 0) /* set_ptrcnt could have reset avail */
2147 if (count > 0 && avail <= 0) {
2148 if (PerlIO_fill(f) != 0)
2153 return (buf - (STDCHAR *) vbuf);
2159 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2161 PERL_UNUSED_CONTEXT;
2167 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2169 PERL_UNUSED_CONTEXT;
2175 PerlIOBase_close(pTHX_ PerlIO *f)
2178 if (PerlIOValid(f)) {
2179 PerlIO *n = PerlIONext(f);
2180 code = PerlIO_flush(f);
2181 PerlIOBase(f)->flags &=
2182 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2183 while (PerlIOValid(n)) {
2184 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2185 if (tab && tab->Close) {
2186 if ((*tab->Close)(aTHX_ n) != 0)
2191 PerlIOBase(n)->flags &=
2192 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2198 SETERRNO(EBADF, SS_IVCHAN);
2204 PerlIOBase_eof(pTHX_ PerlIO *f)
2206 PERL_UNUSED_CONTEXT;
2207 if (PerlIOValid(f)) {
2208 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2214 PerlIOBase_error(pTHX_ PerlIO *f)
2216 PERL_UNUSED_CONTEXT;
2217 if (PerlIOValid(f)) {
2218 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2224 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2226 if (PerlIOValid(f)) {
2227 PerlIO * const n = PerlIONext(f);
2228 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2235 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2237 PERL_UNUSED_CONTEXT;
2238 if (PerlIOValid(f)) {
2239 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2244 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2250 arg = sv_dup(arg, param);
2251 SvREFCNT_inc_simple_void_NN(arg);
2255 return newSVsv(arg);
2258 PERL_UNUSED_ARG(param);
2259 return newSVsv(arg);
2264 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2266 PerlIO * const nexto = PerlIONext(o);
2267 if (PerlIOValid(nexto)) {
2268 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2269 if (tab && tab->Dup)
2270 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2272 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2275 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2278 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2279 self->name, (void*)f, (void*)o, (void*)param);
2281 arg = (*self->Getarg)(aTHX_ o, param, flags);
2282 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2283 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2284 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2291 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2293 /* Must be called with PL_perlio_mutex locked. */
2295 S_more_refcounted_fds(pTHX_ const int new_fd) {
2297 const int old_max = PL_perlio_fd_refcnt_size;
2298 const int new_max = 16 + (new_fd & ~15);
2301 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2302 old_max, new_fd, new_max);
2304 if (new_fd < old_max) {
2308 assert (new_max > new_fd);
2310 /* Use plain realloc() since we need this memory to be really
2311 * global and visible to all the interpreters and/or threads. */
2312 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2316 MUTEX_UNLOCK(&PL_perlio_mutex);
2318 /* Can't use PerlIO to write as it allocates memory */
2319 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2320 PL_no_mem, strlen(PL_no_mem));
2324 PL_perlio_fd_refcnt_size = new_max;
2325 PL_perlio_fd_refcnt = new_array;
2327 PerlIO_debug("Zeroing %p, %d\n",
2328 (void*)(new_array + old_max),
2331 Zero(new_array + old_max, new_max - old_max, int);
2338 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2339 PERL_UNUSED_CONTEXT;
2343 PerlIOUnix_refcnt_inc(int fd)
2350 MUTEX_LOCK(&PL_perlio_mutex);
2352 if (fd >= PL_perlio_fd_refcnt_size)
2353 S_more_refcounted_fds(aTHX_ fd);
2355 PL_perlio_fd_refcnt[fd]++;
2356 if (PL_perlio_fd_refcnt[fd] <= 0) {
2357 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2358 fd, PL_perlio_fd_refcnt[fd]);
2360 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2361 fd, PL_perlio_fd_refcnt[fd]);
2364 MUTEX_UNLOCK(&PL_perlio_mutex);
2367 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2372 PerlIOUnix_refcnt_dec(int fd)
2379 MUTEX_LOCK(&PL_perlio_mutex);
2381 if (fd >= PL_perlio_fd_refcnt_size) {
2382 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2383 fd, PL_perlio_fd_refcnt_size);
2385 if (PL_perlio_fd_refcnt[fd] <= 0) {
2386 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2387 fd, PL_perlio_fd_refcnt[fd]);
2389 cnt = --PL_perlio_fd_refcnt[fd];
2390 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2392 MUTEX_UNLOCK(&PL_perlio_mutex);
2395 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2401 PerlIO_cleanup(pTHX)
2406 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2408 PerlIO_debug("Cleanup layers\n");
2411 /* Raise STDIN..STDERR refcount so we don't close them */
2412 for (i=0; i < 3; i++)
2413 PerlIOUnix_refcnt_inc(i);
2414 PerlIO_cleantable(aTHX_ &PL_perlio);
2415 /* Restore STDIN..STDERR refcount */
2416 for (i=0; i < 3; i++)
2417 PerlIOUnix_refcnt_dec(i);
2419 if (PL_known_layers) {
2420 PerlIO_list_free(aTHX_ PL_known_layers);
2421 PL_known_layers = NULL;
2423 if (PL_def_layerlist) {
2424 PerlIO_list_free(aTHX_ PL_def_layerlist);
2425 PL_def_layerlist = NULL;
2429 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2433 /* XXX we can't rely on an interpreter being present at this late stage,
2434 XXX so we can't use a function like PerlLIO_write that relies on one
2435 being present (at least in win32) :-(.
2440 /* By now all filehandles should have been closed, so any
2441 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2443 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2444 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2445 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2447 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2448 if (PL_perlio_fd_refcnt[i]) {
2450 my_snprintf(buf, sizeof(buf),
2451 "PerlIO_teardown: fd %d refcnt=%d\n",
2452 i, PL_perlio_fd_refcnt[i]);
2453 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2459 /* Not bothering with PL_perlio_mutex since by now
2460 * all the interpreters are gone. */
2461 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2462 && PL_perlio_fd_refcnt) {
2463 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2464 PL_perlio_fd_refcnt = NULL;
2465 PL_perlio_fd_refcnt_size = 0;
2469 /*--------------------------------------------------------------------------------------*/
2471 * Bottom-most level for UNIX-like case
2475 struct _PerlIO base; /* The generic part */
2476 int fd; /* UNIX like file descriptor */
2477 int oflags; /* open/fcntl flags */
2481 PerlIOUnix_oflags(const char *mode)
2484 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2489 if (*++mode == '+') {
2496 oflags = O_CREAT | O_TRUNC;
2497 if (*++mode == '+') {
2506 oflags = O_CREAT | O_APPEND;
2507 if (*++mode == '+') {
2520 else if (*mode == 't') {
2522 oflags &= ~O_BINARY;
2526 * Always open in binary mode
2529 if (*mode || oflags == -1) {
2530 SETERRNO(EINVAL, LIB_INVARG);
2537 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2539 PERL_UNUSED_CONTEXT;
2540 return PerlIOSelf(f, PerlIOUnix)->fd;
2544 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2546 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2549 if (PerlLIO_fstat(fd, &st) == 0) {
2550 if (!S_ISREG(st.st_mode)) {
2551 PerlIO_debug("%d is not regular file\n",fd);
2552 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2555 PerlIO_debug("%d _is_ a regular file\n",fd);
2561 PerlIOUnix_refcnt_inc(fd);
2562 PERL_UNUSED_CONTEXT;
2566 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2568 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2569 if (*PerlIONext(f)) {
2570 /* We never call down so do any pending stuff now */
2571 PerlIO_flush(PerlIONext(f));
2573 * XXX could (or should) we retrieve the oflags from the open file
2574 * handle rather than believing the "mode" we are passed in? XXX
2575 * Should the value on NULL mode be 0 or -1?
2577 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2578 mode ? PerlIOUnix_oflags(mode) : -1);
2580 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2586 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2588 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2590 PERL_UNUSED_CONTEXT;
2591 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2593 SETERRNO(ESPIPE, LIB_INVARG);
2595 SETERRNO(EINVAL, LIB_INVARG);
2599 new_loc = PerlLIO_lseek(fd, offset, whence);
2600 if (new_loc == (Off_t) - 1)
2602 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2607 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2608 IV n, const char *mode, int fd, int imode,
2609 int perm, PerlIO *f, int narg, SV **args)
2611 if (PerlIOValid(f)) {
2612 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2613 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2616 if (*mode == IoTYPE_NUMERIC)
2619 imode = PerlIOUnix_oflags(mode);
2623 const char *path = SvPV_nolen_const(*args);
2624 fd = PerlLIO_open3(path, imode, perm);
2628 if (*mode == IoTYPE_IMPLICIT)
2631 f = PerlIO_allocate(aTHX);
2633 if (!PerlIOValid(f)) {
2634 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2638 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2639 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2640 if (*mode == IoTYPE_APPEND)
2641 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2648 * FIXME: pop layers ???
2656 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2658 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2660 if (flags & PERLIO_DUP_FD) {
2661 fd = PerlLIO_dup(fd);
2664 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2666 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2667 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2676 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2679 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2680 #ifdef PERLIO_STD_SPECIAL
2682 return PERLIO_STD_IN(fd, vbuf, count);
2684 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2685 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2689 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2690 if (len >= 0 || errno != EINTR) {
2692 if (errno != EAGAIN) {
2693 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2696 else if (len == 0 && count != 0) {
2697 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2708 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2711 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2712 #ifdef PERLIO_STD_SPECIAL
2713 if (fd == 1 || fd == 2)
2714 return PERLIO_STD_OUT(fd, vbuf, count);
2717 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2718 if (len >= 0 || errno != EINTR) {
2720 if (errno != EAGAIN) {
2721 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2732 PerlIOUnix_tell(pTHX_ PerlIO *f)
2734 PERL_UNUSED_CONTEXT;
2736 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2740 PerlIOUnix_close(pTHX_ PerlIO *f)
2742 return PerlIOBase_noop_ok(aTHX_ f);
2746 PerlIOUnix_popped(pTHX_ PerlIO *f)
2749 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2751 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2752 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2753 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2758 SETERRNO(EBADF,SS_IVCHAN);
2761 while (PerlLIO_close(fd) != 0) {
2762 if (errno != EINTR) {
2769 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2774 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2775 sizeof(PerlIO_funcs),
2782 PerlIOBase_binmode, /* binmode */
2792 PerlIOBase_noop_ok, /* flush */
2793 PerlIOBase_noop_fail, /* fill */
2796 PerlIOBase_clearerr,
2797 PerlIOBase_setlinebuf,
2798 NULL, /* get_base */
2799 NULL, /* get_bufsiz */
2802 NULL, /* set_ptrcnt */
2805 /*--------------------------------------------------------------------------------------*/
2810 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2811 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2812 broken by the last second glibc 2.3 fix
2814 #define STDIO_BUFFER_WRITABLE
2819 struct _PerlIO base;
2820 FILE *stdio; /* The stream */
2824 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2826 PERL_UNUSED_CONTEXT;
2828 if (PerlIOValid(f)) {
2829 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2831 return PerlSIO_fileno(s);
2838 PerlIOStdio_mode(const char *mode, char *tmode)
2840 char * const ret = tmode;
2846 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2854 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2857 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2858 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2859 if (toptab == tab) {
2860 /* Top is already stdio - pop self (duplicate) and use original */
2861 PerlIO_pop(aTHX_ f);
2864 const int fd = PerlIO_fileno(n);
2867 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2868 mode = PerlIOStdio_mode(mode, tmode)))) {
2869 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2870 /* We never call down so do any pending stuff now */
2871 PerlIO_flush(PerlIONext(f));
2878 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2883 PerlIO_importFILE(FILE *stdio, const char *mode)
2889 if (!mode || !*mode) {
2890 /* We need to probe to see how we can open the stream
2891 so start with read/write and then try write and read
2892 we dup() so that we can fclose without loosing the fd.
2894 Note that the errno value set by a failing fdopen
2895 varies between stdio implementations.
2897 const int fd = PerlLIO_dup(fileno(stdio));
2898 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2900 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2903 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2906 /* Don't seem to be able to open */
2912 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2913 s = PerlIOSelf(f, PerlIOStdio);
2915 PerlIOUnix_refcnt_inc(fileno(stdio));
2922 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2923 IV n, const char *mode, int fd, int imode,
2924 int perm, PerlIO *f, int narg, SV **args)
2927 if (PerlIOValid(f)) {
2928 const char * const path = SvPV_nolen_const(*args);
2929 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2931 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2932 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2937 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2942 const char * const path = SvPV_nolen_const(*args);
2943 if (*mode == IoTYPE_NUMERIC) {
2945 fd = PerlLIO_open3(path, imode, perm);
2949 bool appended = FALSE;
2951 /* Cygwin wants its 'b' early. */
2953 mode = PerlIOStdio_mode(mode, tmode);
2955 stdio = PerlSIO_fopen(path, mode);
2958 f = PerlIO_allocate(aTHX);
2961 mode = PerlIOStdio_mode(mode, tmode);
2962 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2964 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2965 PerlIOUnix_refcnt_inc(fileno(stdio));
2967 PerlSIO_fclose(stdio);
2979 if (*mode == IoTYPE_IMPLICIT) {
2986 stdio = PerlSIO_stdin;
2989 stdio = PerlSIO_stdout;
2992 stdio = PerlSIO_stderr;
2997 stdio = PerlSIO_fdopen(fd, mode =
2998 PerlIOStdio_mode(mode, tmode));
3002 f = PerlIO_allocate(aTHX);
3004 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3005 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3006 PerlIOUnix_refcnt_inc(fileno(stdio));
3016 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3018 /* This assumes no layers underneath - which is what
3019 happens, but is not how I remember it. NI-S 2001/10/16
3021 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3022 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3023 const int fd = fileno(stdio);
3025 if (flags & PERLIO_DUP_FD) {
3026 const int dfd = PerlLIO_dup(fileno(stdio));
3028 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3033 /* FIXME: To avoid messy error recovery if dup fails
3034 re-use the existing stdio as though flag was not set
3038 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3040 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3041 PerlIOUnix_refcnt_inc(fileno(stdio));
3047 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3049 PERL_UNUSED_CONTEXT;
3051 /* XXX this could use PerlIO_canset_fileno() and
3052 * PerlIO_set_fileno() support from Configure
3054 # if defined(__UCLIBC__)
3055 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3058 # elif defined(__GLIBC__)
3059 /* There may be a better way for GLIBC:
3060 - libio.h defines a flag to not close() on cleanup
3064 # elif defined(__sun__)
3067 # elif defined(__hpux)
3071 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3072 your platform does not have special entry try this one.
3073 [For OSF only have confirmation for Tru64 (alpha)
3074 but assume other OSFs will be similar.]
3076 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3079 # elif defined(__FreeBSD__)
3080 /* There may be a better way on FreeBSD:
3081 - we could insert a dummy func in the _close function entry
3082 f->_close = (int (*)(void *)) dummy_close;
3086 # elif defined(__OpenBSD__)
3087 /* There may be a better way on OpenBSD:
3088 - we could insert a dummy func in the _close function entry
3089 f->_close = (int (*)(void *)) dummy_close;
3093 # elif defined(__EMX__)
3094 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3097 # elif defined(__CYGWIN__)
3098 /* There may be a better way on CYGWIN:
3099 - we could insert a dummy func in the _close function entry
3100 f->_close = (int (*)(void *)) dummy_close;
3104 # elif defined(WIN32)
3105 # if defined(__BORLANDC__)
3106 f->fd = PerlLIO_dup(fileno(f));
3107 # elif defined(UNDER_CE)
3108 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3117 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3118 (which isn't thread safe) instead
3120 # error "Don't know how to set FILE.fileno on your platform"
3128 PerlIOStdio_close(pTHX_ PerlIO *f)
3130 return PerlIOBase_noop_ok(aTHX_ f);
3134 PerlIOStdio_popped(pTHX_ PerlIO *f)
3136 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3142 const int fd = fileno(stdio);
3150 #ifdef SOCKS5_VERSION_NAME
3151 /* Socks lib overrides close() but stdio isn't linked to
3152 that library (though we are) - so we must call close()
3153 on sockets on stdio's behalf.
3156 Sock_size_t optlen = sizeof(int);
3157 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3160 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3161 that a subsequent fileno() on it returns -1. Don't want to croak()
3162 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3163 trying to close an already closed handle which somehow it still has
3164 a reference to. (via.xs, I'm looking at you). */
3165 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3166 /* File descriptor still in use */
3170 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3171 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3173 if (stdio == stdout || stdio == stderr)
3174 return PerlIO_flush(f);
3175 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3176 Use Sarathy's trick from maint-5.6 to invalidate the
3177 fileno slot of the FILE *
3179 result = PerlIO_flush(f);
3181 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3184 MUTEX_LOCK(&PL_perlio_mutex);
3185 /* Right. We need a mutex here because for a brief while we
3186 will have the situation that fd is actually closed. Hence if
3187 a second thread were to get into this block, its dup() would
3188 likely return our fd as its dupfd. (after all, it is closed)
3189 Then if we get to the dup2() first, we blat the fd back
3190 (messing up its temporary as a side effect) only for it to
3191 then close its dupfd (== our fd) in its close(dupfd) */
3193 /* There is, of course, a race condition, that any other thread
3194 trying to input/output/whatever on this fd will be stuffed
3195 for the duration of this little manoeuvrer. Perhaps we
3196 should hold an IO mutex for the duration of every IO
3197 operation if we know that invalidate doesn't work on this
3198 platform, but that would suck, and could kill performance.
3200 Except that correctness trumps speed.
3201 Advice from klortho #11912. */
3203 dupfd = PerlLIO_dup(fd);
3206 MUTEX_UNLOCK(&PL_perlio_mutex);
3207 /* Oh cXap. This isn't going to go well. Not sure if we can
3208 recover from here, or if closing this particular FILE *
3209 is a good idea now. */
3214 result = PerlSIO_fclose(stdio);
3215 /* We treat error from stdio as success if we invalidated
3216 errno may NOT be expected EBADF
3218 if (invalidate && result != 0) {
3222 #ifdef SOCKS5_VERSION_NAME
3223 /* in SOCKS' case, let close() determine return value */
3227 PerlLIO_dup2(dupfd,fd);
3228 PerlLIO_close(dupfd);
3230 MUTEX_UNLOCK(&PL_perlio_mutex);
3238 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3241 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3245 STDCHAR *buf = (STDCHAR *) vbuf;
3247 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3248 * stdio does not do that for fread()
3250 const int ch = PerlSIO_fgetc(s);
3257 got = PerlSIO_fread(vbuf, 1, count, s);
3258 if (got == 0 && PerlSIO_ferror(s))
3260 if (got >= 0 || errno != EINTR)
3263 SETERRNO(0,0); /* just in case */
3269 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3272 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3274 #ifdef STDIO_BUFFER_WRITABLE
3275 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3276 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3277 STDCHAR *base = PerlIO_get_base(f);
3278 SSize_t cnt = PerlIO_get_cnt(f);
3279 STDCHAR *ptr = PerlIO_get_ptr(f);
3280 SSize_t avail = ptr - base;
3282 if (avail > count) {
3286 Move(buf-avail,ptr,avail,STDCHAR);
3289 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3290 if (PerlSIO_feof(s) && unread >= 0)
3291 PerlSIO_clearerr(s);
3296 if (PerlIO_has_cntptr(f)) {
3297 /* We can get pointer to buffer but not its base
3298 Do ungetc() but check chars are ending up in the
3301 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3302 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3304 const int ch = *--buf & 0xFF;
3305 if (ungetc(ch,s) != ch) {
3306 /* ungetc did not work */
3309 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3310 /* Did not change pointer as expected */
3311 fgetc(s); /* get char back again */
3321 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3327 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3332 got = PerlSIO_fwrite(vbuf, 1, count,
3333 PerlIOSelf(f, PerlIOStdio)->stdio);
3334 if (got >= 0 || errno != EINTR)
3337 SETERRNO(0,0); /* just in case */
3343 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3345 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3346 PERL_UNUSED_CONTEXT;
3348 return PerlSIO_fseek(stdio, offset, whence);
3352 PerlIOStdio_tell(pTHX_ PerlIO *f)
3354 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3355 PERL_UNUSED_CONTEXT;
3357 return PerlSIO_ftell(stdio);
3361 PerlIOStdio_flush(pTHX_ PerlIO *f)
3363 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3364 PERL_UNUSED_CONTEXT;
3366 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3367 return PerlSIO_fflush(stdio);
3373 * FIXME: This discards ungetc() and pre-read stuff which is not
3374 * right if this is just a "sync" from a layer above Suspect right
3375 * design is to do _this_ but not have layer above flush this
3376 * layer read-to-read
3379 * Not writeable - sync by attempting a seek
3381 const int err = errno;
3382 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3390 PerlIOStdio_eof(pTHX_ PerlIO *f)
3392 PERL_UNUSED_CONTEXT;
3394 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3398 PerlIOStdio_error(pTHX_ PerlIO *f)
3400 PERL_UNUSED_CONTEXT;
3402 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3406 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3408 PERL_UNUSED_CONTEXT;
3410 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3414 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3416 PERL_UNUSED_CONTEXT;
3418 #ifdef HAS_SETLINEBUF
3419 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3421 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3427 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3429 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3430 return (STDCHAR*)PerlSIO_get_base(stdio);
3434 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3436 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3437 return PerlSIO_get_bufsiz(stdio);
3441 #ifdef USE_STDIO_PTR
3443 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3445 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3446 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3450 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3452 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3453 return PerlSIO_get_cnt(stdio);
3457 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3459 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3461 #ifdef STDIO_PTR_LVALUE
3462 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3463 #ifdef STDIO_PTR_LVAL_SETS_CNT
3464 assert(PerlSIO_get_cnt(stdio) == (cnt));
3466 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3468 * Setting ptr _does_ change cnt - we are done
3472 #else /* STDIO_PTR_LVALUE */
3474 #endif /* STDIO_PTR_LVALUE */
3477 * Now (or only) set cnt
3479 #ifdef STDIO_CNT_LVALUE
3480 PerlSIO_set_cnt(stdio, cnt);
3481 #else /* STDIO_CNT_LVALUE */
3482 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3483 PerlSIO_set_ptr(stdio,
3484 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3486 #else /* STDIO_PTR_LVAL_SETS_CNT */
3488 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3489 #endif /* STDIO_CNT_LVALUE */
3496 PerlIOStdio_fill(pTHX_ PerlIO *f)
3498 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3500 PERL_UNUSED_CONTEXT;
3503 * fflush()ing read-only streams can cause trouble on some stdio-s
3505 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3506 if (PerlSIO_fflush(stdio) != 0)
3510 c = PerlSIO_fgetc(stdio);
3513 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3519 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3521 #ifdef STDIO_BUFFER_WRITABLE
3522 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3523 /* Fake ungetc() to the real buffer in case system's ungetc
3526 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3527 SSize_t cnt = PerlSIO_get_cnt(stdio);
3528 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3529 if (ptr == base+1) {
3530 *--ptr = (STDCHAR) c;
3531 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3532 if (PerlSIO_feof(stdio))
3533 PerlSIO_clearerr(stdio);
3539 if (PerlIO_has_cntptr(f)) {
3541 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3548 /* An ungetc()d char is handled separately from the regular
3549 * buffer, so we stuff it in the buffer ourselves.
3550 * Should never get called as should hit code above
3552 *(--((*stdio)->_ptr)) = (unsigned char) c;
3555 /* If buffer snoop scheme above fails fall back to
3558 if (PerlSIO_ungetc(c, stdio) != c)
3566 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3567 sizeof(PerlIO_funcs),
3569 sizeof(PerlIOStdio),
3570 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3574 PerlIOBase_binmode, /* binmode */
3588 PerlIOStdio_clearerr,
3589 PerlIOStdio_setlinebuf,
3591 PerlIOStdio_get_base,
3592 PerlIOStdio_get_bufsiz,
3597 #ifdef USE_STDIO_PTR
3598 PerlIOStdio_get_ptr,
3599 PerlIOStdio_get_cnt,
3600 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3601 PerlIOStdio_set_ptrcnt,
3604 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3609 #endif /* USE_STDIO_PTR */
3612 /* Note that calls to PerlIO_exportFILE() are reversed using
3613 * PerlIO_releaseFILE(), not importFILE. */
3615 PerlIO_exportFILE(PerlIO * f, const char *mode)
3619 if (PerlIOValid(f)) {
3622 if (!mode || !*mode) {
3623 mode = PerlIO_modestr(f, buf);
3625 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3629 /* De-link any lower layers so new :stdio sticks */
3631 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3632 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3634 PerlIOUnix_refcnt_inc(fileno(stdio));
3635 /* Link previous lower layers under new one */
3639 /* restore layers list */
3649 PerlIO_findFILE(PerlIO *f)
3654 if (l->tab == &PerlIO_stdio) {
3655 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3658 l = *PerlIONext(&l);
3660 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3661 /* However, we're not really exporting a FILE * to someone else (who
3662 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3663 So we need to undo its refernce count increase on the underlying file
3664 descriptor. We have to do this, because if the loop above returns you
3665 the FILE *, then *it* didn't increase any reference count. So there's
3666 only one way to be consistent. */
3667 stdio = PerlIO_exportFILE(f, NULL);
3669 const int fd = fileno(stdio);
3671 PerlIOUnix_refcnt_dec(fd);
3676 /* Use this to reverse PerlIO_exportFILE calls. */
3678 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3683 if (l->tab == &PerlIO_stdio) {
3684 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3685 if (s->stdio == f) {
3687 const int fd = fileno(f);
3689 PerlIOUnix_refcnt_dec(fd);
3690 PerlIO_pop(aTHX_ p);
3699 /*--------------------------------------------------------------------------------------*/
3701 * perlio buffer layer
3705 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3707 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3708 const int fd = PerlIO_fileno(f);
3709 if (fd >= 0 && PerlLIO_isatty(fd)) {
3710 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3712 if (*PerlIONext(f)) {
3713 const Off_t posn = PerlIO_tell(PerlIONext(f));
3714 if (posn != (Off_t) - 1) {
3718 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3722 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3723 IV n, const char *mode, int fd, int imode, int perm,
3724 PerlIO *f, int narg, SV **args)
3726 if (PerlIOValid(f)) {
3727 PerlIO *next = PerlIONext(f);
3729 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3730 if (tab && tab->Open)
3732 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3734 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3739 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3741 if (*mode == IoTYPE_IMPLICIT) {
3747 if (tab && tab->Open)
3748 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3751 SETERRNO(EINVAL, LIB_INVARG);
3753 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3755 * if push fails during open, open fails. close will pop us.
3760 fd = PerlIO_fileno(f);
3761 if (init && fd == 2) {
3763 * Initial stderr is unbuffered
3765 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3767 #ifdef PERLIO_USING_CRLF
3768 # ifdef PERLIO_IS_BINMODE_FD
3769 if (PERLIO_IS_BINMODE_FD(fd))
3770 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3774 * do something about failing setmode()? --jhi
3776 PerlLIO_setmode(fd, O_BINARY);
3785 * This "flush" is akin to sfio's sync in that it handles files in either
3786 * read or write state. For write state, we put the postponed data through
3787 * the next layers. For read state, we seek() the next layers to the
3788 * offset given by current position in the buffer, and discard the buffer
3789 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3790 * in any case?). Then the pass the stick further in chain.
3793 PerlIOBuf_flush(pTHX_ PerlIO *f)
3795 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3797 PerlIO *n = PerlIONext(f);
3798 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3800 * write() the buffer
3802 const STDCHAR *buf = b->buf;
3803 const STDCHAR *p = buf;
3804 while (p < b->ptr) {
3805 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3809 else if (count < 0 || PerlIO_error(n)) {
3810 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3815 b->posn += (p - buf);
3817 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3818 STDCHAR *buf = PerlIO_get_base(f);
3820 * Note position change
3822 b->posn += (b->ptr - buf);
3823 if (b->ptr < b->end) {
3824 /* We did not consume all of it - try and seek downstream to
3825 our logical position
3827 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3828 /* Reload n as some layers may pop themselves on seek */
3829 b->posn = PerlIO_tell(n = PerlIONext(f));
3832 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3833 data is lost for good - so return saying "ok" having undone
3836 b->posn -= (b->ptr - buf);
3841 b->ptr = b->end = b->buf;
3842 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3843 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3844 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3849 /* This discards the content of the buffer after b->ptr, and rereads
3850 * the buffer from the position off in the layer downstream; here off
3851 * is at offset corresponding to b->ptr - b->buf.
3854 PerlIOBuf_fill(pTHX_ PerlIO *f)
3856 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3857 PerlIO *n = PerlIONext(f);
3860 * Down-stream flush is defined not to loose read data so is harmless.
3861 * we would not normally be fill'ing if there was data left in anycase.
3863 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3865 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3866 PerlIOBase_flush_linebuf(aTHX);
3869 PerlIO_get_base(f); /* allocate via vtable */
3871 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3873 b->ptr = b->end = b->buf;
3875 if (!PerlIOValid(n)) {
3876 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3880 if (PerlIO_fast_gets(n)) {
3882 * Layer below is also buffered. We do _NOT_ want to call its
3883 * ->Read() because that will loop till it gets what we asked for
3884 * which may hang on a pipe etc. Instead take anything it has to
3885 * hand, or ask it to fill _once_.
3887 avail = PerlIO_get_cnt(n);
3889 avail = PerlIO_fill(n);
3891 avail = PerlIO_get_cnt(n);
3893 if (!PerlIO_error(n) && PerlIO_eof(n))
3898 STDCHAR *ptr = PerlIO_get_ptr(n);
3899 const SSize_t cnt = avail;
3900 if (avail > (SSize_t)b->bufsiz)
3902 Copy(ptr, b->buf, avail, STDCHAR);
3903 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3907 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3911 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3913 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3916 b->end = b->buf + avail;
3917 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3922 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3924 if (PerlIOValid(f)) {
3925 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3928 return PerlIOBase_read(aTHX_ f, vbuf, count);
3934 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3936 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3937 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3940 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3945 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3947 * Buffer is already a read buffer, we can overwrite any chars
3948 * which have been read back to buffer start
3950 avail = (b->ptr - b->buf);
3954 * Buffer is idle, set it up so whole buffer is available for
3958 b->end = b->buf + avail;
3960 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3962 * Buffer extends _back_ from where we are now
3964 b->posn -= b->bufsiz;
3966 if (avail > (SSize_t) count) {
3968 * If we have space for more than count, just move count
3976 * In simple stdio-like ungetc() case chars will be already
3979 if (buf != b->ptr) {
3980 Copy(buf, b->ptr, avail, STDCHAR);
3984 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3988 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3994 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3996 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3997 const STDCHAR *buf = (const STDCHAR *) vbuf;
3998 const STDCHAR *flushptr = buf;
4002 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4004 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4005 if (PerlIO_flush(f) != 0) {
4009 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4010 flushptr = buf + count;
4011 while (flushptr > buf && *(flushptr - 1) != '\n')
4015 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4016 if ((SSize_t) count < avail)
4018 if (flushptr > buf && flushptr <= buf + avail)
4019 avail = flushptr - buf;
4020 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4022 Copy(buf, b->ptr, avail, STDCHAR);
4027 if (buf == flushptr)
4030 if (b->ptr >= (b->buf + b->bufsiz))
4033 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4039 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4042 if ((code = PerlIO_flush(f)) == 0) {
4043 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4044 code = PerlIO_seek(PerlIONext(f), offset, whence);
4046 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4047 b->posn = PerlIO_tell(PerlIONext(f));
4054 PerlIOBuf_tell(pTHX_ PerlIO *f)
4056 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4058 * b->posn is file position where b->buf was read, or will be written
4060 Off_t posn = b->posn;
4061 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4062 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4064 /* As O_APPEND files are normally shared in some sense it is better
4069 /* when file is NOT shared then this is sufficient */
4070 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4072 posn = b->posn = PerlIO_tell(PerlIONext(f));
4076 * If buffer is valid adjust position by amount in buffer
4078 posn += (b->ptr - b->buf);
4084 PerlIOBuf_popped(pTHX_ PerlIO *f)
4086 const IV code = PerlIOBase_popped(aTHX_ f);
4087 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4088 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4091 b->ptr = b->end = b->buf = NULL;
4092 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4097 PerlIOBuf_close(pTHX_ PerlIO *f)
4099 const IV code = PerlIOBase_close(aTHX_ f);
4100 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4101 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4104 b->ptr = b->end = b->buf = NULL;
4105 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4110 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4112 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4119 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4121 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4124 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4125 return (b->end - b->ptr);
4130 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4132 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4133 PERL_UNUSED_CONTEXT;
4138 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4140 b->buf = (STDCHAR *) & b->oneword;
4141 b->bufsiz = sizeof(b->oneword);
4143 b->end = b->ptr = b->buf;
4149 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4151 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4154 return (b->end - b->buf);
4158 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4160 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4162 PERL_UNUSED_ARG(cnt);
4167 assert(PerlIO_get_cnt(f) == cnt);
4168 assert(b->ptr >= b->buf);
4169 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4173 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4175 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4180 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4181 sizeof(PerlIO_funcs),
4184 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4188 PerlIOBase_binmode, /* binmode */
4202 PerlIOBase_clearerr,
4203 PerlIOBase_setlinebuf,
4208 PerlIOBuf_set_ptrcnt,
4211 /*--------------------------------------------------------------------------------------*/
4213 * Temp layer to hold unread chars when cannot do it any other way
4217 PerlIOPending_fill(pTHX_ PerlIO *f)
4220 * Should never happen
4227 PerlIOPending_close(pTHX_ PerlIO *f)
4230 * A tad tricky - flush pops us, then we close new top
4233 return PerlIO_close(f);
4237 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4240 * A tad tricky - flush pops us, then we seek new top
4243 return PerlIO_seek(f, offset, whence);
4248 PerlIOPending_flush(pTHX_ PerlIO *f)
4250 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4251 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4255 PerlIO_pop(aTHX_ f);
4260 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4266 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4271 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4273 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4274 PerlIOl * const l = PerlIOBase(f);
4276 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4277 * etc. get muddled when it changes mid-string when we auto-pop.
4279 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4280 (PerlIOBase(PerlIONext(f))->
4281 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4286 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4288 SSize_t avail = PerlIO_get_cnt(f);
4290 if ((SSize_t)count < avail)
4293 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4294 if (got >= 0 && got < (SSize_t)count) {
4295 const SSize_t more =
4296 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4297 if (more >= 0 || got == 0)
4303 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4304 sizeof(PerlIO_funcs),
4307 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4308 PerlIOPending_pushed,
4311 PerlIOBase_binmode, /* binmode */
4320 PerlIOPending_close,
4321 PerlIOPending_flush,
4325 PerlIOBase_clearerr,
4326 PerlIOBase_setlinebuf,
4331 PerlIOPending_set_ptrcnt,
4336 /*--------------------------------------------------------------------------------------*/
4338 * crlf - translation On read translate CR,LF to "\n" we do this by
4339 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4340 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4342 * c->nl points on the first byte of CR LF pair when it is temporarily
4343 * replaced by LF, or to the last CR of the buffer. In the former case
4344 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4345 * that it ends at c->nl; these two cases can be distinguished by
4346 * *c->nl. c->nl is set during _getcnt() call, and unset during
4347 * _unread() and _flush() calls.
4348 * It only matters for read operations.
4352 PerlIOBuf base; /* PerlIOBuf stuff */
4353 STDCHAR *nl; /* Position of crlf we "lied" about in the
4357 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4358 * Otherwise the :crlf layer would always revert back to
4362 S_inherit_utf8_flag(PerlIO *f)
4364 PerlIO *g = PerlIONext(f);
4365 if (PerlIOValid(g)) {
4366 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4367 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4373 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4376 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4377 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4379 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4380 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4381 PerlIOBase(f)->flags);
4384 /* Enable the first CRLF capable layer you can find, but if none
4385 * found, the one we just pushed is fine. This results in at
4386 * any given moment at most one CRLF-capable layer being enabled
4387 * in the whole layer stack. */
4388 PerlIO *g = PerlIONext(f);
4389 while (PerlIOValid(g)) {
4390 PerlIOl *b = PerlIOBase(g);
4391 if (b && b->tab == &PerlIO_crlf) {
4392 if (!(b->flags & PERLIO_F_CRLF))
4393 b->flags |= PERLIO_F_CRLF;
4394 S_inherit_utf8_flag(g);
4395 PerlIO_pop(aTHX_ f);
4401 S_inherit_utf8_flag(f);
4407 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4409 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4410 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4414 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4415 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4417 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4418 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4420 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4425 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4426 b->end = b->ptr = b->buf + b->bufsiz;
4427 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4428 b->posn -= b->bufsiz;
4430 while (count > 0 && b->ptr > b->buf) {
4431 const int ch = *--buf;
4433 if (b->ptr - 2 >= b->buf) {
4440 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4441 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4457 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4459 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4461 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4464 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4465 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4466 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4467 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4469 while (nl < b->end && *nl != 0xd)
4471 if (nl < b->end && *nl == 0xd) {
4473 if (nl + 1 < b->end) {
4480 * Not CR,LF but just CR
4488 * Blast - found CR as last char in buffer
4493 * They may not care, defer work as long as
4497 return (nl - b->ptr);
4501 b->ptr++; /* say we have read it as far as
4502 * flush() is concerned */
4503 b->buf++; /* Leave space in front of buffer */
4504 /* Note as we have moved buf up flush's
4506 will naturally make posn point at CR
4508 b->bufsiz--; /* Buffer is thus smaller */
4509 code = PerlIO_fill(f); /* Fetch some more */
4510 b->bufsiz++; /* Restore size for next time */
4511 b->buf--; /* Point at space */
4512 b->ptr = nl = b->buf; /* Which is what we hand
4514 *nl = 0xd; /* Fill in the CR */
4516 goto test; /* fill() call worked */
4518 * CR at EOF - just fall through
4520 /* Should we clear EOF though ??? */
4525 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4531 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4533 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4534 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4540 if (ptr == b->end && *c->nl == 0xd) {
4541 /* Defered CR at end of buffer case - we lied about count */
4554 * Test code - delete when it works ...
4556 IV flags = PerlIOBase(f)->flags;
4557 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4558 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4559 /* Defered CR at end of buffer case - we lied about count */
4565 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4566 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4567 flags, c->nl, b->end, cnt);
4574 * They have taken what we lied about
4582 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4586 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4588 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4589 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4591 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4592 const STDCHAR *buf = (const STDCHAR *) vbuf;
4593 const STDCHAR * const ebuf = buf + count;
4596 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4598 while (buf < ebuf) {
4599 const STDCHAR * const eptr = b->buf + b->bufsiz;
4600 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4601 while (buf < ebuf && b->ptr < eptr) {
4603 if ((b->ptr + 2) > eptr) {
4611 *(b->ptr)++ = 0xd; /* CR */
4612 *(b->ptr)++ = 0xa; /* LF */
4614 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4621 *(b->ptr)++ = *buf++;
4623 if (b->ptr >= eptr) {
4629 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4631 return (buf - (STDCHAR *) vbuf);
4636 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4638 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4643 return PerlIOBuf_flush(aTHX_ f);
4647 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4649 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4650 /* In text mode - flush any pending stuff and flip it */
4651 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4652 #ifndef PERLIO_USING_CRLF
4653 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4654 PerlIO_pop(aTHX_ f);
4660 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4661 sizeof(PerlIO_funcs),
4664 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4666 PerlIOBuf_popped, /* popped */
4668 PerlIOCrlf_binmode, /* binmode */
4672 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4673 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4674 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4682 PerlIOBase_clearerr,
4683 PerlIOBase_setlinebuf,
4688 PerlIOCrlf_set_ptrcnt,
4692 /*--------------------------------------------------------------------------------------*/
4694 * mmap as "buffer" layer
4698 PerlIOBuf base; /* PerlIOBuf stuff */
4699 Mmap_t mptr; /* Mapped address */
4700 Size_t len; /* mapped length */
4701 STDCHAR *bbuf; /* malloced buffer if map fails */
4705 PerlIOMmap_map(pTHX_ PerlIO *f)
4708 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4709 const IV flags = PerlIOBase(f)->flags;
4713 if (flags & PERLIO_F_CANREAD) {
4714 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4715 const int fd = PerlIO_fileno(f);
4717 code = Fstat(fd, &st);
4718 if (code == 0 && S_ISREG(st.st_mode)) {
4719 SSize_t len = st.st_size - b->posn;
4722 if (PL_mmap_page_size <= 0)
4723 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4727 * This is a hack - should never happen - open should
4730 b->posn = PerlIO_tell(PerlIONext(f));
4732 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4733 len = st.st_size - posn;
4734 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4735 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4736 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4737 madvise(m->mptr, len, MADV_SEQUENTIAL);
4739 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4740 madvise(m->mptr, len, MADV_WILLNEED);
4742 PerlIOBase(f)->flags =
4743 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4744 b->end = ((STDCHAR *) m->mptr) + len;
4745 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4754 PerlIOBase(f)->flags =
4755 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4757 b->ptr = b->end = b->ptr;
4766 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4768 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4771 PerlIOBuf * const b = &m->base;
4773 /* The munmap address argument is tricky: depending on the
4774 * standard it is either "void *" or "caddr_t" (which is
4775 * usually "char *" (signed or unsigned). If we cast it
4776 * to "void *", those that have it caddr_t and an uptight
4777 * C++ compiler, will freak out. But casting it as char*
4778 * should work. Maybe. (Using Mmap_t figured out by
4779 * Configure doesn't always work, apparently.) */
4780 code = munmap((char*)m->mptr, m->len);
4784 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4787 b->ptr = b->end = b->buf;
4788 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4794 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4796 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4797 PerlIOBuf * const b = &m->base;
4798 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4800 * Already have a readbuffer in progress
4806 * We have a write buffer or flushed PerlIOBuf read buffer
4808 m->bbuf = b->buf; /* save it in case we need it again */
4809 b->buf = NULL; /* Clear to trigger below */
4812 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4815 * Map did not work - recover PerlIOBuf buffer if we have one
4820 b->ptr = b->end = b->buf;
4823 return PerlIOBuf_get_base(aTHX_ f);
4827 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4829 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4830 PerlIOBuf * const b = &m->base;
4831 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4833 if (b->ptr && (b->ptr - count) >= b->buf
4834 && memEQ(b->ptr - count, vbuf, count)) {
4836 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4841 * Loose the unwritable mapped buffer
4845 * If flush took the "buffer" see if we have one from before
4847 if (!b->buf && m->bbuf)
4850 PerlIOBuf_get_base(aTHX_ f);
4854 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4858 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4860 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4861 PerlIOBuf * const b = &m->base;
4863 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4865 * No, or wrong sort of, buffer
4868 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4872 * If unmap took the "buffer" see if we have one from before
4874 if (!b->buf && m->bbuf)
4877 PerlIOBuf_get_base(aTHX_ f);
4881 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4885 PerlIOMmap_flush(pTHX_ PerlIO *f)
4887 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4888 PerlIOBuf * const b = &m->base;
4889 IV code = PerlIOBuf_flush(aTHX_ f);
4891 * Now we are "synced" at PerlIOBuf level
4898 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4903 * We seem to have a PerlIOBuf buffer which was not mapped
4904 * remember it in case we need one later
4913 PerlIOMmap_fill(pTHX_ PerlIO *f)
4915 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4916 IV code = PerlIO_flush(f);
4917 if (code == 0 && !b->buf) {
4918 code = PerlIOMmap_map(aTHX_ f);
4920 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4921 code = PerlIOBuf_fill(aTHX_ f);
4927 PerlIOMmap_close(pTHX_ PerlIO *f)
4929 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4930 PerlIOBuf * const b = &m->base;
4931 IV code = PerlIO_flush(f);
4935 b->ptr = b->end = b->buf;
4937 if (PerlIOBuf_close(aTHX_ f) != 0)
4943 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4945 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4949 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4950 sizeof(PerlIO_funcs),
4953 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4957 PerlIOBase_binmode, /* binmode */
4971 PerlIOBase_clearerr,
4972 PerlIOBase_setlinebuf,
4973 PerlIOMmap_get_base,
4977 PerlIOBuf_set_ptrcnt,
4980 #endif /* HAS_MMAP */
4983 Perl_PerlIO_stdin(pTHX)
4987 PerlIO_stdstreams(aTHX);
4989 return &PL_perlio[1];
4993 Perl_PerlIO_stdout(pTHX)
4997 PerlIO_stdstreams(aTHX);
4999 return &PL_perlio[2];
5003 Perl_PerlIO_stderr(pTHX)
5007 PerlIO_stdstreams(aTHX);
5009 return &PL_perlio[3];
5012 /*--------------------------------------------------------------------------------------*/
5015 PerlIO_getname(PerlIO *f, char *buf)
5020 bool exported = FALSE;
5021 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5023 stdio = PerlIO_exportFILE(f,0);
5027 name = fgetname(stdio, buf);
5028 if (exported) PerlIO_releaseFILE(f,stdio);
5033 PERL_UNUSED_ARG(buf);
5034 Perl_croak(aTHX_ "Don't know how to get file name");
5040 /*--------------------------------------------------------------------------------------*/
5042 * Functions which can be called on any kind of PerlIO implemented in
5046 #undef PerlIO_fdopen
5048 PerlIO_fdopen(int fd, const char *mode)
5051 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5056 PerlIO_open(const char *path, const char *mode)
5059 SV *name = sv_2mortal(newSVpv(path, 0));
5060 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5063 #undef Perlio_reopen
5065 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5068 SV *name = sv_2mortal(newSVpv(path,0));
5069 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5074 PerlIO_getc(PerlIO *f)
5078 if ( 1 == PerlIO_read(f, buf, 1) ) {
5079 return (unsigned char) buf[0];
5084 #undef PerlIO_ungetc
5086 PerlIO_ungetc(PerlIO *f, int ch)
5091 if (PerlIO_unread(f, &buf, 1) == 1)
5099 PerlIO_putc(PerlIO *f, int ch)
5103 return PerlIO_write(f, &buf, 1);
5108 PerlIO_puts(PerlIO *f, const char *s)
5111 return PerlIO_write(f, s, strlen(s));
5114 #undef PerlIO_rewind
5116 PerlIO_rewind(PerlIO *f)
5119 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5123 #undef PerlIO_vprintf
5125 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5134 Perl_va_copy(ap, apc);
5135 sv = vnewSVpvf(fmt, &apc);
5137 sv = vnewSVpvf(fmt, &ap);
5139 s = SvPV_const(sv, len);
5140 wrote = PerlIO_write(f, s, len);
5145 #undef PerlIO_printf
5147 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5152 result = PerlIO_vprintf(f, fmt, ap);
5157 #undef PerlIO_stdoutf
5159 PerlIO_stdoutf(const char *fmt, ...)
5165 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5170 #undef PerlIO_tmpfile
5172 PerlIO_tmpfile(void)
5177 const int fd = win32_tmpfd();
5179 f = PerlIO_fdopen(fd, "w+b");
5181 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5182 SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
5184 * I have no idea how portable mkstemp() is ... NI-S
5186 const int fd = mkstemp(SvPVX(sv));
5188 f = PerlIO_fdopen(fd, "w+");
5190 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5191 PerlLIO_unlink(SvPVX_const(sv));
5194 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5195 FILE * const stdio = PerlSIO_tmpfile();
5198 f = PerlIO_fdopen(fileno(stdio), "w+");
5200 # endif /* else HAS_MKSTEMP */
5201 #endif /* else WIN32 */
5208 #endif /* USE_SFIO */
5209 #endif /* PERLIO_IS_STDIO */
5211 /*======================================================================================*/
5213 * Now some functions in terms of above which may be needed even if we are
5214 * not in true PerlIO mode
5217 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5220 const char *direction = NULL;
5223 * Need to supply default layer info from open.pm
5229 if (mode && mode[0] != 'r') {
5230 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5231 direction = "open>";
5233 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5234 direction = "open<";
5239 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5240 0, direction, 5, 0, 0);
5243 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5248 #undef PerlIO_setpos
5250 PerlIO_setpos(PerlIO *f, SV *pos)
5255 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5256 if (f && len == sizeof(Off_t))
5257 return PerlIO_seek(f, *posn, SEEK_SET);
5259 SETERRNO(EINVAL, SS_IVCHAN);
5263 #undef PerlIO_setpos
5265 PerlIO_setpos(PerlIO *f, SV *pos)
5270 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5271 if (f && len == sizeof(Fpos_t)) {
5272 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5273 return fsetpos64(f, fpos);
5275 return fsetpos(f, fpos);
5279 SETERRNO(EINVAL, SS_IVCHAN);
5285 #undef PerlIO_getpos
5287 PerlIO_getpos(PerlIO *f, SV *pos)
5290 Off_t posn = PerlIO_tell(f);
5291 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5292 return (posn == (Off_t) - 1) ? -1 : 0;
5295 #undef PerlIO_getpos
5297 PerlIO_getpos(PerlIO *f, SV *pos)
5302 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5303 code = fgetpos64(f, &fpos);
5305 code = fgetpos(f, &fpos);
5307 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5312 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5315 vprintf(char *pat, char *args)
5317 _doprnt(pat, args, stdout);
5318 return 0; /* wrong, but perl doesn't use the return
5323 vfprintf(FILE *fd, char *pat, char *args)
5325 _doprnt(pat, args, fd);
5326 return 0; /* wrong, but perl doesn't use the return
5332 #ifndef PerlIO_vsprintf
5334 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5337 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5338 PERL_UNUSED_CONTEXT;
5340 #ifndef PERL_MY_VSNPRINTF_GUARDED
5341 if (val < 0 || (n > 0 ? val >= n : 0)) {
5342 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5349 #ifndef PerlIO_sprintf
5351 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5356 result = PerlIO_vsprintf(s, n, fmt, ap);
5364 * c-indentation-style: bsd
5366 * indent-tabs-mode: t
5369 * ex: set ts=8 sts=4 sw=4 noet: