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)
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 SvREFCNT_dec(list->array[i].arg);
619 Safefree(list->array);
627 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
633 if (list->cur >= list->len) {
636 Renew(list->array, list->len, PerlIO_pair_t);
638 Newx(list->array, list->len, PerlIO_pair_t);
640 p = &(list->array[list->cur++]);
642 if ((p->arg = arg)) {
643 SvREFCNT_inc_simple_void_NN(arg);
648 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
650 PerlIO_list_t *list = NULL;
653 list = PerlIO_list_alloc(aTHX);
654 for (i=0; i < proto->cur; i++) {
655 SV *arg = proto->array[i].arg;
658 arg = sv_dup(arg, param);
660 PERL_UNUSED_ARG(param);
662 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
669 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
672 PerlIO **table = &proto->Iperlio;
675 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
676 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
677 PerlIO_allocate(aTHX); /* root slot is never used */
678 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
679 while ((f = *table)) {
681 table = (PerlIO **) (f++);
682 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
684 (void) fp_dup(f, 0, param);
691 PERL_UNUSED_ARG(proto);
692 PERL_UNUSED_ARG(param);
697 PerlIO_destruct(pTHX)
700 PerlIO **table = &PL_perlio;
703 PerlIO_debug("Destruct %p\n",(void*)aTHX);
705 while ((f = *table)) {
707 table = (PerlIO **) (f++);
708 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
712 if (l->tab->kind & PERLIO_K_DESTRUCT) {
713 PerlIO_debug("Destruct popping %s\n", l->tab->name);
727 PerlIO_pop(pTHX_ PerlIO *f)
729 const PerlIOl *l = *f;
731 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
732 if (l->tab->Popped) {
734 * If popped returns non-zero do not free its layer structure
735 * it has either done so itself, or it is shared and still in
738 if ((*l->tab->Popped) (aTHX_ f) != 0)
746 /* Return as an array the stack of layers on a filehandle. Note that
747 * the stack is returned top-first in the array, and there are three
748 * times as many array elements as there are layers in the stack: the
749 * first element of a layer triplet is the name, the second one is the
750 * arguments, and the third one is the flags. */
753 PerlIO_get_layers(pTHX_ PerlIO *f)
756 AV * const av = newAV();
758 if (PerlIOValid(f)) {
759 PerlIOl *l = PerlIOBase(f);
762 /* There is some collusion in the implementation of
763 XS_PerlIO_get_layers - it knows that name and flags are
764 generated as fresh SVs here, and takes advantage of that to
765 "copy" them by taking a reference. If it changes here, it needs
766 to change there too. */
767 SV * const name = l->tab && l->tab->name ?
768 newSVpv(l->tab->name, 0) : &PL_sv_undef;
769 SV * const arg = l->tab && l->tab->Getarg ?
770 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
773 av_push(av, newSViv((IV)l->flags));
781 /*--------------------------------------------------------------------------------------*/
783 * XS Interface for perl code
787 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
791 if ((SSize_t) len <= 0)
793 for (i = 0; i < PL_known_layers->cur; i++) {
794 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
795 if (memEQ(f->name, name, len) && f->name[len] == 0) {
796 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
800 if (load && PL_subname && PL_def_layerlist
801 && PL_def_layerlist->cur >= 2) {
802 if (PL_in_load_module) {
803 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
806 SV * const pkgsv = newSVpvs("PerlIO");
807 SV * const layer = newSVpvn(name, len);
808 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
810 SAVEBOOL(PL_in_load_module);
812 SAVEGENERICSV(PL_warnhook);
813 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
815 PL_in_load_module = TRUE;
817 * The two SVs are magically freed by load_module
819 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
821 return PerlIO_find_layer(aTHX_ name, len, 0);
824 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
828 #ifdef USE_ATTRIBUTES_FOR_PERLIO
831 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
834 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
835 PerlIO * const ifp = IoIFP(io);
836 PerlIO * const ofp = IoOFP(io);
837 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
838 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
844 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
847 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
848 PerlIO * const ifp = IoIFP(io);
849 PerlIO * const ofp = IoOFP(io);
850 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
851 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
857 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
859 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
864 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
866 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
870 MGVTBL perlio_vtab = {
878 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
881 SV * const sv = SvRV(ST(1));
882 AV * const av = newAV();
886 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
888 mg = mg_find(sv, PERL_MAGIC_ext);
889 mg->mg_virtual = &perlio_vtab;
891 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
892 for (i = 2; i < items; i++) {
894 const char * const name = SvPV_const(ST(i), len);
895 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
897 av_push(av, SvREFCNT_inc_simple_NN(layer));
908 #endif /* USE_ATTIBUTES_FOR_PERLIO */
911 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
913 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
914 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
918 XS(XS_PerlIO__Layer__NoWarnings)
920 /* This is used as a %SIG{__WARN__} handler to supress warnings
921 during loading of layers.
927 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
931 XS(XS_PerlIO__Layer__find)
937 Perl_croak(aTHX_ "Usage class->find(name[,load])");
940 const char * const name = SvPV_const(ST(1), len);
941 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
942 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
944 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
951 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
954 if (!PL_known_layers)
955 PL_known_layers = PerlIO_list_alloc(aTHX);
956 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
957 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
961 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
965 const char *s = names;
967 while (isSPACE(*s) || *s == ':')
972 const char *as = NULL;
974 if (!isIDFIRST(*s)) {
976 * Message is consistent with how attribute lists are
977 * passed. Even though this means "foo : : bar" is
978 * seen as an invalid separator character.
980 const char q = ((*s == '\'') ? '"' : '\'');
981 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
982 "Invalid separator character %c%c%c in PerlIO layer specification %s",
984 SETERRNO(EINVAL, LIB_INVARG);
989 } while (isALNUM(*e));
1005 * It's a nul terminated string, not allowed
1006 * to \ the terminating null. Anything other
1007 * character is passed over.
1017 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1018 "Argument list not closed for PerlIO layer \"%.*s\"",
1030 PerlIO_funcs * const layer =
1031 PerlIO_find_layer(aTHX_ s, llen, 1);
1035 arg = newSVpvn(as, alen);
1036 PerlIO_list_push(aTHX_ av, layer,
1037 (arg) ? arg : &PL_sv_undef);
1041 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1054 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1057 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1058 #ifdef PERLIO_USING_CRLF
1061 if (PerlIO_stdio.Set_ptrcnt)
1062 tab = &PerlIO_stdio;
1064 PerlIO_debug("Pushing %s\n", tab->name);
1065 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1070 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1072 return av->array[n].arg;
1076 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1078 if (n >= 0 && n < av->cur) {
1079 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1080 av->array[n].funcs->name);
1081 return av->array[n].funcs;
1084 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1089 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1091 PERL_UNUSED_ARG(mode);
1092 PERL_UNUSED_ARG(arg);
1093 PERL_UNUSED_ARG(tab);
1094 if (PerlIOValid(f)) {
1096 PerlIO_pop(aTHX_ f);
1102 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1103 sizeof(PerlIO_funcs),
1106 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1126 NULL, /* get_base */
1127 NULL, /* get_bufsiz */
1130 NULL, /* set_ptrcnt */
1134 PerlIO_default_layers(pTHX)
1137 if (!PL_def_layerlist) {
1138 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1139 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1140 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1141 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1143 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1145 osLayer = &PerlIO_win32;
1148 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1149 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1150 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1151 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1153 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1155 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1156 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1157 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1158 PerlIO_list_push(aTHX_ PL_def_layerlist,
1159 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1162 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1165 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1168 if (PL_def_layerlist->cur < 2) {
1169 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1171 return PL_def_layerlist;
1175 Perl_boot_core_PerlIO(pTHX)
1177 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1178 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1181 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1182 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1186 PerlIO_default_layer(pTHX_ I32 n)
1189 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1192 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1195 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1196 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1199 PerlIO_stdstreams(pTHX)
1203 PerlIO_allocate(aTHX);
1204 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1205 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1206 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1211 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1213 if (tab->fsize != sizeof(PerlIO_funcs)) {
1215 Perl_croak(aTHX_ "Layer does not match this perl");
1219 if (tab->size < sizeof(PerlIOl)) {
1222 /* Real layer with a data area */
1225 Newxz(temp, tab->size, char);
1229 l->tab = (PerlIO_funcs*) tab;
1231 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1232 (void*)f, tab->name,
1233 (mode) ? mode : "(Null)", (void*)arg);
1234 if (*l->tab->Pushed &&
1236 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1237 PerlIO_pop(aTHX_ f);
1246 /* Pseudo-layer where push does its own stack adjust */
1247 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1248 (mode) ? mode : "(Null)", (void*)arg);
1250 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1258 PerlIOBase_binmode(pTHX_ PerlIO *f)
1260 if (PerlIOValid(f)) {
1261 /* Is layer suitable for raw stream ? */
1262 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1263 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1264 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1267 /* Not suitable - pop it */
1268 PerlIO_pop(aTHX_ f);
1276 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1278 PERL_UNUSED_ARG(mode);
1279 PERL_UNUSED_ARG(arg);
1280 PERL_UNUSED_ARG(tab);
1282 if (PerlIOValid(f)) {
1287 * Strip all layers that are not suitable for a raw stream
1290 while (t && (l = *t)) {
1291 if (l->tab->Binmode) {
1292 /* Has a handler - normal case */
1293 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1295 /* Layer still there - move down a layer */
1304 /* No handler - pop it */
1305 PerlIO_pop(aTHX_ t);
1308 if (PerlIOValid(f)) {
1309 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1317 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1318 PerlIO_list_t *layers, IV n, IV max)
1322 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1324 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1335 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1339 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1340 code = PerlIO_parse_layers(aTHX_ layers, names);
1342 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1344 PerlIO_list_free(aTHX_ layers);
1350 /*--------------------------------------------------------------------------------------*/
1352 * Given the abstraction above the public API functions
1356 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1358 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1359 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1360 iotype, mode, (names) ? names : "(Null)");
1363 /* Do not flush etc. if (e.g.) switching encodings.
1364 if a pushed layer knows it needs to flush lower layers
1365 (for example :unix which is never going to call them)
1366 it can do the flush when it is pushed.
1368 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1371 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1372 #ifdef PERLIO_USING_CRLF
1373 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1374 O_BINARY so we can look for it in mode.
1376 if (!(mode & O_BINARY)) {
1378 /* FIXME?: Looking down the layer stack seems wrong,
1379 but is a way of reaching past (say) an encoding layer
1380 to flip CRLF-ness of the layer(s) below
1383 /* Perhaps we should turn on bottom-most aware layer
1384 e.g. Ilya's idea that UNIX TTY could serve
1386 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1387 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1388 /* Not in text mode - flush any pending stuff and flip it */
1390 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1392 /* Only need to turn it on in one layer so we are done */
1397 /* Not finding a CRLF aware layer presumably means we are binary
1398 which is not what was requested - so we failed
1399 We _could_ push :crlf layer but so could caller
1404 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1405 So code that used to be here is now in PerlIORaw_pushed().
1407 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1412 PerlIO__close(pTHX_ PerlIO *f)
1414 if (PerlIOValid(f)) {
1415 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1416 if (tab && tab->Close)
1417 return (*tab->Close)(aTHX_ f);
1419 return PerlIOBase_close(aTHX_ f);
1422 SETERRNO(EBADF, SS_IVCHAN);
1428 Perl_PerlIO_close(pTHX_ PerlIO *f)
1430 const int code = PerlIO__close(aTHX_ f);
1431 while (PerlIOValid(f)) {
1432 PerlIO_pop(aTHX_ f);
1438 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1441 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1445 static PerlIO_funcs *
1446 PerlIO_layer_from_ref(pTHX_ SV *sv)
1450 * For any scalar type load the handler which is bundled with perl
1452 if (SvTYPE(sv) < SVt_PVAV) {
1453 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1454 /* This isn't supposed to happen, since PerlIO::scalar is core,
1455 * but could happen anyway in smaller installs or with PAR */
1457 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1462 * For other types allow if layer is known but don't try and load it
1464 switch (SvTYPE(sv)) {
1466 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1468 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1470 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1472 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1479 PerlIO_resolve_layers(pTHX_ const char *layers,
1480 const char *mode, int narg, SV **args)
1483 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1486 PerlIO_stdstreams(aTHX);
1488 SV * const arg = *args;
1490 * If it is a reference but not an object see if we have a handler
1493 if (SvROK(arg) && !sv_isobject(arg)) {
1494 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1496 def = PerlIO_list_alloc(aTHX);
1497 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1501 * Don't fail if handler cannot be found :via(...) etc. may do
1502 * something sensible else we will just stringfy and open
1507 if (!layers || !*layers)
1508 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1509 if (layers && *layers) {
1512 av = PerlIO_clone_list(aTHX_ def, NULL);
1517 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1521 PerlIO_list_free(aTHX_ av);
1533 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1534 int imode, int perm, PerlIO *f, int narg, SV **args)
1537 if (!f && narg == 1 && *args == &PL_sv_undef) {
1538 if ((f = PerlIO_tmpfile())) {
1539 if (!layers || !*layers)
1540 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1541 if (layers && *layers)
1542 PerlIO_apply_layers(aTHX_ f, mode, layers);
1546 PerlIO_list_t *layera;
1548 PerlIO_funcs *tab = NULL;
1549 if (PerlIOValid(f)) {
1551 * This is "reopen" - it is not tested as perl does not use it
1555 layera = PerlIO_list_alloc(aTHX);
1559 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1560 PerlIO_list_push(aTHX_ layera, l->tab,
1561 (arg) ? arg : &PL_sv_undef);
1563 l = *PerlIONext(&l);
1567 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1573 * Start at "top" of layer stack
1575 n = layera->cur - 1;
1577 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1586 * Found that layer 'n' can do opens - call it
1588 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1589 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1591 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1592 tab->name, layers ? layers : "(Null)", mode, fd,
1593 imode, perm, (void*)f, narg, (void*)args);
1595 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1598 SETERRNO(EINVAL, LIB_INVARG);
1602 if (n + 1 < layera->cur) {
1604 * More layers above the one that we used to open -
1607 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1608 /* If pushing layers fails close the file */
1615 PerlIO_list_free(aTHX_ layera);
1622 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1624 PERL_ARGS_ASSERT_PERLIO_READ;
1626 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1630 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1632 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1634 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1638 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1640 PERL_ARGS_ASSERT_PERLIO_WRITE;
1642 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1646 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1648 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1652 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1654 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1658 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1663 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1665 if (tab && tab->Flush)
1666 return (*tab->Flush) (aTHX_ f);
1668 return 0; /* If no Flush defined, silently succeed. */
1671 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1672 SETERRNO(EBADF, SS_IVCHAN);
1678 * Is it good API design to do flush-all on NULL, a potentially
1679 * errorneous input? Maybe some magical value (PerlIO*
1680 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1681 * things on fflush(NULL), but should we be bound by their design
1684 PerlIO **table = &PL_perlio;
1686 while ((f = *table)) {
1688 table = (PerlIO **) (f++);
1689 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1690 if (*f && PerlIO_flush(f) != 0)
1700 PerlIOBase_flush_linebuf(pTHX)
1703 PerlIO **table = &PL_perlio;
1705 while ((f = *table)) {
1707 table = (PerlIO **) (f++);
1708 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1711 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1712 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1720 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1722 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1726 PerlIO_isutf8(PerlIO *f)
1729 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1731 SETERRNO(EBADF, SS_IVCHAN);
1737 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1739 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1743 Perl_PerlIO_error(pTHX_ PerlIO *f)
1745 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1749 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1751 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1755 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1757 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1761 PerlIO_has_base(PerlIO *f)
1763 if (PerlIOValid(f)) {
1764 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1767 return (tab->Get_base != NULL);
1774 PerlIO_fast_gets(PerlIO *f)
1776 if (PerlIOValid(f)) {
1777 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1778 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1781 return (tab->Set_ptrcnt != NULL);
1789 PerlIO_has_cntptr(PerlIO *f)
1791 if (PerlIOValid(f)) {
1792 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1795 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1802 PerlIO_canset_cnt(PerlIO *f)
1804 if (PerlIOValid(f)) {
1805 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1808 return (tab->Set_ptrcnt != NULL);
1815 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1817 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1821 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1823 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1827 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1829 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1833 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1835 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1839 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1841 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1845 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1847 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1851 /*--------------------------------------------------------------------------------------*/
1853 * utf8 and raw dummy layers
1857 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1859 PERL_UNUSED_CONTEXT;
1860 PERL_UNUSED_ARG(mode);
1861 PERL_UNUSED_ARG(arg);
1862 if (PerlIOValid(f)) {
1863 if (tab->kind & PERLIO_K_UTF8)
1864 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1866 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1872 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1873 sizeof(PerlIO_funcs),
1876 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1896 NULL, /* get_base */
1897 NULL, /* get_bufsiz */
1900 NULL, /* set_ptrcnt */
1903 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1904 sizeof(PerlIO_funcs),
1927 NULL, /* get_base */
1928 NULL, /* get_bufsiz */
1931 NULL, /* set_ptrcnt */
1935 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1936 IV n, const char *mode, int fd, int imode, int perm,
1937 PerlIO *old, int narg, SV **args)
1939 PerlIO_funcs * const tab = PerlIO_default_btm();
1940 PERL_UNUSED_ARG(self);
1941 if (tab && tab->Open)
1942 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1944 SETERRNO(EINVAL, LIB_INVARG);
1948 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1949 sizeof(PerlIO_funcs),
1972 NULL, /* get_base */
1973 NULL, /* get_bufsiz */
1976 NULL, /* set_ptrcnt */
1978 /*--------------------------------------------------------------------------------------*/
1979 /*--------------------------------------------------------------------------------------*/
1981 * "Methods" of the "base class"
1985 PerlIOBase_fileno(pTHX_ PerlIO *f)
1987 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1991 PerlIO_modestr(PerlIO * f, char *buf)
1994 if (PerlIOValid(f)) {
1995 const IV flags = PerlIOBase(f)->flags;
1996 if (flags & PERLIO_F_APPEND) {
1998 if (flags & PERLIO_F_CANREAD) {
2002 else if (flags & PERLIO_F_CANREAD) {
2004 if (flags & PERLIO_F_CANWRITE)
2007 else if (flags & PERLIO_F_CANWRITE) {
2009 if (flags & PERLIO_F_CANREAD) {
2013 #ifdef PERLIO_USING_CRLF
2014 if (!(flags & PERLIO_F_CRLF))
2024 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2026 PerlIOl * const l = PerlIOBase(f);
2027 PERL_UNUSED_CONTEXT;
2028 PERL_UNUSED_ARG(arg);
2030 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2031 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2032 if (tab->Set_ptrcnt != NULL)
2033 l->flags |= PERLIO_F_FASTGETS;
2035 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2039 l->flags |= PERLIO_F_CANREAD;
2042 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2045 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2048 SETERRNO(EINVAL, LIB_INVARG);
2054 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2057 l->flags &= ~PERLIO_F_CRLF;
2060 l->flags |= PERLIO_F_CRLF;
2063 SETERRNO(EINVAL, LIB_INVARG);
2070 l->flags |= l->next->flags &
2071 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2076 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2077 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2078 l->flags, PerlIO_modestr(f, temp));
2084 PerlIOBase_popped(pTHX_ PerlIO *f)
2086 PERL_UNUSED_CONTEXT;
2092 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2095 * Save the position as current head considers it
2097 const Off_t old = PerlIO_tell(f);
2098 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2099 PerlIOSelf(f, PerlIOBuf)->posn = old;
2100 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2104 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2106 STDCHAR *buf = (STDCHAR *) vbuf;
2108 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2109 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2110 SETERRNO(EBADF, SS_IVCHAN);
2116 SSize_t avail = PerlIO_get_cnt(f);
2119 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2121 STDCHAR *ptr = PerlIO_get_ptr(f);
2122 Copy(ptr, buf, take, STDCHAR);
2123 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2126 if (avail == 0) /* set_ptrcnt could have reset avail */
2129 if (count > 0 && avail <= 0) {
2130 if (PerlIO_fill(f) != 0)
2135 return (buf - (STDCHAR *) vbuf);
2141 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2143 PERL_UNUSED_CONTEXT;
2149 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2151 PERL_UNUSED_CONTEXT;
2157 PerlIOBase_close(pTHX_ PerlIO *f)
2160 if (PerlIOValid(f)) {
2161 PerlIO *n = PerlIONext(f);
2162 code = PerlIO_flush(f);
2163 PerlIOBase(f)->flags &=
2164 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2165 while (PerlIOValid(n)) {
2166 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2167 if (tab && tab->Close) {
2168 if ((*tab->Close)(aTHX_ n) != 0)
2173 PerlIOBase(n)->flags &=
2174 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2180 SETERRNO(EBADF, SS_IVCHAN);
2186 PerlIOBase_eof(pTHX_ PerlIO *f)
2188 PERL_UNUSED_CONTEXT;
2189 if (PerlIOValid(f)) {
2190 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2196 PerlIOBase_error(pTHX_ PerlIO *f)
2198 PERL_UNUSED_CONTEXT;
2199 if (PerlIOValid(f)) {
2200 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2206 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2208 if (PerlIOValid(f)) {
2209 PerlIO * const n = PerlIONext(f);
2210 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2217 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2219 PERL_UNUSED_CONTEXT;
2220 if (PerlIOValid(f)) {
2221 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2226 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2232 arg = sv_dup(arg, param);
2233 SvREFCNT_inc_simple_void_NN(arg);
2237 return newSVsv(arg);
2240 PERL_UNUSED_ARG(param);
2241 return newSVsv(arg);
2246 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2248 PerlIO * const nexto = PerlIONext(o);
2249 if (PerlIOValid(nexto)) {
2250 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2251 if (tab && tab->Dup)
2252 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2254 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2257 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2260 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2261 self->name, (void*)f, (void*)o, (void*)param);
2263 arg = (*self->Getarg)(aTHX_ o, param, flags);
2264 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2265 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2266 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2272 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2274 /* Must be called with PL_perlio_mutex locked. */
2276 S_more_refcounted_fds(pTHX_ const int new_fd) {
2278 const int old_max = PL_perlio_fd_refcnt_size;
2279 const int new_max = 16 + (new_fd & ~15);
2282 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2283 old_max, new_fd, new_max);
2285 if (new_fd < old_max) {
2289 assert (new_max > new_fd);
2291 /* Use plain realloc() since we need this memory to be really
2292 * global and visible to all the interpreters and/or threads. */
2293 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2297 MUTEX_UNLOCK(&PL_perlio_mutex);
2299 /* Can't use PerlIO to write as it allocates memory */
2300 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2301 PL_no_mem, strlen(PL_no_mem));
2305 PL_perlio_fd_refcnt_size = new_max;
2306 PL_perlio_fd_refcnt = new_array;
2308 PerlIO_debug("Zeroing %p, %d\n",
2309 (void*)(new_array + old_max),
2312 Zero(new_array + old_max, new_max - old_max, int);
2319 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2320 PERL_UNUSED_CONTEXT;
2324 PerlIOUnix_refcnt_inc(int fd)
2331 MUTEX_LOCK(&PL_perlio_mutex);
2333 if (fd >= PL_perlio_fd_refcnt_size)
2334 S_more_refcounted_fds(aTHX_ fd);
2336 PL_perlio_fd_refcnt[fd]++;
2337 if (PL_perlio_fd_refcnt[fd] <= 0) {
2338 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2339 fd, PL_perlio_fd_refcnt[fd]);
2341 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2342 fd, PL_perlio_fd_refcnt[fd]);
2345 MUTEX_UNLOCK(&PL_perlio_mutex);
2348 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2353 PerlIOUnix_refcnt_dec(int fd)
2360 MUTEX_LOCK(&PL_perlio_mutex);
2362 if (fd >= PL_perlio_fd_refcnt_size) {
2363 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2364 fd, PL_perlio_fd_refcnt_size);
2366 if (PL_perlio_fd_refcnt[fd] <= 0) {
2367 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2368 fd, PL_perlio_fd_refcnt[fd]);
2370 cnt = --PL_perlio_fd_refcnt[fd];
2371 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2373 MUTEX_UNLOCK(&PL_perlio_mutex);
2376 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2382 PerlIO_cleanup(pTHX)
2387 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2389 PerlIO_debug("Cleanup layers\n");
2392 /* Raise STDIN..STDERR refcount so we don't close them */
2393 for (i=0; i < 3; i++)
2394 PerlIOUnix_refcnt_inc(i);
2395 PerlIO_cleantable(aTHX_ &PL_perlio);
2396 /* Restore STDIN..STDERR refcount */
2397 for (i=0; i < 3; i++)
2398 PerlIOUnix_refcnt_dec(i);
2400 if (PL_known_layers) {
2401 PerlIO_list_free(aTHX_ PL_known_layers);
2402 PL_known_layers = NULL;
2404 if (PL_def_layerlist) {
2405 PerlIO_list_free(aTHX_ PL_def_layerlist);
2406 PL_def_layerlist = NULL;
2410 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2414 /* XXX we can't rely on an interpreter being present at this late stage,
2415 XXX so we can't use a function like PerlLIO_write that relies on one
2416 being present (at least in win32) :-(.
2421 /* By now all filehandles should have been closed, so any
2422 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2424 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2425 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2426 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2428 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2429 if (PL_perlio_fd_refcnt[i]) {
2431 my_snprintf(buf, sizeof(buf),
2432 "PerlIO_teardown: fd %d refcnt=%d\n",
2433 i, PL_perlio_fd_refcnt[i]);
2434 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2440 /* Not bothering with PL_perlio_mutex since by now
2441 * all the interpreters are gone. */
2442 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2443 && PL_perlio_fd_refcnt) {
2444 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2445 PL_perlio_fd_refcnt = NULL;
2446 PL_perlio_fd_refcnt_size = 0;
2450 /*--------------------------------------------------------------------------------------*/
2452 * Bottom-most level for UNIX-like case
2456 struct _PerlIO base; /* The generic part */
2457 int fd; /* UNIX like file descriptor */
2458 int oflags; /* open/fcntl flags */
2462 PerlIOUnix_oflags(const char *mode)
2465 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2470 if (*++mode == '+') {
2477 oflags = O_CREAT | O_TRUNC;
2478 if (*++mode == '+') {
2487 oflags = O_CREAT | O_APPEND;
2488 if (*++mode == '+') {
2501 else if (*mode == 't') {
2503 oflags &= ~O_BINARY;
2507 * Always open in binary mode
2510 if (*mode || oflags == -1) {
2511 SETERRNO(EINVAL, LIB_INVARG);
2518 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2520 PERL_UNUSED_CONTEXT;
2521 return PerlIOSelf(f, PerlIOUnix)->fd;
2525 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2527 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2530 if (PerlLIO_fstat(fd, &st) == 0) {
2531 if (!S_ISREG(st.st_mode)) {
2532 PerlIO_debug("%d is not regular file\n",fd);
2533 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2536 PerlIO_debug("%d _is_ a regular file\n",fd);
2542 PerlIOUnix_refcnt_inc(fd);
2543 PERL_UNUSED_CONTEXT;
2547 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2549 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2550 if (*PerlIONext(f)) {
2551 /* We never call down so do any pending stuff now */
2552 PerlIO_flush(PerlIONext(f));
2554 * XXX could (or should) we retrieve the oflags from the open file
2555 * handle rather than believing the "mode" we are passed in? XXX
2556 * Should the value on NULL mode be 0 or -1?
2558 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2559 mode ? PerlIOUnix_oflags(mode) : -1);
2561 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2567 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2569 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2571 PERL_UNUSED_CONTEXT;
2572 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2574 SETERRNO(ESPIPE, LIB_INVARG);
2576 SETERRNO(EINVAL, LIB_INVARG);
2580 new_loc = PerlLIO_lseek(fd, offset, whence);
2581 if (new_loc == (Off_t) - 1)
2583 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2588 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2589 IV n, const char *mode, int fd, int imode,
2590 int perm, PerlIO *f, int narg, SV **args)
2592 if (PerlIOValid(f)) {
2593 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2594 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2597 if (*mode == IoTYPE_NUMERIC)
2600 imode = PerlIOUnix_oflags(mode);
2604 const char *path = SvPV_nolen_const(*args);
2605 fd = PerlLIO_open3(path, imode, perm);
2609 if (*mode == IoTYPE_IMPLICIT)
2612 f = PerlIO_allocate(aTHX);
2614 if (!PerlIOValid(f)) {
2615 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2619 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2620 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2621 if (*mode == IoTYPE_APPEND)
2622 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2629 * FIXME: pop layers ???
2637 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2639 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2641 if (flags & PERLIO_DUP_FD) {
2642 fd = PerlLIO_dup(fd);
2645 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2647 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2648 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2657 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2660 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2661 #ifdef PERLIO_STD_SPECIAL
2663 return PERLIO_STD_IN(fd, vbuf, count);
2665 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2666 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2670 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2671 if (len >= 0 || errno != EINTR) {
2673 if (errno != EAGAIN) {
2674 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2677 else if (len == 0 && count != 0) {
2678 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2689 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2692 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2693 #ifdef PERLIO_STD_SPECIAL
2694 if (fd == 1 || fd == 2)
2695 return PERLIO_STD_OUT(fd, vbuf, count);
2698 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2699 if (len >= 0 || errno != EINTR) {
2701 if (errno != EAGAIN) {
2702 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2713 PerlIOUnix_tell(pTHX_ PerlIO *f)
2715 PERL_UNUSED_CONTEXT;
2717 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2722 PerlIOUnix_close(pTHX_ PerlIO *f)
2725 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2727 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2728 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2729 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2734 SETERRNO(EBADF,SS_IVCHAN);
2737 while (PerlLIO_close(fd) != 0) {
2738 if (errno != EINTR) {
2745 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2750 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2751 sizeof(PerlIO_funcs),
2758 PerlIOBase_binmode, /* binmode */
2768 PerlIOBase_noop_ok, /* flush */
2769 PerlIOBase_noop_fail, /* fill */
2772 PerlIOBase_clearerr,
2773 PerlIOBase_setlinebuf,
2774 NULL, /* get_base */
2775 NULL, /* get_bufsiz */
2778 NULL, /* set_ptrcnt */
2781 /*--------------------------------------------------------------------------------------*/
2786 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2787 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2788 broken by the last second glibc 2.3 fix
2790 #define STDIO_BUFFER_WRITABLE
2795 struct _PerlIO base;
2796 FILE *stdio; /* The stream */
2800 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2802 PERL_UNUSED_CONTEXT;
2804 if (PerlIOValid(f)) {
2805 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2807 return PerlSIO_fileno(s);
2814 PerlIOStdio_mode(const char *mode, char *tmode)
2816 char * const ret = tmode;
2822 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2830 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2833 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2834 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2835 if (toptab == tab) {
2836 /* Top is already stdio - pop self (duplicate) and use original */
2837 PerlIO_pop(aTHX_ f);
2840 const int fd = PerlIO_fileno(n);
2843 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2844 mode = PerlIOStdio_mode(mode, tmode)))) {
2845 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2846 /* We never call down so do any pending stuff now */
2847 PerlIO_flush(PerlIONext(f));
2854 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2859 PerlIO_importFILE(FILE *stdio, const char *mode)
2865 if (!mode || !*mode) {
2866 /* We need to probe to see how we can open the stream
2867 so start with read/write and then try write and read
2868 we dup() so that we can fclose without loosing the fd.
2870 Note that the errno value set by a failing fdopen
2871 varies between stdio implementations.
2873 const int fd = PerlLIO_dup(fileno(stdio));
2874 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2876 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2879 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2882 /* Don't seem to be able to open */
2888 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2889 s = PerlIOSelf(f, PerlIOStdio);
2891 PerlIOUnix_refcnt_inc(fileno(stdio));
2898 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2899 IV n, const char *mode, int fd, int imode,
2900 int perm, PerlIO *f, int narg, SV **args)
2903 if (PerlIOValid(f)) {
2904 const char * const path = SvPV_nolen_const(*args);
2905 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2907 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2908 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2913 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2918 const char * const path = SvPV_nolen_const(*args);
2919 if (*mode == IoTYPE_NUMERIC) {
2921 fd = PerlLIO_open3(path, imode, perm);
2925 bool appended = FALSE;
2927 /* Cygwin wants its 'b' early. */
2929 mode = PerlIOStdio_mode(mode, tmode);
2931 stdio = PerlSIO_fopen(path, mode);
2934 f = PerlIO_allocate(aTHX);
2937 mode = PerlIOStdio_mode(mode, tmode);
2938 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2940 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2941 PerlIOUnix_refcnt_inc(fileno(stdio));
2943 PerlSIO_fclose(stdio);
2955 if (*mode == IoTYPE_IMPLICIT) {
2962 stdio = PerlSIO_stdin;
2965 stdio = PerlSIO_stdout;
2968 stdio = PerlSIO_stderr;
2973 stdio = PerlSIO_fdopen(fd, mode =
2974 PerlIOStdio_mode(mode, tmode));
2978 f = PerlIO_allocate(aTHX);
2980 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2981 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2982 PerlIOUnix_refcnt_inc(fileno(stdio));
2992 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2994 /* This assumes no layers underneath - which is what
2995 happens, but is not how I remember it. NI-S 2001/10/16
2997 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2998 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2999 const int fd = fileno(stdio);
3001 if (flags & PERLIO_DUP_FD) {
3002 const int dfd = PerlLIO_dup(fileno(stdio));
3004 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3009 /* FIXME: To avoid messy error recovery if dup fails
3010 re-use the existing stdio as though flag was not set
3014 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3016 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3018 PerlIOUnix_refcnt_inc(fileno(stdio));
3025 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3027 PERL_UNUSED_CONTEXT;
3029 /* XXX this could use PerlIO_canset_fileno() and
3030 * PerlIO_set_fileno() support from Configure
3032 # if defined(__UCLIBC__)
3033 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3036 # elif defined(__GLIBC__)
3037 /* There may be a better way for GLIBC:
3038 - libio.h defines a flag to not close() on cleanup
3042 # elif defined(__sun__)
3045 # elif defined(__hpux)
3049 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3050 your platform does not have special entry try this one.
3051 [For OSF only have confirmation for Tru64 (alpha)
3052 but assume other OSFs will be similar.]
3054 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3057 # elif defined(__FreeBSD__)
3058 /* There may be a better way on FreeBSD:
3059 - we could insert a dummy func in the _close function entry
3060 f->_close = (int (*)(void *)) dummy_close;
3064 # elif defined(__OpenBSD__)
3065 /* There may be a better way on OpenBSD:
3066 - we could insert a dummy func in the _close function entry
3067 f->_close = (int (*)(void *)) dummy_close;
3071 # elif defined(__EMX__)
3072 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3075 # elif defined(__CYGWIN__)
3076 /* There may be a better way on CYGWIN:
3077 - we could insert a dummy func in the _close function entry
3078 f->_close = (int (*)(void *)) dummy_close;
3082 # elif defined(WIN32)
3083 # if defined(__BORLANDC__)
3084 f->fd = PerlLIO_dup(fileno(f));
3085 # elif defined(UNDER_CE)
3086 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3095 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3096 (which isn't thread safe) instead
3098 # error "Don't know how to set FILE.fileno on your platform"
3106 PerlIOStdio_close(pTHX_ PerlIO *f)
3108 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3114 const int fd = fileno(stdio);
3122 #ifdef SOCKS5_VERSION_NAME
3123 /* Socks lib overrides close() but stdio isn't linked to
3124 that library (though we are) - so we must call close()
3125 on sockets on stdio's behalf.
3128 Sock_size_t optlen = sizeof(int);
3129 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3132 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3133 that a subsequent fileno() on it returns -1. Don't want to croak()
3134 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3135 trying to close an already closed handle which somehow it still has
3136 a reference to. (via.xs, I'm looking at you). */
3137 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3138 /* File descriptor still in use */
3142 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3143 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3145 if (stdio == stdout || stdio == stderr)
3146 return PerlIO_flush(f);
3147 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3148 Use Sarathy's trick from maint-5.6 to invalidate the
3149 fileno slot of the FILE *
3151 result = PerlIO_flush(f);
3153 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3156 MUTEX_LOCK(&PL_perlio_mutex);
3157 /* Right. We need a mutex here because for a brief while we
3158 will have the situation that fd is actually closed. Hence if
3159 a second thread were to get into this block, its dup() would
3160 likely return our fd as its dupfd. (after all, it is closed)
3161 Then if we get to the dup2() first, we blat the fd back
3162 (messing up its temporary as a side effect) only for it to
3163 then close its dupfd (== our fd) in its close(dupfd) */
3165 /* There is, of course, a race condition, that any other thread
3166 trying to input/output/whatever on this fd will be stuffed
3167 for the duration of this little manoeuvrer. Perhaps we
3168 should hold an IO mutex for the duration of every IO
3169 operation if we know that invalidate doesn't work on this
3170 platform, but that would suck, and could kill performance.
3172 Except that correctness trumps speed.
3173 Advice from klortho #11912. */
3175 dupfd = PerlLIO_dup(fd);
3178 MUTEX_UNLOCK(&PL_perlio_mutex);
3179 /* Oh cXap. This isn't going to go well. Not sure if we can
3180 recover from here, or if closing this particular FILE *
3181 is a good idea now. */
3186 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3188 result = PerlSIO_fclose(stdio);
3189 /* We treat error from stdio as success if we invalidated
3190 errno may NOT be expected EBADF
3192 if (invalidate && result != 0) {
3196 #ifdef SOCKS5_VERSION_NAME
3197 /* in SOCKS' case, let close() determine return value */
3201 PerlLIO_dup2(dupfd,fd);
3202 PerlLIO_close(dupfd);
3204 MUTEX_UNLOCK(&PL_perlio_mutex);
3212 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3215 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3219 STDCHAR *buf = (STDCHAR *) vbuf;
3221 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3222 * stdio does not do that for fread()
3224 const int ch = PerlSIO_fgetc(s);
3231 got = PerlSIO_fread(vbuf, 1, count, s);
3232 if (got == 0 && PerlSIO_ferror(s))
3234 if (got >= 0 || errno != EINTR)
3237 SETERRNO(0,0); /* just in case */
3243 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3246 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3248 #ifdef STDIO_BUFFER_WRITABLE
3249 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3250 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3251 STDCHAR *base = PerlIO_get_base(f);
3252 SSize_t cnt = PerlIO_get_cnt(f);
3253 STDCHAR *ptr = PerlIO_get_ptr(f);
3254 SSize_t avail = ptr - base;
3256 if (avail > count) {
3260 Move(buf-avail,ptr,avail,STDCHAR);
3263 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3264 if (PerlSIO_feof(s) && unread >= 0)
3265 PerlSIO_clearerr(s);
3270 if (PerlIO_has_cntptr(f)) {
3271 /* We can get pointer to buffer but not its base
3272 Do ungetc() but check chars are ending up in the
3275 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3276 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3278 const int ch = *--buf & 0xFF;
3279 if (ungetc(ch,s) != ch) {
3280 /* ungetc did not work */
3283 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3284 /* Did not change pointer as expected */
3285 fgetc(s); /* get char back again */
3295 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3301 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3306 got = PerlSIO_fwrite(vbuf, 1, count,
3307 PerlIOSelf(f, PerlIOStdio)->stdio);
3308 if (got >= 0 || errno != EINTR)
3311 SETERRNO(0,0); /* just in case */
3317 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3319 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3320 PERL_UNUSED_CONTEXT;
3322 return PerlSIO_fseek(stdio, offset, whence);
3326 PerlIOStdio_tell(pTHX_ PerlIO *f)
3328 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3329 PERL_UNUSED_CONTEXT;
3331 return PerlSIO_ftell(stdio);
3335 PerlIOStdio_flush(pTHX_ PerlIO *f)
3337 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3338 PERL_UNUSED_CONTEXT;
3340 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3341 return PerlSIO_fflush(stdio);
3347 * FIXME: This discards ungetc() and pre-read stuff which is not
3348 * right if this is just a "sync" from a layer above Suspect right
3349 * design is to do _this_ but not have layer above flush this
3350 * layer read-to-read
3353 * Not writeable - sync by attempting a seek
3356 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3364 PerlIOStdio_eof(pTHX_ PerlIO *f)
3366 PERL_UNUSED_CONTEXT;
3368 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3372 PerlIOStdio_error(pTHX_ PerlIO *f)
3374 PERL_UNUSED_CONTEXT;
3376 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3380 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3382 PERL_UNUSED_CONTEXT;
3384 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3388 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3390 PERL_UNUSED_CONTEXT;
3392 #ifdef HAS_SETLINEBUF
3393 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3395 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3401 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3403 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3404 return (STDCHAR*)PerlSIO_get_base(stdio);
3408 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3410 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3411 return PerlSIO_get_bufsiz(stdio);
3415 #ifdef USE_STDIO_PTR
3417 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3419 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3420 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3424 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3426 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3427 return PerlSIO_get_cnt(stdio);
3431 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3433 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3435 #ifdef STDIO_PTR_LVALUE
3436 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3437 #ifdef STDIO_PTR_LVAL_SETS_CNT
3438 assert(PerlSIO_get_cnt(stdio) == (cnt));
3440 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3442 * Setting ptr _does_ change cnt - we are done
3446 #else /* STDIO_PTR_LVALUE */
3448 #endif /* STDIO_PTR_LVALUE */
3451 * Now (or only) set cnt
3453 #ifdef STDIO_CNT_LVALUE
3454 PerlSIO_set_cnt(stdio, cnt);
3455 #else /* STDIO_CNT_LVALUE */
3456 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3457 PerlSIO_set_ptr(stdio,
3458 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3460 #else /* STDIO_PTR_LVAL_SETS_CNT */
3462 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3463 #endif /* STDIO_CNT_LVALUE */
3470 PerlIOStdio_fill(pTHX_ PerlIO *f)
3472 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3474 PERL_UNUSED_CONTEXT;
3477 * fflush()ing read-only streams can cause trouble on some stdio-s
3479 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3480 if (PerlSIO_fflush(stdio) != 0)
3484 c = PerlSIO_fgetc(stdio);
3487 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3493 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3495 #ifdef STDIO_BUFFER_WRITABLE
3496 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3497 /* Fake ungetc() to the real buffer in case system's ungetc
3500 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3501 SSize_t cnt = PerlSIO_get_cnt(stdio);
3502 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3503 if (ptr == base+1) {
3504 *--ptr = (STDCHAR) c;
3505 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3506 if (PerlSIO_feof(stdio))
3507 PerlSIO_clearerr(stdio);
3513 if (PerlIO_has_cntptr(f)) {
3515 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3522 /* An ungetc()d char is handled separately from the regular
3523 * buffer, so we stuff it in the buffer ourselves.
3524 * Should never get called as should hit code above
3526 *(--((*stdio)->_ptr)) = (unsigned char) c;
3529 /* If buffer snoop scheme above fails fall back to
3532 if (PerlSIO_ungetc(c, stdio) != c)
3540 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3541 sizeof(PerlIO_funcs),
3543 sizeof(PerlIOStdio),
3544 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3548 PerlIOBase_binmode, /* binmode */
3562 PerlIOStdio_clearerr,
3563 PerlIOStdio_setlinebuf,
3565 PerlIOStdio_get_base,
3566 PerlIOStdio_get_bufsiz,
3571 #ifdef USE_STDIO_PTR
3572 PerlIOStdio_get_ptr,
3573 PerlIOStdio_get_cnt,
3574 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3575 PerlIOStdio_set_ptrcnt,
3578 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3583 #endif /* USE_STDIO_PTR */
3586 /* Note that calls to PerlIO_exportFILE() are reversed using
3587 * PerlIO_releaseFILE(), not importFILE. */
3589 PerlIO_exportFILE(PerlIO * f, const char *mode)
3593 if (PerlIOValid(f)) {
3596 if (!mode || !*mode) {
3597 mode = PerlIO_modestr(f, buf);
3599 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3603 /* De-link any lower layers so new :stdio sticks */
3605 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3606 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3608 PerlIOUnix_refcnt_inc(fileno(stdio));
3609 /* Link previous lower layers under new one */
3613 /* restore layers list */
3623 PerlIO_findFILE(PerlIO *f)
3628 if (l->tab == &PerlIO_stdio) {
3629 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3632 l = *PerlIONext(&l);
3634 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3635 /* However, we're not really exporting a FILE * to someone else (who
3636 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3637 So we need to undo its refernce count increase on the underlying file
3638 descriptor. We have to do this, because if the loop above returns you
3639 the FILE *, then *it* didn't increase any reference count. So there's
3640 only one way to be consistent. */
3641 stdio = PerlIO_exportFILE(f, NULL);
3643 const int fd = fileno(stdio);
3645 PerlIOUnix_refcnt_dec(fd);
3650 /* Use this to reverse PerlIO_exportFILE calls. */
3652 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3657 if (l->tab == &PerlIO_stdio) {
3658 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3659 if (s->stdio == f) {
3661 const int fd = fileno(f);
3663 PerlIOUnix_refcnt_dec(fd);
3664 PerlIO_pop(aTHX_ p);
3673 /*--------------------------------------------------------------------------------------*/
3675 * perlio buffer layer
3679 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3681 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3682 const int fd = PerlIO_fileno(f);
3683 if (fd >= 0 && PerlLIO_isatty(fd)) {
3684 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3686 if (*PerlIONext(f)) {
3687 const Off_t posn = PerlIO_tell(PerlIONext(f));
3688 if (posn != (Off_t) - 1) {
3692 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3696 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3697 IV n, const char *mode, int fd, int imode, int perm,
3698 PerlIO *f, int narg, SV **args)
3700 if (PerlIOValid(f)) {
3701 PerlIO *next = PerlIONext(f);
3703 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3704 if (tab && tab->Open)
3706 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3708 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3713 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3715 if (*mode == IoTYPE_IMPLICIT) {
3721 if (tab && tab->Open)
3722 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3725 SETERRNO(EINVAL, LIB_INVARG);
3727 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3729 * if push fails during open, open fails. close will pop us.
3734 fd = PerlIO_fileno(f);
3735 if (init && fd == 2) {
3737 * Initial stderr is unbuffered
3739 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3741 #ifdef PERLIO_USING_CRLF
3742 # ifdef PERLIO_IS_BINMODE_FD
3743 if (PERLIO_IS_BINMODE_FD(fd))
3744 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3748 * do something about failing setmode()? --jhi
3750 PerlLIO_setmode(fd, O_BINARY);
3759 * This "flush" is akin to sfio's sync in that it handles files in either
3760 * read or write state. For write state, we put the postponed data through
3761 * the next layers. For read state, we seek() the next layers to the
3762 * offset given by current position in the buffer, and discard the buffer
3763 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3764 * in any case?). Then the pass the stick further in chain.
3767 PerlIOBuf_flush(pTHX_ PerlIO *f)
3769 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3771 PerlIO *n = PerlIONext(f);
3772 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3774 * write() the buffer
3776 const STDCHAR *buf = b->buf;
3777 const STDCHAR *p = buf;
3778 while (p < b->ptr) {
3779 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3783 else if (count < 0 || PerlIO_error(n)) {
3784 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3789 b->posn += (p - buf);
3791 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3792 STDCHAR *buf = PerlIO_get_base(f);
3794 * Note position change
3796 b->posn += (b->ptr - buf);
3797 if (b->ptr < b->end) {
3798 /* We did not consume all of it - try and seek downstream to
3799 our logical position
3801 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3802 /* Reload n as some layers may pop themselves on seek */
3803 b->posn = PerlIO_tell(n = PerlIONext(f));
3806 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3807 data is lost for good - so return saying "ok" having undone
3810 b->posn -= (b->ptr - buf);
3815 b->ptr = b->end = b->buf;
3816 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3817 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3818 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3823 /* This discards the content of the buffer after b->ptr, and rereads
3824 * the buffer from the position off in the layer downstream; here off
3825 * is at offset corresponding to b->ptr - b->buf.
3828 PerlIOBuf_fill(pTHX_ PerlIO *f)
3830 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3831 PerlIO *n = PerlIONext(f);
3834 * Down-stream flush is defined not to loose read data so is harmless.
3835 * we would not normally be fill'ing if there was data left in anycase.
3837 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3839 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3840 PerlIOBase_flush_linebuf(aTHX);
3843 PerlIO_get_base(f); /* allocate via vtable */
3845 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3847 b->ptr = b->end = b->buf;
3849 if (!PerlIOValid(n)) {
3850 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3854 if (PerlIO_fast_gets(n)) {
3856 * Layer below is also buffered. We do _NOT_ want to call its
3857 * ->Read() because that will loop till it gets what we asked for
3858 * which may hang on a pipe etc. Instead take anything it has to
3859 * hand, or ask it to fill _once_.
3861 avail = PerlIO_get_cnt(n);
3863 avail = PerlIO_fill(n);
3865 avail = PerlIO_get_cnt(n);
3867 if (!PerlIO_error(n) && PerlIO_eof(n))
3872 STDCHAR *ptr = PerlIO_get_ptr(n);
3873 const SSize_t cnt = avail;
3874 if (avail > (SSize_t)b->bufsiz)
3876 Copy(ptr, b->buf, avail, STDCHAR);
3877 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3881 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3885 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3887 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3890 b->end = b->buf + avail;
3891 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3896 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3898 if (PerlIOValid(f)) {
3899 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3902 return PerlIOBase_read(aTHX_ f, vbuf, count);
3908 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3910 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3911 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3914 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3919 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3921 * Buffer is already a read buffer, we can overwrite any chars
3922 * which have been read back to buffer start
3924 avail = (b->ptr - b->buf);
3928 * Buffer is idle, set it up so whole buffer is available for
3932 b->end = b->buf + avail;
3934 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3936 * Buffer extends _back_ from where we are now
3938 b->posn -= b->bufsiz;
3940 if (avail > (SSize_t) count) {
3942 * If we have space for more than count, just move count
3950 * In simple stdio-like ungetc() case chars will be already
3953 if (buf != b->ptr) {
3954 Copy(buf, b->ptr, avail, STDCHAR);
3958 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3962 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3968 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3970 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3971 const STDCHAR *buf = (const STDCHAR *) vbuf;
3972 const STDCHAR *flushptr = buf;
3976 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3978 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3979 if (PerlIO_flush(f) != 0) {
3983 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3984 flushptr = buf + count;
3985 while (flushptr > buf && *(flushptr - 1) != '\n')
3989 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3990 if ((SSize_t) count < avail)
3992 if (flushptr > buf && flushptr <= buf + avail)
3993 avail = flushptr - buf;
3994 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3996 Copy(buf, b->ptr, avail, STDCHAR);
4001 if (buf == flushptr)
4004 if (b->ptr >= (b->buf + b->bufsiz))
4007 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4013 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4016 if ((code = PerlIO_flush(f)) == 0) {
4017 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4018 code = PerlIO_seek(PerlIONext(f), offset, whence);
4020 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4021 b->posn = PerlIO_tell(PerlIONext(f));
4028 PerlIOBuf_tell(pTHX_ PerlIO *f)
4030 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4032 * b->posn is file position where b->buf was read, or will be written
4034 Off_t posn = b->posn;
4035 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4036 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4038 /* As O_APPEND files are normally shared in some sense it is better
4043 /* when file is NOT shared then this is sufficient */
4044 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4046 posn = b->posn = PerlIO_tell(PerlIONext(f));
4050 * If buffer is valid adjust position by amount in buffer
4052 posn += (b->ptr - b->buf);
4058 PerlIOBuf_popped(pTHX_ PerlIO *f)
4060 const IV code = PerlIOBase_popped(aTHX_ f);
4061 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4062 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4065 b->ptr = b->end = b->buf = NULL;
4066 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4071 PerlIOBuf_close(pTHX_ PerlIO *f)
4073 const IV code = PerlIOBase_close(aTHX_ f);
4074 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4075 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4078 b->ptr = b->end = b->buf = NULL;
4079 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4084 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4086 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4093 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4095 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4098 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4099 return (b->end - b->ptr);
4104 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4106 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4107 PERL_UNUSED_CONTEXT;
4112 Newxz(b->buf,b->bufsiz, STDCHAR);
4114 b->buf = (STDCHAR *) & b->oneword;
4115 b->bufsiz = sizeof(b->oneword);
4117 b->end = b->ptr = b->buf;
4123 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4125 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4128 return (b->end - b->buf);
4132 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4134 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4136 PERL_UNUSED_ARG(cnt);
4141 assert(PerlIO_get_cnt(f) == cnt);
4142 assert(b->ptr >= b->buf);
4143 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4147 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4149 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4154 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4155 sizeof(PerlIO_funcs),
4158 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4162 PerlIOBase_binmode, /* binmode */
4176 PerlIOBase_clearerr,
4177 PerlIOBase_setlinebuf,
4182 PerlIOBuf_set_ptrcnt,
4185 /*--------------------------------------------------------------------------------------*/
4187 * Temp layer to hold unread chars when cannot do it any other way
4191 PerlIOPending_fill(pTHX_ PerlIO *f)
4194 * Should never happen
4201 PerlIOPending_close(pTHX_ PerlIO *f)
4204 * A tad tricky - flush pops us, then we close new top
4207 return PerlIO_close(f);
4211 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4214 * A tad tricky - flush pops us, then we seek new top
4217 return PerlIO_seek(f, offset, whence);
4222 PerlIOPending_flush(pTHX_ PerlIO *f)
4224 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4225 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4229 PerlIO_pop(aTHX_ f);
4234 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4240 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4245 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4247 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4248 PerlIOl * const l = PerlIOBase(f);
4250 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4251 * etc. get muddled when it changes mid-string when we auto-pop.
4253 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4254 (PerlIOBase(PerlIONext(f))->
4255 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4260 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4262 SSize_t avail = PerlIO_get_cnt(f);
4264 if ((SSize_t)count < avail)
4267 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4268 if (got >= 0 && got < (SSize_t)count) {
4269 const SSize_t more =
4270 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4271 if (more >= 0 || got == 0)
4277 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4278 sizeof(PerlIO_funcs),
4281 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4282 PerlIOPending_pushed,
4285 PerlIOBase_binmode, /* binmode */
4294 PerlIOPending_close,
4295 PerlIOPending_flush,
4299 PerlIOBase_clearerr,
4300 PerlIOBase_setlinebuf,
4305 PerlIOPending_set_ptrcnt,
4310 /*--------------------------------------------------------------------------------------*/
4312 * crlf - translation On read translate CR,LF to "\n" we do this by
4313 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4314 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4316 * c->nl points on the first byte of CR LF pair when it is temporarily
4317 * replaced by LF, or to the last CR of the buffer. In the former case
4318 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4319 * that it ends at c->nl; these two cases can be distinguished by
4320 * *c->nl. c->nl is set during _getcnt() call, and unset during
4321 * _unread() and _flush() calls.
4322 * It only matters for read operations.
4326 PerlIOBuf base; /* PerlIOBuf stuff */
4327 STDCHAR *nl; /* Position of crlf we "lied" about in the
4331 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4332 * Otherwise the :crlf layer would always revert back to
4336 S_inherit_utf8_flag(PerlIO *f)
4338 PerlIO *g = PerlIONext(f);
4339 if (PerlIOValid(g)) {
4340 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4341 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4347 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4350 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4351 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4353 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4354 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4355 PerlIOBase(f)->flags);
4358 /* Enable the first CRLF capable layer you can find, but if none
4359 * found, the one we just pushed is fine. This results in at
4360 * any given moment at most one CRLF-capable layer being enabled
4361 * in the whole layer stack. */
4362 PerlIO *g = PerlIONext(f);
4363 while (PerlIOValid(g)) {
4364 PerlIOl *b = PerlIOBase(g);
4365 if (b && b->tab == &PerlIO_crlf) {
4366 if (!(b->flags & PERLIO_F_CRLF))
4367 b->flags |= PERLIO_F_CRLF;
4368 S_inherit_utf8_flag(g);
4369 PerlIO_pop(aTHX_ f);
4375 S_inherit_utf8_flag(f);
4381 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4383 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4384 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4388 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4389 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4391 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4392 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4394 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4399 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4400 b->end = b->ptr = b->buf + b->bufsiz;
4401 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4402 b->posn -= b->bufsiz;
4404 while (count > 0 && b->ptr > b->buf) {
4405 const int ch = *--buf;
4407 if (b->ptr - 2 >= b->buf) {
4414 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4415 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4431 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4433 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4435 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4438 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4439 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4440 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4441 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4443 while (nl < b->end && *nl != 0xd)
4445 if (nl < b->end && *nl == 0xd) {
4447 if (nl + 1 < b->end) {
4454 * Not CR,LF but just CR
4462 * Blast - found CR as last char in buffer
4467 * They may not care, defer work as long as
4471 return (nl - b->ptr);
4475 b->ptr++; /* say we have read it as far as
4476 * flush() is concerned */
4477 b->buf++; /* Leave space in front of buffer */
4478 /* Note as we have moved buf up flush's
4480 will naturally make posn point at CR
4482 b->bufsiz--; /* Buffer is thus smaller */
4483 code = PerlIO_fill(f); /* Fetch some more */
4484 b->bufsiz++; /* Restore size for next time */
4485 b->buf--; /* Point at space */
4486 b->ptr = nl = b->buf; /* Which is what we hand
4488 *nl = 0xd; /* Fill in the CR */
4490 goto test; /* fill() call worked */
4492 * CR at EOF - just fall through
4494 /* Should we clear EOF though ??? */
4499 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4505 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4507 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4508 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4514 if (ptr == b->end && *c->nl == 0xd) {
4515 /* Defered CR at end of buffer case - we lied about count */
4528 * Test code - delete when it works ...
4530 IV flags = PerlIOBase(f)->flags;
4531 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4532 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4533 /* Defered CR at end of buffer case - we lied about count */
4539 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4540 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4541 flags, c->nl, b->end, cnt);
4548 * They have taken what we lied about
4556 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4560 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4562 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4563 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4565 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4566 const STDCHAR *buf = (const STDCHAR *) vbuf;
4567 const STDCHAR * const ebuf = buf + count;
4570 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4572 while (buf < ebuf) {
4573 const STDCHAR * const eptr = b->buf + b->bufsiz;
4574 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4575 while (buf < ebuf && b->ptr < eptr) {
4577 if ((b->ptr + 2) > eptr) {
4585 *(b->ptr)++ = 0xd; /* CR */
4586 *(b->ptr)++ = 0xa; /* LF */
4588 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4595 *(b->ptr)++ = *buf++;
4597 if (b->ptr >= eptr) {
4603 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4605 return (buf - (STDCHAR *) vbuf);
4610 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4612 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4617 return PerlIOBuf_flush(aTHX_ f);
4621 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4623 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4624 /* In text mode - flush any pending stuff and flip it */
4625 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4626 #ifndef PERLIO_USING_CRLF
4627 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4628 PerlIO_pop(aTHX_ f);
4634 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4635 sizeof(PerlIO_funcs),
4638 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4640 PerlIOBuf_popped, /* popped */
4642 PerlIOCrlf_binmode, /* binmode */
4646 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4647 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4648 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4656 PerlIOBase_clearerr,
4657 PerlIOBase_setlinebuf,
4662 PerlIOCrlf_set_ptrcnt,
4666 /*--------------------------------------------------------------------------------------*/
4668 * mmap as "buffer" layer
4672 PerlIOBuf base; /* PerlIOBuf stuff */
4673 Mmap_t mptr; /* Mapped address */
4674 Size_t len; /* mapped length */
4675 STDCHAR *bbuf; /* malloced buffer if map fails */
4679 PerlIOMmap_map(pTHX_ PerlIO *f)
4682 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4683 const IV flags = PerlIOBase(f)->flags;
4687 if (flags & PERLIO_F_CANREAD) {
4688 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4689 const int fd = PerlIO_fileno(f);
4691 code = Fstat(fd, &st);
4692 if (code == 0 && S_ISREG(st.st_mode)) {
4693 SSize_t len = st.st_size - b->posn;
4696 if (PL_mmap_page_size <= 0)
4697 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4701 * This is a hack - should never happen - open should
4704 b->posn = PerlIO_tell(PerlIONext(f));
4706 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4707 len = st.st_size - posn;
4708 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4709 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4710 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4711 madvise(m->mptr, len, MADV_SEQUENTIAL);
4713 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4714 madvise(m->mptr, len, MADV_WILLNEED);
4716 PerlIOBase(f)->flags =
4717 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4718 b->end = ((STDCHAR *) m->mptr) + len;
4719 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4728 PerlIOBase(f)->flags =
4729 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4731 b->ptr = b->end = b->ptr;
4740 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4742 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4745 PerlIOBuf * const b = &m->base;
4747 /* The munmap address argument is tricky: depending on the
4748 * standard it is either "void *" or "caddr_t" (which is
4749 * usually "char *" (signed or unsigned). If we cast it
4750 * to "void *", those that have it caddr_t and an uptight
4751 * C++ compiler, will freak out. But casting it as char*
4752 * should work. Maybe. (Using Mmap_t figured out by
4753 * Configure doesn't always work, apparently.) */
4754 code = munmap((char*)m->mptr, m->len);
4758 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4761 b->ptr = b->end = b->buf;
4762 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4768 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4770 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4771 PerlIOBuf * const b = &m->base;
4772 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4774 * Already have a readbuffer in progress
4780 * We have a write buffer or flushed PerlIOBuf read buffer
4782 m->bbuf = b->buf; /* save it in case we need it again */
4783 b->buf = NULL; /* Clear to trigger below */
4786 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4789 * Map did not work - recover PerlIOBuf buffer if we have one
4794 b->ptr = b->end = b->buf;
4797 return PerlIOBuf_get_base(aTHX_ f);
4801 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4803 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4804 PerlIOBuf * const b = &m->base;
4805 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4807 if (b->ptr && (b->ptr - count) >= b->buf
4808 && memEQ(b->ptr - count, vbuf, count)) {
4810 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4815 * Loose the unwritable mapped buffer
4819 * If flush took the "buffer" see if we have one from before
4821 if (!b->buf && m->bbuf)
4824 PerlIOBuf_get_base(aTHX_ f);
4828 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4832 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4834 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4835 PerlIOBuf * const b = &m->base;
4837 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4839 * No, or wrong sort of, buffer
4842 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4846 * If unmap took the "buffer" see if we have one from before
4848 if (!b->buf && m->bbuf)
4851 PerlIOBuf_get_base(aTHX_ f);
4855 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4859 PerlIOMmap_flush(pTHX_ PerlIO *f)
4861 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4862 PerlIOBuf * const b = &m->base;
4863 IV code = PerlIOBuf_flush(aTHX_ f);
4865 * Now we are "synced" at PerlIOBuf level
4872 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4877 * We seem to have a PerlIOBuf buffer which was not mapped
4878 * remember it in case we need one later
4887 PerlIOMmap_fill(pTHX_ PerlIO *f)
4889 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4890 IV code = PerlIO_flush(f);
4891 if (code == 0 && !b->buf) {
4892 code = PerlIOMmap_map(aTHX_ f);
4894 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4895 code = PerlIOBuf_fill(aTHX_ f);
4901 PerlIOMmap_close(pTHX_ PerlIO *f)
4903 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4904 PerlIOBuf * const b = &m->base;
4905 IV code = PerlIO_flush(f);
4909 b->ptr = b->end = b->buf;
4911 if (PerlIOBuf_close(aTHX_ f) != 0)
4917 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4919 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4923 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4924 sizeof(PerlIO_funcs),
4927 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4931 PerlIOBase_binmode, /* binmode */
4945 PerlIOBase_clearerr,
4946 PerlIOBase_setlinebuf,
4947 PerlIOMmap_get_base,
4951 PerlIOBuf_set_ptrcnt,
4954 #endif /* HAS_MMAP */
4957 Perl_PerlIO_stdin(pTHX)
4961 PerlIO_stdstreams(aTHX);
4963 return &PL_perlio[1];
4967 Perl_PerlIO_stdout(pTHX)
4971 PerlIO_stdstreams(aTHX);
4973 return &PL_perlio[2];
4977 Perl_PerlIO_stderr(pTHX)
4981 PerlIO_stdstreams(aTHX);
4983 return &PL_perlio[3];
4986 /*--------------------------------------------------------------------------------------*/
4989 PerlIO_getname(PerlIO *f, char *buf)
4994 bool exported = FALSE;
4995 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4997 stdio = PerlIO_exportFILE(f,0);
5001 name = fgetname(stdio, buf);
5002 if (exported) PerlIO_releaseFILE(f,stdio);
5007 PERL_UNUSED_ARG(buf);
5008 Perl_croak(aTHX_ "Don't know how to get file name");
5014 /*--------------------------------------------------------------------------------------*/
5016 * Functions which can be called on any kind of PerlIO implemented in
5020 #undef PerlIO_fdopen
5022 PerlIO_fdopen(int fd, const char *mode)
5025 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5030 PerlIO_open(const char *path, const char *mode)
5033 SV *name = sv_2mortal(newSVpv(path, 0));
5034 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5037 #undef Perlio_reopen
5039 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5042 SV *name = sv_2mortal(newSVpv(path,0));
5043 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5048 PerlIO_getc(PerlIO *f)
5052 if ( 1 == PerlIO_read(f, buf, 1) ) {
5053 return (unsigned char) buf[0];
5058 #undef PerlIO_ungetc
5060 PerlIO_ungetc(PerlIO *f, int ch)
5065 if (PerlIO_unread(f, &buf, 1) == 1)
5073 PerlIO_putc(PerlIO *f, int ch)
5077 return PerlIO_write(f, &buf, 1);
5082 PerlIO_puts(PerlIO *f, const char *s)
5085 return PerlIO_write(f, s, strlen(s));
5088 #undef PerlIO_rewind
5090 PerlIO_rewind(PerlIO *f)
5093 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5097 #undef PerlIO_vprintf
5099 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5108 Perl_va_copy(ap, apc);
5109 sv = vnewSVpvf(fmt, &apc);
5111 sv = vnewSVpvf(fmt, &ap);
5113 s = SvPV_const(sv, len);
5114 wrote = PerlIO_write(f, s, len);
5119 #undef PerlIO_printf
5121 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5126 result = PerlIO_vprintf(f, fmt, ap);
5131 #undef PerlIO_stdoutf
5133 PerlIO_stdoutf(const char *fmt, ...)
5139 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5144 #undef PerlIO_tmpfile
5146 PerlIO_tmpfile(void)
5151 const int fd = win32_tmpfd();
5153 f = PerlIO_fdopen(fd, "w+b");
5155 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5157 char tempname[] = "/tmp/PerlIO_XXXXXX";
5158 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5161 * I have no idea how portable mkstemp() is ... NI-S
5163 if (tmpdir && *tmpdir) {
5164 /* if TMPDIR is set and not empty, we try that first */
5165 sv = newSVpv(tmpdir, 0);
5166 sv_catpv(sv, tempname + 4);
5167 fd = mkstemp(SvPVX(sv));
5171 /* else we try /tmp */
5172 fd = mkstemp(tempname);
5175 f = PerlIO_fdopen(fd, "w+");
5177 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5178 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5181 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5182 FILE * const stdio = PerlSIO_tmpfile();
5185 f = PerlIO_fdopen(fileno(stdio), "w+");
5187 # endif /* else HAS_MKSTEMP */
5188 #endif /* else WIN32 */
5195 #endif /* USE_SFIO */
5196 #endif /* PERLIO_IS_STDIO */
5198 /*======================================================================================*/
5200 * Now some functions in terms of above which may be needed even if we are
5201 * not in true PerlIO mode
5204 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5207 const char *direction = NULL;
5210 * Need to supply default layer info from open.pm
5216 if (mode && mode[0] != 'r') {
5217 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5218 direction = "open>";
5220 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5221 direction = "open<";
5226 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5227 0, direction, 5, 0, 0);
5230 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5235 #undef PerlIO_setpos
5237 PerlIO_setpos(PerlIO *f, SV *pos)
5242 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5243 if (f && len == sizeof(Off_t))
5244 return PerlIO_seek(f, *posn, SEEK_SET);
5246 SETERRNO(EINVAL, SS_IVCHAN);
5250 #undef PerlIO_setpos
5252 PerlIO_setpos(PerlIO *f, SV *pos)
5257 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5258 if (f && len == sizeof(Fpos_t)) {
5259 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5260 return fsetpos64(f, fpos);
5262 return fsetpos(f, fpos);
5266 SETERRNO(EINVAL, SS_IVCHAN);
5272 #undef PerlIO_getpos
5274 PerlIO_getpos(PerlIO *f, SV *pos)
5277 Off_t posn = PerlIO_tell(f);
5278 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5279 return (posn == (Off_t) - 1) ? -1 : 0;
5282 #undef PerlIO_getpos
5284 PerlIO_getpos(PerlIO *f, SV *pos)
5289 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5290 code = fgetpos64(f, &fpos);
5292 code = fgetpos(f, &fpos);
5294 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5299 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5302 vprintf(char *pat, char *args)
5304 _doprnt(pat, args, stdout);
5305 return 0; /* wrong, but perl doesn't use the return
5310 vfprintf(FILE *fd, char *pat, char *args)
5312 _doprnt(pat, args, fd);
5313 return 0; /* wrong, but perl doesn't use the return
5319 #ifndef PerlIO_vsprintf
5321 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5324 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5325 PERL_UNUSED_CONTEXT;
5327 #ifndef PERL_MY_VSNPRINTF_GUARDED
5328 if (val < 0 || (n > 0 ? val >= n : 0)) {
5329 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5336 #ifndef PerlIO_sprintf
5338 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5343 result = PerlIO_vsprintf(s, n, fmt, ap);
5351 * c-indentation-style: bsd
5353 * indent-tabs-mode: t
5356 * ex: set ts=8 sts=4 sw=4 noet: