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 = get_cvs("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)) {
1788 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1789 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1792 return (tab->Set_ptrcnt != NULL);
1793 SETERRNO(EINVAL, LIB_INVARG);
1797 SETERRNO(EBADF, SS_IVCHAN);
1803 PerlIO_has_cntptr(PerlIO *f)
1805 if (PerlIOValid(f)) {
1806 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1809 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1810 SETERRNO(EINVAL, LIB_INVARG);
1813 SETERRNO(EBADF, SS_IVCHAN);
1819 PerlIO_canset_cnt(PerlIO *f)
1821 if (PerlIOValid(f)) {
1822 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1825 return (tab->Set_ptrcnt != NULL);
1826 SETERRNO(EINVAL, LIB_INVARG);
1829 SETERRNO(EBADF, SS_IVCHAN);
1835 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1837 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1841 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1843 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1847 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1849 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1853 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1855 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1859 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1861 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1865 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1867 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1871 /*--------------------------------------------------------------------------------------*/
1873 * utf8 and raw dummy layers
1877 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1879 PERL_UNUSED_CONTEXT;
1880 PERL_UNUSED_ARG(mode);
1881 PERL_UNUSED_ARG(arg);
1882 if (PerlIOValid(f)) {
1883 if (tab->kind & PERLIO_K_UTF8)
1884 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1886 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1892 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1893 sizeof(PerlIO_funcs),
1896 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1916 NULL, /* get_base */
1917 NULL, /* get_bufsiz */
1920 NULL, /* set_ptrcnt */
1923 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1924 sizeof(PerlIO_funcs),
1947 NULL, /* get_base */
1948 NULL, /* get_bufsiz */
1951 NULL, /* set_ptrcnt */
1955 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1956 IV n, const char *mode, int fd, int imode, int perm,
1957 PerlIO *old, int narg, SV **args)
1959 PerlIO_funcs * const tab = PerlIO_default_btm();
1960 PERL_UNUSED_ARG(self);
1961 if (tab && tab->Open)
1962 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1964 SETERRNO(EINVAL, LIB_INVARG);
1968 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1969 sizeof(PerlIO_funcs),
1992 NULL, /* get_base */
1993 NULL, /* get_bufsiz */
1996 NULL, /* set_ptrcnt */
1998 /*--------------------------------------------------------------------------------------*/
1999 /*--------------------------------------------------------------------------------------*/
2001 * "Methods" of the "base class"
2005 PerlIOBase_fileno(pTHX_ PerlIO *f)
2007 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2011 PerlIO_modestr(PerlIO * f, char *buf)
2014 if (PerlIOValid(f)) {
2015 const IV flags = PerlIOBase(f)->flags;
2016 if (flags & PERLIO_F_APPEND) {
2018 if (flags & PERLIO_F_CANREAD) {
2022 else if (flags & PERLIO_F_CANREAD) {
2024 if (flags & PERLIO_F_CANWRITE)
2027 else if (flags & PERLIO_F_CANWRITE) {
2029 if (flags & PERLIO_F_CANREAD) {
2033 #ifdef PERLIO_USING_CRLF
2034 if (!(flags & PERLIO_F_CRLF))
2044 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2046 PerlIOl * const l = PerlIOBase(f);
2047 PERL_UNUSED_CONTEXT;
2048 PERL_UNUSED_ARG(arg);
2050 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2051 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2052 if (tab->Set_ptrcnt != NULL)
2053 l->flags |= PERLIO_F_FASTGETS;
2055 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2059 l->flags |= PERLIO_F_CANREAD;
2062 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2065 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2068 SETERRNO(EINVAL, LIB_INVARG);
2074 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2077 l->flags &= ~PERLIO_F_CRLF;
2080 l->flags |= PERLIO_F_CRLF;
2083 SETERRNO(EINVAL, LIB_INVARG);
2090 l->flags |= l->next->flags &
2091 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2096 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2097 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2098 l->flags, PerlIO_modestr(f, temp));
2104 PerlIOBase_popped(pTHX_ PerlIO *f)
2106 PERL_UNUSED_CONTEXT;
2112 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2115 * Save the position as current head considers it
2117 const Off_t old = PerlIO_tell(f);
2118 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2119 PerlIOSelf(f, PerlIOBuf)->posn = old;
2120 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2124 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2126 STDCHAR *buf = (STDCHAR *) vbuf;
2128 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2129 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2130 SETERRNO(EBADF, SS_IVCHAN);
2136 SSize_t avail = PerlIO_get_cnt(f);
2139 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2141 STDCHAR *ptr = PerlIO_get_ptr(f);
2142 Copy(ptr, buf, take, STDCHAR);
2143 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2146 if (avail == 0) /* set_ptrcnt could have reset avail */
2149 if (count > 0 && avail <= 0) {
2150 if (PerlIO_fill(f) != 0)
2155 return (buf - (STDCHAR *) vbuf);
2161 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2163 PERL_UNUSED_CONTEXT;
2169 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2171 PERL_UNUSED_CONTEXT;
2177 PerlIOBase_close(pTHX_ PerlIO *f)
2180 if (PerlIOValid(f)) {
2181 PerlIO *n = PerlIONext(f);
2182 code = PerlIO_flush(f);
2183 PerlIOBase(f)->flags &=
2184 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2185 while (PerlIOValid(n)) {
2186 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2187 if (tab && tab->Close) {
2188 if ((*tab->Close)(aTHX_ n) != 0)
2193 PerlIOBase(n)->flags &=
2194 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2200 SETERRNO(EBADF, SS_IVCHAN);
2206 PerlIOBase_eof(pTHX_ PerlIO *f)
2208 PERL_UNUSED_CONTEXT;
2209 if (PerlIOValid(f)) {
2210 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2216 PerlIOBase_error(pTHX_ PerlIO *f)
2218 PERL_UNUSED_CONTEXT;
2219 if (PerlIOValid(f)) {
2220 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2226 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2228 if (PerlIOValid(f)) {
2229 PerlIO * const n = PerlIONext(f);
2230 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2237 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2239 PERL_UNUSED_CONTEXT;
2240 if (PerlIOValid(f)) {
2241 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2246 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2252 arg = sv_dup(arg, param);
2253 SvREFCNT_inc_simple_void_NN(arg);
2257 return newSVsv(arg);
2260 PERL_UNUSED_ARG(param);
2261 return newSVsv(arg);
2266 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2268 PerlIO * const nexto = PerlIONext(o);
2269 if (PerlIOValid(nexto)) {
2270 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2271 if (tab && tab->Dup)
2272 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2274 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2277 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2280 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2281 self->name, (void*)f, (void*)o, (void*)param);
2283 arg = (*self->Getarg)(aTHX_ o, param, flags);
2284 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2285 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2286 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2293 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2295 /* Must be called with PL_perlio_mutex locked. */
2297 S_more_refcounted_fds(pTHX_ const int new_fd) {
2299 const int old_max = PL_perlio_fd_refcnt_size;
2300 const int new_max = 16 + (new_fd & ~15);
2303 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2304 old_max, new_fd, new_max);
2306 if (new_fd < old_max) {
2310 assert (new_max > new_fd);
2312 /* Use plain realloc() since we need this memory to be really
2313 * global and visible to all the interpreters and/or threads. */
2314 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2318 MUTEX_UNLOCK(&PL_perlio_mutex);
2320 /* Can't use PerlIO to write as it allocates memory */
2321 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2322 PL_no_mem, strlen(PL_no_mem));
2326 PL_perlio_fd_refcnt_size = new_max;
2327 PL_perlio_fd_refcnt = new_array;
2329 PerlIO_debug("Zeroing %p, %d\n",
2330 (void*)(new_array + old_max),
2333 Zero(new_array + old_max, new_max - old_max, int);
2340 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2341 PERL_UNUSED_CONTEXT;
2345 PerlIOUnix_refcnt_inc(int fd)
2352 MUTEX_LOCK(&PL_perlio_mutex);
2354 if (fd >= PL_perlio_fd_refcnt_size)
2355 S_more_refcounted_fds(aTHX_ fd);
2357 PL_perlio_fd_refcnt[fd]++;
2358 if (PL_perlio_fd_refcnt[fd] <= 0) {
2359 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2360 fd, PL_perlio_fd_refcnt[fd]);
2362 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2363 fd, PL_perlio_fd_refcnt[fd]);
2366 MUTEX_UNLOCK(&PL_perlio_mutex);
2369 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2374 PerlIOUnix_refcnt_dec(int fd)
2381 MUTEX_LOCK(&PL_perlio_mutex);
2383 if (fd >= PL_perlio_fd_refcnt_size) {
2384 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2385 fd, PL_perlio_fd_refcnt_size);
2387 if (PL_perlio_fd_refcnt[fd] <= 0) {
2388 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2389 fd, PL_perlio_fd_refcnt[fd]);
2391 cnt = --PL_perlio_fd_refcnt[fd];
2392 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2394 MUTEX_UNLOCK(&PL_perlio_mutex);
2397 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2403 PerlIO_cleanup(pTHX)
2408 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2410 PerlIO_debug("Cleanup layers\n");
2413 /* Raise STDIN..STDERR refcount so we don't close them */
2414 for (i=0; i < 3; i++)
2415 PerlIOUnix_refcnt_inc(i);
2416 PerlIO_cleantable(aTHX_ &PL_perlio);
2417 /* Restore STDIN..STDERR refcount */
2418 for (i=0; i < 3; i++)
2419 PerlIOUnix_refcnt_dec(i);
2421 if (PL_known_layers) {
2422 PerlIO_list_free(aTHX_ PL_known_layers);
2423 PL_known_layers = NULL;
2425 if (PL_def_layerlist) {
2426 PerlIO_list_free(aTHX_ PL_def_layerlist);
2427 PL_def_layerlist = NULL;
2431 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2435 /* XXX we can't rely on an interpreter being present at this late stage,
2436 XXX so we can't use a function like PerlLIO_write that relies on one
2437 being present (at least in win32) :-(.
2442 /* By now all filehandles should have been closed, so any
2443 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2445 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2446 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2447 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2449 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2450 if (PL_perlio_fd_refcnt[i]) {
2452 my_snprintf(buf, sizeof(buf),
2453 "PerlIO_teardown: fd %d refcnt=%d\n",
2454 i, PL_perlio_fd_refcnt[i]);
2455 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2461 /* Not bothering with PL_perlio_mutex since by now
2462 * all the interpreters are gone. */
2463 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2464 && PL_perlio_fd_refcnt) {
2465 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2466 PL_perlio_fd_refcnt = NULL;
2467 PL_perlio_fd_refcnt_size = 0;
2471 /*--------------------------------------------------------------------------------------*/
2473 * Bottom-most level for UNIX-like case
2477 struct _PerlIO base; /* The generic part */
2478 int fd; /* UNIX like file descriptor */
2479 int oflags; /* open/fcntl flags */
2483 PerlIOUnix_oflags(const char *mode)
2486 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2491 if (*++mode == '+') {
2498 oflags = O_CREAT | O_TRUNC;
2499 if (*++mode == '+') {
2508 oflags = O_CREAT | O_APPEND;
2509 if (*++mode == '+') {
2522 else if (*mode == 't') {
2524 oflags &= ~O_BINARY;
2528 * Always open in binary mode
2531 if (*mode || oflags == -1) {
2532 SETERRNO(EINVAL, LIB_INVARG);
2539 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2541 PERL_UNUSED_CONTEXT;
2542 return PerlIOSelf(f, PerlIOUnix)->fd;
2546 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2548 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2551 if (PerlLIO_fstat(fd, &st) == 0) {
2552 if (!S_ISREG(st.st_mode)) {
2553 PerlIO_debug("%d is not regular file\n",fd);
2554 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2557 PerlIO_debug("%d _is_ a regular file\n",fd);
2563 PerlIOUnix_refcnt_inc(fd);
2564 PERL_UNUSED_CONTEXT;
2568 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2570 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2571 if (*PerlIONext(f)) {
2572 /* We never call down so do any pending stuff now */
2573 PerlIO_flush(PerlIONext(f));
2575 * XXX could (or should) we retrieve the oflags from the open file
2576 * handle rather than believing the "mode" we are passed in? XXX
2577 * Should the value on NULL mode be 0 or -1?
2579 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2580 mode ? PerlIOUnix_oflags(mode) : -1);
2582 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2588 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2590 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2592 PERL_UNUSED_CONTEXT;
2593 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2595 SETERRNO(ESPIPE, LIB_INVARG);
2597 SETERRNO(EINVAL, LIB_INVARG);
2601 new_loc = PerlLIO_lseek(fd, offset, whence);
2602 if (new_loc == (Off_t) - 1)
2604 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2609 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2610 IV n, const char *mode, int fd, int imode,
2611 int perm, PerlIO *f, int narg, SV **args)
2613 if (PerlIOValid(f)) {
2614 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2615 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2618 if (*mode == IoTYPE_NUMERIC)
2621 imode = PerlIOUnix_oflags(mode);
2625 const char *path = SvPV_nolen_const(*args);
2626 fd = PerlLIO_open3(path, imode, perm);
2630 if (*mode == IoTYPE_IMPLICIT)
2633 f = PerlIO_allocate(aTHX);
2635 if (!PerlIOValid(f)) {
2636 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2640 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2641 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2642 if (*mode == IoTYPE_APPEND)
2643 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2650 * FIXME: pop layers ???
2658 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2660 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2662 if (flags & PERLIO_DUP_FD) {
2663 fd = PerlLIO_dup(fd);
2666 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2668 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2669 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2678 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2681 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2682 #ifdef PERLIO_STD_SPECIAL
2684 return PERLIO_STD_IN(fd, vbuf, count);
2686 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2687 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2691 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2692 if (len >= 0 || errno != EINTR) {
2694 if (errno != EAGAIN) {
2695 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2698 else if (len == 0 && count != 0) {
2699 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2710 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2713 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2714 #ifdef PERLIO_STD_SPECIAL
2715 if (fd == 1 || fd == 2)
2716 return PERLIO_STD_OUT(fd, vbuf, count);
2719 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2720 if (len >= 0 || errno != EINTR) {
2722 if (errno != EAGAIN) {
2723 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2734 PerlIOUnix_tell(pTHX_ PerlIO *f)
2736 PERL_UNUSED_CONTEXT;
2738 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2743 PerlIOUnix_close(pTHX_ PerlIO *f)
2746 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2748 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2749 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2750 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2755 SETERRNO(EBADF,SS_IVCHAN);
2758 while (PerlLIO_close(fd) != 0) {
2759 if (errno != EINTR) {
2766 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2771 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2772 sizeof(PerlIO_funcs),
2779 PerlIOBase_binmode, /* binmode */
2789 PerlIOBase_noop_ok, /* flush */
2790 PerlIOBase_noop_fail, /* fill */
2793 PerlIOBase_clearerr,
2794 PerlIOBase_setlinebuf,
2795 NULL, /* get_base */
2796 NULL, /* get_bufsiz */
2799 NULL, /* set_ptrcnt */
2802 /*--------------------------------------------------------------------------------------*/
2807 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2808 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2809 broken by the last second glibc 2.3 fix
2811 #define STDIO_BUFFER_WRITABLE
2816 struct _PerlIO base;
2817 FILE *stdio; /* The stream */
2821 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2823 PERL_UNUSED_CONTEXT;
2825 if (PerlIOValid(f)) {
2826 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2828 return PerlSIO_fileno(s);
2835 PerlIOStdio_mode(const char *mode, char *tmode)
2837 char * const ret = tmode;
2843 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2851 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2854 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2855 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2856 if (toptab == tab) {
2857 /* Top is already stdio - pop self (duplicate) and use original */
2858 PerlIO_pop(aTHX_ f);
2861 const int fd = PerlIO_fileno(n);
2864 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2865 mode = PerlIOStdio_mode(mode, tmode)))) {
2866 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2867 /* We never call down so do any pending stuff now */
2868 PerlIO_flush(PerlIONext(f));
2875 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2880 PerlIO_importFILE(FILE *stdio, const char *mode)
2886 if (!mode || !*mode) {
2887 /* We need to probe to see how we can open the stream
2888 so start with read/write and then try write and read
2889 we dup() so that we can fclose without loosing the fd.
2891 Note that the errno value set by a failing fdopen
2892 varies between stdio implementations.
2894 const int fd = PerlLIO_dup(fileno(stdio));
2895 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2897 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2900 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2903 /* Don't seem to be able to open */
2909 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2910 s = PerlIOSelf(f, PerlIOStdio);
2912 PerlIOUnix_refcnt_inc(fileno(stdio));
2919 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2920 IV n, const char *mode, int fd, int imode,
2921 int perm, PerlIO *f, int narg, SV **args)
2924 if (PerlIOValid(f)) {
2925 const char * const path = SvPV_nolen_const(*args);
2926 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2928 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2929 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2934 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2939 const char * const path = SvPV_nolen_const(*args);
2940 if (*mode == IoTYPE_NUMERIC) {
2942 fd = PerlLIO_open3(path, imode, perm);
2946 bool appended = FALSE;
2948 /* Cygwin wants its 'b' early. */
2950 mode = PerlIOStdio_mode(mode, tmode);
2952 stdio = PerlSIO_fopen(path, mode);
2955 f = PerlIO_allocate(aTHX);
2958 mode = PerlIOStdio_mode(mode, tmode);
2959 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2961 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2962 PerlIOUnix_refcnt_inc(fileno(stdio));
2964 PerlSIO_fclose(stdio);
2976 if (*mode == IoTYPE_IMPLICIT) {
2983 stdio = PerlSIO_stdin;
2986 stdio = PerlSIO_stdout;
2989 stdio = PerlSIO_stderr;
2994 stdio = PerlSIO_fdopen(fd, mode =
2995 PerlIOStdio_mode(mode, tmode));
2999 f = PerlIO_allocate(aTHX);
3001 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3002 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3003 PerlIOUnix_refcnt_inc(fileno(stdio));
3013 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3015 /* This assumes no layers underneath - which is what
3016 happens, but is not how I remember it. NI-S 2001/10/16
3018 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3019 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3020 const int fd = fileno(stdio);
3022 if (flags & PERLIO_DUP_FD) {
3023 const int dfd = PerlLIO_dup(fileno(stdio));
3025 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3030 /* FIXME: To avoid messy error recovery if dup fails
3031 re-use the existing stdio as though flag was not set
3035 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3037 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3039 PerlIOUnix_refcnt_inc(fileno(stdio));
3046 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3048 PERL_UNUSED_CONTEXT;
3050 /* XXX this could use PerlIO_canset_fileno() and
3051 * PerlIO_set_fileno() support from Configure
3053 # if defined(__UCLIBC__)
3054 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3057 # elif defined(__GLIBC__)
3058 /* There may be a better way for GLIBC:
3059 - libio.h defines a flag to not close() on cleanup
3063 # elif defined(__sun__)
3066 # elif defined(__hpux)
3070 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3071 your platform does not have special entry try this one.
3072 [For OSF only have confirmation for Tru64 (alpha)
3073 but assume other OSFs will be similar.]
3075 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3078 # elif defined(__FreeBSD__)
3079 /* There may be a better way on FreeBSD:
3080 - we could insert a dummy func in the _close function entry
3081 f->_close = (int (*)(void *)) dummy_close;
3085 # elif defined(__OpenBSD__)
3086 /* There may be a better way on OpenBSD:
3087 - we could insert a dummy func in the _close function entry
3088 f->_close = (int (*)(void *)) dummy_close;
3092 # elif defined(__EMX__)
3093 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3096 # elif defined(__CYGWIN__)
3097 /* There may be a better way on CYGWIN:
3098 - we could insert a dummy func in the _close function entry
3099 f->_close = (int (*)(void *)) dummy_close;
3103 # elif defined(WIN32)
3104 # if defined(__BORLANDC__)
3105 f->fd = PerlLIO_dup(fileno(f));
3106 # elif defined(UNDER_CE)
3107 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3116 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3117 (which isn't thread safe) instead
3119 # error "Don't know how to set FILE.fileno on your platform"
3127 PerlIOStdio_close(pTHX_ PerlIO *f)
3129 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3135 const int fd = fileno(stdio);
3143 #ifdef SOCKS5_VERSION_NAME
3144 /* Socks lib overrides close() but stdio isn't linked to
3145 that library (though we are) - so we must call close()
3146 on sockets on stdio's behalf.
3149 Sock_size_t optlen = sizeof(int);
3150 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3153 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3154 that a subsequent fileno() on it returns -1. Don't want to croak()
3155 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3156 trying to close an already closed handle which somehow it still has
3157 a reference to. (via.xs, I'm looking at you). */
3158 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3159 /* File descriptor still in use */
3163 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3164 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3166 if (stdio == stdout || stdio == stderr)
3167 return PerlIO_flush(f);
3168 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3169 Use Sarathy's trick from maint-5.6 to invalidate the
3170 fileno slot of the FILE *
3172 result = PerlIO_flush(f);
3174 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3177 MUTEX_LOCK(&PL_perlio_mutex);
3178 /* Right. We need a mutex here because for a brief while we
3179 will have the situation that fd is actually closed. Hence if
3180 a second thread were to get into this block, its dup() would
3181 likely return our fd as its dupfd. (after all, it is closed)
3182 Then if we get to the dup2() first, we blat the fd back
3183 (messing up its temporary as a side effect) only for it to
3184 then close its dupfd (== our fd) in its close(dupfd) */
3186 /* There is, of course, a race condition, that any other thread
3187 trying to input/output/whatever on this fd will be stuffed
3188 for the duration of this little manoeuvrer. Perhaps we
3189 should hold an IO mutex for the duration of every IO
3190 operation if we know that invalidate doesn't work on this
3191 platform, but that would suck, and could kill performance.
3193 Except that correctness trumps speed.
3194 Advice from klortho #11912. */
3196 dupfd = PerlLIO_dup(fd);
3199 MUTEX_UNLOCK(&PL_perlio_mutex);
3200 /* Oh cXap. This isn't going to go well. Not sure if we can
3201 recover from here, or if closing this particular FILE *
3202 is a good idea now. */
3207 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3209 result = PerlSIO_fclose(stdio);
3210 /* We treat error from stdio as success if we invalidated
3211 errno may NOT be expected EBADF
3213 if (invalidate && result != 0) {
3217 #ifdef SOCKS5_VERSION_NAME
3218 /* in SOCKS' case, let close() determine return value */
3222 PerlLIO_dup2(dupfd,fd);
3223 PerlLIO_close(dupfd);
3225 MUTEX_UNLOCK(&PL_perlio_mutex);
3233 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3236 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3240 STDCHAR *buf = (STDCHAR *) vbuf;
3242 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3243 * stdio does not do that for fread()
3245 const int ch = PerlSIO_fgetc(s);
3252 got = PerlSIO_fread(vbuf, 1, count, s);
3253 if (got == 0 && PerlSIO_ferror(s))
3255 if (got >= 0 || errno != EINTR)
3258 SETERRNO(0,0); /* just in case */
3264 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3267 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3269 #ifdef STDIO_BUFFER_WRITABLE
3270 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3271 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3272 STDCHAR *base = PerlIO_get_base(f);
3273 SSize_t cnt = PerlIO_get_cnt(f);
3274 STDCHAR *ptr = PerlIO_get_ptr(f);
3275 SSize_t avail = ptr - base;
3277 if (avail > count) {
3281 Move(buf-avail,ptr,avail,STDCHAR);
3284 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3285 if (PerlSIO_feof(s) && unread >= 0)
3286 PerlSIO_clearerr(s);
3291 if (PerlIO_has_cntptr(f)) {
3292 /* We can get pointer to buffer but not its base
3293 Do ungetc() but check chars are ending up in the
3296 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3297 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3299 const int ch = *--buf & 0xFF;
3300 if (ungetc(ch,s) != ch) {
3301 /* ungetc did not work */
3304 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3305 /* Did not change pointer as expected */
3306 fgetc(s); /* get char back again */
3316 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3322 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3327 got = PerlSIO_fwrite(vbuf, 1, count,
3328 PerlIOSelf(f, PerlIOStdio)->stdio);
3329 if (got >= 0 || errno != EINTR)
3332 SETERRNO(0,0); /* just in case */
3338 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3340 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3341 PERL_UNUSED_CONTEXT;
3343 return PerlSIO_fseek(stdio, offset, whence);
3347 PerlIOStdio_tell(pTHX_ PerlIO *f)
3349 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3350 PERL_UNUSED_CONTEXT;
3352 return PerlSIO_ftell(stdio);
3356 PerlIOStdio_flush(pTHX_ PerlIO *f)
3358 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3359 PERL_UNUSED_CONTEXT;
3361 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3362 return PerlSIO_fflush(stdio);
3368 * FIXME: This discards ungetc() and pre-read stuff which is not
3369 * right if this is just a "sync" from a layer above Suspect right
3370 * design is to do _this_ but not have layer above flush this
3371 * layer read-to-read
3374 * Not writeable - sync by attempting a seek
3377 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3385 PerlIOStdio_eof(pTHX_ PerlIO *f)
3387 PERL_UNUSED_CONTEXT;
3389 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3393 PerlIOStdio_error(pTHX_ PerlIO *f)
3395 PERL_UNUSED_CONTEXT;
3397 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3401 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3403 PERL_UNUSED_CONTEXT;
3405 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3409 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3411 PERL_UNUSED_CONTEXT;
3413 #ifdef HAS_SETLINEBUF
3414 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3416 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3422 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3424 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3425 return (STDCHAR*)PerlSIO_get_base(stdio);
3429 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3431 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3432 return PerlSIO_get_bufsiz(stdio);
3436 #ifdef USE_STDIO_PTR
3438 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3440 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3441 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3445 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3447 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3448 return PerlSIO_get_cnt(stdio);
3452 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3454 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3456 #ifdef STDIO_PTR_LVALUE
3457 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3458 #ifdef STDIO_PTR_LVAL_SETS_CNT
3459 assert(PerlSIO_get_cnt(stdio) == (cnt));
3461 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3463 * Setting ptr _does_ change cnt - we are done
3467 #else /* STDIO_PTR_LVALUE */
3469 #endif /* STDIO_PTR_LVALUE */
3472 * Now (or only) set cnt
3474 #ifdef STDIO_CNT_LVALUE
3475 PerlSIO_set_cnt(stdio, cnt);
3476 #else /* STDIO_CNT_LVALUE */
3477 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3478 PerlSIO_set_ptr(stdio,
3479 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3481 #else /* STDIO_PTR_LVAL_SETS_CNT */
3483 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3484 #endif /* STDIO_CNT_LVALUE */
3491 PerlIOStdio_fill(pTHX_ PerlIO *f)
3493 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3495 PERL_UNUSED_CONTEXT;
3498 * fflush()ing read-only streams can cause trouble on some stdio-s
3500 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3501 if (PerlSIO_fflush(stdio) != 0)
3505 c = PerlSIO_fgetc(stdio);
3508 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3514 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3516 #ifdef STDIO_BUFFER_WRITABLE
3517 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3518 /* Fake ungetc() to the real buffer in case system's ungetc
3521 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3522 SSize_t cnt = PerlSIO_get_cnt(stdio);
3523 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3524 if (ptr == base+1) {
3525 *--ptr = (STDCHAR) c;
3526 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3527 if (PerlSIO_feof(stdio))
3528 PerlSIO_clearerr(stdio);
3534 if (PerlIO_has_cntptr(f)) {
3536 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3543 /* An ungetc()d char is handled separately from the regular
3544 * buffer, so we stuff it in the buffer ourselves.
3545 * Should never get called as should hit code above
3547 *(--((*stdio)->_ptr)) = (unsigned char) c;
3550 /* If buffer snoop scheme above fails fall back to
3553 if (PerlSIO_ungetc(c, stdio) != c)
3561 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3562 sizeof(PerlIO_funcs),
3564 sizeof(PerlIOStdio),
3565 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3569 PerlIOBase_binmode, /* binmode */
3583 PerlIOStdio_clearerr,
3584 PerlIOStdio_setlinebuf,
3586 PerlIOStdio_get_base,
3587 PerlIOStdio_get_bufsiz,
3592 #ifdef USE_STDIO_PTR
3593 PerlIOStdio_get_ptr,
3594 PerlIOStdio_get_cnt,
3595 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3596 PerlIOStdio_set_ptrcnt,
3599 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3604 #endif /* USE_STDIO_PTR */
3607 /* Note that calls to PerlIO_exportFILE() are reversed using
3608 * PerlIO_releaseFILE(), not importFILE. */
3610 PerlIO_exportFILE(PerlIO * f, const char *mode)
3614 if (PerlIOValid(f)) {
3617 if (!mode || !*mode) {
3618 mode = PerlIO_modestr(f, buf);
3620 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3624 /* De-link any lower layers so new :stdio sticks */
3626 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3627 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3629 PerlIOUnix_refcnt_inc(fileno(stdio));
3630 /* Link previous lower layers under new one */
3634 /* restore layers list */
3644 PerlIO_findFILE(PerlIO *f)
3649 if (l->tab == &PerlIO_stdio) {
3650 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3653 l = *PerlIONext(&l);
3655 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3656 /* However, we're not really exporting a FILE * to someone else (who
3657 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3658 So we need to undo its refernce count increase on the underlying file
3659 descriptor. We have to do this, because if the loop above returns you
3660 the FILE *, then *it* didn't increase any reference count. So there's
3661 only one way to be consistent. */
3662 stdio = PerlIO_exportFILE(f, NULL);
3664 const int fd = fileno(stdio);
3666 PerlIOUnix_refcnt_dec(fd);
3671 /* Use this to reverse PerlIO_exportFILE calls. */
3673 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3678 if (l->tab == &PerlIO_stdio) {
3679 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3680 if (s->stdio == f) {
3682 const int fd = fileno(f);
3684 PerlIOUnix_refcnt_dec(fd);
3685 PerlIO_pop(aTHX_ p);
3694 /*--------------------------------------------------------------------------------------*/
3696 * perlio buffer layer
3700 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3702 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3703 const int fd = PerlIO_fileno(f);
3704 if (fd >= 0 && PerlLIO_isatty(fd)) {
3705 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3707 if (*PerlIONext(f)) {
3708 const Off_t posn = PerlIO_tell(PerlIONext(f));
3709 if (posn != (Off_t) - 1) {
3713 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3717 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3718 IV n, const char *mode, int fd, int imode, int perm,
3719 PerlIO *f, int narg, SV **args)
3721 if (PerlIOValid(f)) {
3722 PerlIO *next = PerlIONext(f);
3724 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3725 if (tab && tab->Open)
3727 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3729 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3734 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3736 if (*mode == IoTYPE_IMPLICIT) {
3742 if (tab && tab->Open)
3743 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3746 SETERRNO(EINVAL, LIB_INVARG);
3748 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3750 * if push fails during open, open fails. close will pop us.
3755 fd = PerlIO_fileno(f);
3756 if (init && fd == 2) {
3758 * Initial stderr is unbuffered
3760 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3762 #ifdef PERLIO_USING_CRLF
3763 # ifdef PERLIO_IS_BINMODE_FD
3764 if (PERLIO_IS_BINMODE_FD(fd))
3765 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3769 * do something about failing setmode()? --jhi
3771 PerlLIO_setmode(fd, O_BINARY);
3780 * This "flush" is akin to sfio's sync in that it handles files in either
3781 * read or write state. For write state, we put the postponed data through
3782 * the next layers. For read state, we seek() the next layers to the
3783 * offset given by current position in the buffer, and discard the buffer
3784 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3785 * in any case?). Then the pass the stick further in chain.
3788 PerlIOBuf_flush(pTHX_ PerlIO *f)
3790 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3792 PerlIO *n = PerlIONext(f);
3793 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3795 * write() the buffer
3797 const STDCHAR *buf = b->buf;
3798 const STDCHAR *p = buf;
3799 while (p < b->ptr) {
3800 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3804 else if (count < 0 || PerlIO_error(n)) {
3805 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3810 b->posn += (p - buf);
3812 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3813 STDCHAR *buf = PerlIO_get_base(f);
3815 * Note position change
3817 b->posn += (b->ptr - buf);
3818 if (b->ptr < b->end) {
3819 /* We did not consume all of it - try and seek downstream to
3820 our logical position
3822 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3823 /* Reload n as some layers may pop themselves on seek */
3824 b->posn = PerlIO_tell(n = PerlIONext(f));
3827 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3828 data is lost for good - so return saying "ok" having undone
3831 b->posn -= (b->ptr - buf);
3836 b->ptr = b->end = b->buf;
3837 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3838 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3839 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3844 /* This discards the content of the buffer after b->ptr, and rereads
3845 * the buffer from the position off in the layer downstream; here off
3846 * is at offset corresponding to b->ptr - b->buf.
3849 PerlIOBuf_fill(pTHX_ PerlIO *f)
3851 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3852 PerlIO *n = PerlIONext(f);
3855 * Down-stream flush is defined not to loose read data so is harmless.
3856 * we would not normally be fill'ing if there was data left in anycase.
3858 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3860 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3861 PerlIOBase_flush_linebuf(aTHX);
3864 PerlIO_get_base(f); /* allocate via vtable */
3866 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3868 b->ptr = b->end = b->buf;
3870 if (!PerlIOValid(n)) {
3871 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3875 if (PerlIO_fast_gets(n)) {
3877 * Layer below is also buffered. We do _NOT_ want to call its
3878 * ->Read() because that will loop till it gets what we asked for
3879 * which may hang on a pipe etc. Instead take anything it has to
3880 * hand, or ask it to fill _once_.
3882 avail = PerlIO_get_cnt(n);
3884 avail = PerlIO_fill(n);
3886 avail = PerlIO_get_cnt(n);
3888 if (!PerlIO_error(n) && PerlIO_eof(n))
3893 STDCHAR *ptr = PerlIO_get_ptr(n);
3894 const SSize_t cnt = avail;
3895 if (avail > (SSize_t)b->bufsiz)
3897 Copy(ptr, b->buf, avail, STDCHAR);
3898 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3902 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3906 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3908 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3911 b->end = b->buf + avail;
3912 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3917 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3919 if (PerlIOValid(f)) {
3920 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3923 return PerlIOBase_read(aTHX_ f, vbuf, count);
3929 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3931 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3932 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3935 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3940 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3942 * Buffer is already a read buffer, we can overwrite any chars
3943 * which have been read back to buffer start
3945 avail = (b->ptr - b->buf);
3949 * Buffer is idle, set it up so whole buffer is available for
3953 b->end = b->buf + avail;
3955 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3957 * Buffer extends _back_ from where we are now
3959 b->posn -= b->bufsiz;
3961 if (avail > (SSize_t) count) {
3963 * If we have space for more than count, just move count
3971 * In simple stdio-like ungetc() case chars will be already
3974 if (buf != b->ptr) {
3975 Copy(buf, b->ptr, avail, STDCHAR);
3979 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3983 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3989 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3991 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3992 const STDCHAR *buf = (const STDCHAR *) vbuf;
3993 const STDCHAR *flushptr = buf;
3997 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3999 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4000 if (PerlIO_flush(f) != 0) {
4004 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4005 flushptr = buf + count;
4006 while (flushptr > buf && *(flushptr - 1) != '\n')
4010 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4011 if ((SSize_t) count < avail)
4013 if (flushptr > buf && flushptr <= buf + avail)
4014 avail = flushptr - buf;
4015 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4017 Copy(buf, b->ptr, avail, STDCHAR);
4022 if (buf == flushptr)
4025 if (b->ptr >= (b->buf + b->bufsiz))
4028 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4034 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4037 if ((code = PerlIO_flush(f)) == 0) {
4038 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4039 code = PerlIO_seek(PerlIONext(f), offset, whence);
4041 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4042 b->posn = PerlIO_tell(PerlIONext(f));
4049 PerlIOBuf_tell(pTHX_ PerlIO *f)
4051 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4053 * b->posn is file position where b->buf was read, or will be written
4055 Off_t posn = b->posn;
4056 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4057 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4059 /* As O_APPEND files are normally shared in some sense it is better
4064 /* when file is NOT shared then this is sufficient */
4065 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4067 posn = b->posn = PerlIO_tell(PerlIONext(f));
4071 * If buffer is valid adjust position by amount in buffer
4073 posn += (b->ptr - b->buf);
4079 PerlIOBuf_popped(pTHX_ PerlIO *f)
4081 const IV code = PerlIOBase_popped(aTHX_ f);
4082 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4083 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4086 b->ptr = b->end = b->buf = NULL;
4087 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4092 PerlIOBuf_close(pTHX_ PerlIO *f)
4094 const IV code = PerlIOBase_close(aTHX_ f);
4095 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4096 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4099 b->ptr = b->end = b->buf = NULL;
4100 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4105 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4107 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4114 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4116 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4119 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4120 return (b->end - b->ptr);
4125 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4127 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4128 PERL_UNUSED_CONTEXT;
4133 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4135 b->buf = (STDCHAR *) & b->oneword;
4136 b->bufsiz = sizeof(b->oneword);
4138 b->end = b->ptr = b->buf;
4144 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4146 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4149 return (b->end - b->buf);
4153 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4155 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4157 PERL_UNUSED_ARG(cnt);
4162 assert(PerlIO_get_cnt(f) == cnt);
4163 assert(b->ptr >= b->buf);
4164 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4168 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4170 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4175 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4176 sizeof(PerlIO_funcs),
4179 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4183 PerlIOBase_binmode, /* binmode */
4197 PerlIOBase_clearerr,
4198 PerlIOBase_setlinebuf,
4203 PerlIOBuf_set_ptrcnt,
4206 /*--------------------------------------------------------------------------------------*/
4208 * Temp layer to hold unread chars when cannot do it any other way
4212 PerlIOPending_fill(pTHX_ PerlIO *f)
4215 * Should never happen
4222 PerlIOPending_close(pTHX_ PerlIO *f)
4225 * A tad tricky - flush pops us, then we close new top
4228 return PerlIO_close(f);
4232 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4235 * A tad tricky - flush pops us, then we seek new top
4238 return PerlIO_seek(f, offset, whence);
4243 PerlIOPending_flush(pTHX_ PerlIO *f)
4245 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4246 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4250 PerlIO_pop(aTHX_ f);
4255 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4261 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4266 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4268 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4269 PerlIOl * const l = PerlIOBase(f);
4271 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4272 * etc. get muddled when it changes mid-string when we auto-pop.
4274 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4275 (PerlIOBase(PerlIONext(f))->
4276 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4281 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4283 SSize_t avail = PerlIO_get_cnt(f);
4285 if ((SSize_t)count < avail)
4288 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4289 if (got >= 0 && got < (SSize_t)count) {
4290 const SSize_t more =
4291 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4292 if (more >= 0 || got == 0)
4298 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4299 sizeof(PerlIO_funcs),
4302 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4303 PerlIOPending_pushed,
4306 PerlIOBase_binmode, /* binmode */
4315 PerlIOPending_close,
4316 PerlIOPending_flush,
4320 PerlIOBase_clearerr,
4321 PerlIOBase_setlinebuf,
4326 PerlIOPending_set_ptrcnt,
4331 /*--------------------------------------------------------------------------------------*/
4333 * crlf - translation On read translate CR,LF to "\n" we do this by
4334 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4335 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4337 * c->nl points on the first byte of CR LF pair when it is temporarily
4338 * replaced by LF, or to the last CR of the buffer. In the former case
4339 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4340 * that it ends at c->nl; these two cases can be distinguished by
4341 * *c->nl. c->nl is set during _getcnt() call, and unset during
4342 * _unread() and _flush() calls.
4343 * It only matters for read operations.
4347 PerlIOBuf base; /* PerlIOBuf stuff */
4348 STDCHAR *nl; /* Position of crlf we "lied" about in the
4352 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4353 * Otherwise the :crlf layer would always revert back to
4357 S_inherit_utf8_flag(PerlIO *f)
4359 PerlIO *g = PerlIONext(f);
4360 if (PerlIOValid(g)) {
4361 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4362 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4368 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4371 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4372 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4374 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4375 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4376 PerlIOBase(f)->flags);
4379 /* Enable the first CRLF capable layer you can find, but if none
4380 * found, the one we just pushed is fine. This results in at
4381 * any given moment at most one CRLF-capable layer being enabled
4382 * in the whole layer stack. */
4383 PerlIO *g = PerlIONext(f);
4384 while (PerlIOValid(g)) {
4385 PerlIOl *b = PerlIOBase(g);
4386 if (b && b->tab == &PerlIO_crlf) {
4387 if (!(b->flags & PERLIO_F_CRLF))
4388 b->flags |= PERLIO_F_CRLF;
4389 S_inherit_utf8_flag(g);
4390 PerlIO_pop(aTHX_ f);
4396 S_inherit_utf8_flag(f);
4402 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4404 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4405 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4409 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4410 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4412 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4413 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4415 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4420 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4421 b->end = b->ptr = b->buf + b->bufsiz;
4422 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4423 b->posn -= b->bufsiz;
4425 while (count > 0 && b->ptr > b->buf) {
4426 const int ch = *--buf;
4428 if (b->ptr - 2 >= b->buf) {
4435 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4436 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4452 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4454 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4456 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4459 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4460 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4461 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4462 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4464 while (nl < b->end && *nl != 0xd)
4466 if (nl < b->end && *nl == 0xd) {
4468 if (nl + 1 < b->end) {
4475 * Not CR,LF but just CR
4483 * Blast - found CR as last char in buffer
4488 * They may not care, defer work as long as
4492 return (nl - b->ptr);
4496 b->ptr++; /* say we have read it as far as
4497 * flush() is concerned */
4498 b->buf++; /* Leave space in front of buffer */
4499 /* Note as we have moved buf up flush's
4501 will naturally make posn point at CR
4503 b->bufsiz--; /* Buffer is thus smaller */
4504 code = PerlIO_fill(f); /* Fetch some more */
4505 b->bufsiz++; /* Restore size for next time */
4506 b->buf--; /* Point at space */
4507 b->ptr = nl = b->buf; /* Which is what we hand
4509 *nl = 0xd; /* Fill in the CR */
4511 goto test; /* fill() call worked */
4513 * CR at EOF - just fall through
4515 /* Should we clear EOF though ??? */
4520 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4526 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4528 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4529 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4535 if (ptr == b->end && *c->nl == 0xd) {
4536 /* Defered CR at end of buffer case - we lied about count */
4549 * Test code - delete when it works ...
4551 IV flags = PerlIOBase(f)->flags;
4552 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4553 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4554 /* Defered CR at end of buffer case - we lied about count */
4560 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4561 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4562 flags, c->nl, b->end, cnt);
4569 * They have taken what we lied about
4577 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4581 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4583 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4584 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4586 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4587 const STDCHAR *buf = (const STDCHAR *) vbuf;
4588 const STDCHAR * const ebuf = buf + count;
4591 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4593 while (buf < ebuf) {
4594 const STDCHAR * const eptr = b->buf + b->bufsiz;
4595 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4596 while (buf < ebuf && b->ptr < eptr) {
4598 if ((b->ptr + 2) > eptr) {
4606 *(b->ptr)++ = 0xd; /* CR */
4607 *(b->ptr)++ = 0xa; /* LF */
4609 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4616 *(b->ptr)++ = *buf++;
4618 if (b->ptr >= eptr) {
4624 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4626 return (buf - (STDCHAR *) vbuf);
4631 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4633 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4638 return PerlIOBuf_flush(aTHX_ f);
4642 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4644 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4645 /* In text mode - flush any pending stuff and flip it */
4646 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4647 #ifndef PERLIO_USING_CRLF
4648 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4649 PerlIO_pop(aTHX_ f);
4655 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4656 sizeof(PerlIO_funcs),
4659 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4661 PerlIOBuf_popped, /* popped */
4663 PerlIOCrlf_binmode, /* binmode */
4667 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4668 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4669 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4677 PerlIOBase_clearerr,
4678 PerlIOBase_setlinebuf,
4683 PerlIOCrlf_set_ptrcnt,
4687 /*--------------------------------------------------------------------------------------*/
4689 * mmap as "buffer" layer
4693 PerlIOBuf base; /* PerlIOBuf stuff */
4694 Mmap_t mptr; /* Mapped address */
4695 Size_t len; /* mapped length */
4696 STDCHAR *bbuf; /* malloced buffer if map fails */
4700 PerlIOMmap_map(pTHX_ PerlIO *f)
4703 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4704 const IV flags = PerlIOBase(f)->flags;
4708 if (flags & PERLIO_F_CANREAD) {
4709 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4710 const int fd = PerlIO_fileno(f);
4712 code = Fstat(fd, &st);
4713 if (code == 0 && S_ISREG(st.st_mode)) {
4714 SSize_t len = st.st_size - b->posn;
4717 if (PL_mmap_page_size <= 0)
4718 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4722 * This is a hack - should never happen - open should
4725 b->posn = PerlIO_tell(PerlIONext(f));
4727 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4728 len = st.st_size - posn;
4729 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4730 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4731 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4732 madvise(m->mptr, len, MADV_SEQUENTIAL);
4734 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4735 madvise(m->mptr, len, MADV_WILLNEED);
4737 PerlIOBase(f)->flags =
4738 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4739 b->end = ((STDCHAR *) m->mptr) + len;
4740 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4749 PerlIOBase(f)->flags =
4750 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4752 b->ptr = b->end = b->ptr;
4761 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4763 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4766 PerlIOBuf * const b = &m->base;
4768 /* The munmap address argument is tricky: depending on the
4769 * standard it is either "void *" or "caddr_t" (which is
4770 * usually "char *" (signed or unsigned). If we cast it
4771 * to "void *", those that have it caddr_t and an uptight
4772 * C++ compiler, will freak out. But casting it as char*
4773 * should work. Maybe. (Using Mmap_t figured out by
4774 * Configure doesn't always work, apparently.) */
4775 code = munmap((char*)m->mptr, m->len);
4779 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4782 b->ptr = b->end = b->buf;
4783 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4789 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4791 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4792 PerlIOBuf * const b = &m->base;
4793 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4795 * Already have a readbuffer in progress
4801 * We have a write buffer or flushed PerlIOBuf read buffer
4803 m->bbuf = b->buf; /* save it in case we need it again */
4804 b->buf = NULL; /* Clear to trigger below */
4807 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4810 * Map did not work - recover PerlIOBuf buffer if we have one
4815 b->ptr = b->end = b->buf;
4818 return PerlIOBuf_get_base(aTHX_ f);
4822 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4824 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4825 PerlIOBuf * const b = &m->base;
4826 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4828 if (b->ptr && (b->ptr - count) >= b->buf
4829 && memEQ(b->ptr - count, vbuf, count)) {
4831 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4836 * Loose the unwritable mapped buffer
4840 * If flush took the "buffer" see if we have one from before
4842 if (!b->buf && m->bbuf)
4845 PerlIOBuf_get_base(aTHX_ f);
4849 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4853 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4855 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4856 PerlIOBuf * const b = &m->base;
4858 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4860 * No, or wrong sort of, buffer
4863 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4867 * If unmap took the "buffer" see if we have one from before
4869 if (!b->buf && m->bbuf)
4872 PerlIOBuf_get_base(aTHX_ f);
4876 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4880 PerlIOMmap_flush(pTHX_ PerlIO *f)
4882 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4883 PerlIOBuf * const b = &m->base;
4884 IV code = PerlIOBuf_flush(aTHX_ f);
4886 * Now we are "synced" at PerlIOBuf level
4893 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4898 * We seem to have a PerlIOBuf buffer which was not mapped
4899 * remember it in case we need one later
4908 PerlIOMmap_fill(pTHX_ PerlIO *f)
4910 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4911 IV code = PerlIO_flush(f);
4912 if (code == 0 && !b->buf) {
4913 code = PerlIOMmap_map(aTHX_ f);
4915 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4916 code = PerlIOBuf_fill(aTHX_ f);
4922 PerlIOMmap_close(pTHX_ PerlIO *f)
4924 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4925 PerlIOBuf * const b = &m->base;
4926 IV code = PerlIO_flush(f);
4930 b->ptr = b->end = b->buf;
4932 if (PerlIOBuf_close(aTHX_ f) != 0)
4938 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4940 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4944 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4945 sizeof(PerlIO_funcs),
4948 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4952 PerlIOBase_binmode, /* binmode */
4966 PerlIOBase_clearerr,
4967 PerlIOBase_setlinebuf,
4968 PerlIOMmap_get_base,
4972 PerlIOBuf_set_ptrcnt,
4975 #endif /* HAS_MMAP */
4978 Perl_PerlIO_stdin(pTHX)
4982 PerlIO_stdstreams(aTHX);
4984 return &PL_perlio[1];
4988 Perl_PerlIO_stdout(pTHX)
4992 PerlIO_stdstreams(aTHX);
4994 return &PL_perlio[2];
4998 Perl_PerlIO_stderr(pTHX)
5002 PerlIO_stdstreams(aTHX);
5004 return &PL_perlio[3];
5007 /*--------------------------------------------------------------------------------------*/
5010 PerlIO_getname(PerlIO *f, char *buf)
5015 bool exported = FALSE;
5016 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5018 stdio = PerlIO_exportFILE(f,0);
5022 name = fgetname(stdio, buf);
5023 if (exported) PerlIO_releaseFILE(f,stdio);
5028 PERL_UNUSED_ARG(buf);
5029 Perl_croak(aTHX_ "Don't know how to get file name");
5035 /*--------------------------------------------------------------------------------------*/
5037 * Functions which can be called on any kind of PerlIO implemented in
5041 #undef PerlIO_fdopen
5043 PerlIO_fdopen(int fd, const char *mode)
5046 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5051 PerlIO_open(const char *path, const char *mode)
5054 SV *name = sv_2mortal(newSVpv(path, 0));
5055 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5058 #undef Perlio_reopen
5060 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5063 SV *name = sv_2mortal(newSVpv(path,0));
5064 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5069 PerlIO_getc(PerlIO *f)
5073 if ( 1 == PerlIO_read(f, buf, 1) ) {
5074 return (unsigned char) buf[0];
5079 #undef PerlIO_ungetc
5081 PerlIO_ungetc(PerlIO *f, int ch)
5086 if (PerlIO_unread(f, &buf, 1) == 1)
5094 PerlIO_putc(PerlIO *f, int ch)
5098 return PerlIO_write(f, &buf, 1);
5103 PerlIO_puts(PerlIO *f, const char *s)
5106 return PerlIO_write(f, s, strlen(s));
5109 #undef PerlIO_rewind
5111 PerlIO_rewind(PerlIO *f)
5114 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5118 #undef PerlIO_vprintf
5120 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5129 Perl_va_copy(ap, apc);
5130 sv = vnewSVpvf(fmt, &apc);
5132 sv = vnewSVpvf(fmt, &ap);
5134 s = SvPV_const(sv, len);
5135 wrote = PerlIO_write(f, s, len);
5140 #undef PerlIO_printf
5142 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5147 result = PerlIO_vprintf(f, fmt, ap);
5152 #undef PerlIO_stdoutf
5154 PerlIO_stdoutf(const char *fmt, ...)
5160 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5165 #undef PerlIO_tmpfile
5167 PerlIO_tmpfile(void)
5172 const int fd = win32_tmpfd();
5174 f = PerlIO_fdopen(fd, "w+b");
5176 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5177 const char * const tmpdir = PerlEnv_getenv("TMPDIR");
5178 SV * const sv = newSVpv(tmpdir ? tmpdir : "/tmp", 0);
5179 sv_catpv(sv, "/PerlIO_XXXXXX");
5181 * I have no idea how portable mkstemp() is ... NI-S
5183 const int fd = mkstemp(SvPVX(sv));
5185 f = PerlIO_fdopen(fd, "w+");
5187 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5188 PerlLIO_unlink(SvPVX_const(sv));
5191 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5192 FILE * const stdio = PerlSIO_tmpfile();
5195 f = PerlIO_fdopen(fileno(stdio), "w+");
5197 # endif /* else HAS_MKSTEMP */
5198 #endif /* else WIN32 */
5205 #endif /* USE_SFIO */
5206 #endif /* PERLIO_IS_STDIO */
5208 /*======================================================================================*/
5210 * Now some functions in terms of above which may be needed even if we are
5211 * not in true PerlIO mode
5214 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5217 const char *direction = NULL;
5220 * Need to supply default layer info from open.pm
5226 if (mode && mode[0] != 'r') {
5227 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5228 direction = "open>";
5230 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5231 direction = "open<";
5236 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5237 0, direction, 5, 0, 0);
5240 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5245 #undef PerlIO_setpos
5247 PerlIO_setpos(PerlIO *f, SV *pos)
5252 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5253 if (f && len == sizeof(Off_t))
5254 return PerlIO_seek(f, *posn, SEEK_SET);
5256 SETERRNO(EINVAL, SS_IVCHAN);
5260 #undef PerlIO_setpos
5262 PerlIO_setpos(PerlIO *f, SV *pos)
5267 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5268 if (f && len == sizeof(Fpos_t)) {
5269 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5270 return fsetpos64(f, fpos);
5272 return fsetpos(f, fpos);
5276 SETERRNO(EINVAL, SS_IVCHAN);
5282 #undef PerlIO_getpos
5284 PerlIO_getpos(PerlIO *f, SV *pos)
5287 Off_t posn = PerlIO_tell(f);
5288 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5289 return (posn == (Off_t) - 1) ? -1 : 0;
5292 #undef PerlIO_getpos
5294 PerlIO_getpos(PerlIO *f, SV *pos)
5299 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5300 code = fgetpos64(f, &fpos);
5302 code = fgetpos(f, &fpos);
5304 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5309 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5312 vprintf(char *pat, char *args)
5314 _doprnt(pat, args, stdout);
5315 return 0; /* wrong, but perl doesn't use the return
5320 vfprintf(FILE *fd, char *pat, char *args)
5322 _doprnt(pat, args, fd);
5323 return 0; /* wrong, but perl doesn't use the return
5329 #ifndef PerlIO_vsprintf
5331 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5334 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5335 PERL_UNUSED_CONTEXT;
5337 #ifndef PERL_MY_VSNPRINTF_GUARDED
5338 if (val < 0 || (n > 0 ? val >= n : 0)) {
5339 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5346 #ifndef PerlIO_sprintf
5348 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5353 result = PerlIO_vsprintf(s, n, fmt, ap);
5361 * c-indentation-style: bsd
5363 * indent-tabs-mode: t
5366 * ex: set ts=8 sts=4 sw=4 noet: