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 "%s (%d) does not match %s (%d)",
1216 "PerlIO layer function table size", tab->fsize,
1217 "size expected by this perl", sizeof(PerlIO_funcs) );
1221 if (tab->size < sizeof(PerlIOl)) {
1223 "%s (%d) smaller than %s (%d)",
1224 "PerlIO layer instance size", tab->size,
1225 "size expected by this perl", sizeof(PerlIOl) );
1227 /* Real layer with a data area */
1230 Newxz(temp, tab->size, char);
1234 l->tab = (PerlIO_funcs*) tab;
1236 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1237 (void*)f, tab->name,
1238 (mode) ? mode : "(Null)", (void*)arg);
1239 if (*l->tab->Pushed &&
1241 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1242 PerlIO_pop(aTHX_ f);
1251 /* Pseudo-layer where push does its own stack adjust */
1252 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1253 (mode) ? mode : "(Null)", (void*)arg);
1255 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1263 PerlIOBase_binmode(pTHX_ PerlIO *f)
1265 if (PerlIOValid(f)) {
1266 /* Is layer suitable for raw stream ? */
1267 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1268 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1269 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1272 /* Not suitable - pop it */
1273 PerlIO_pop(aTHX_ f);
1281 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1283 PERL_UNUSED_ARG(mode);
1284 PERL_UNUSED_ARG(arg);
1285 PERL_UNUSED_ARG(tab);
1287 if (PerlIOValid(f)) {
1292 * Strip all layers that are not suitable for a raw stream
1295 while (t && (l = *t)) {
1296 if (l->tab->Binmode) {
1297 /* Has a handler - normal case */
1298 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1300 /* Layer still there - move down a layer */
1309 /* No handler - pop it */
1310 PerlIO_pop(aTHX_ t);
1313 if (PerlIOValid(f)) {
1314 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1322 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1323 PerlIO_list_t *layers, IV n, IV max)
1327 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1329 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1340 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1344 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1345 code = PerlIO_parse_layers(aTHX_ layers, names);
1347 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1349 PerlIO_list_free(aTHX_ layers);
1355 /*--------------------------------------------------------------------------------------*/
1357 * Given the abstraction above the public API functions
1361 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1363 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1364 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1365 iotype, mode, (names) ? names : "(Null)");
1368 /* Do not flush etc. if (e.g.) switching encodings.
1369 if a pushed layer knows it needs to flush lower layers
1370 (for example :unix which is never going to call them)
1371 it can do the flush when it is pushed.
1373 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1376 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1377 #ifdef PERLIO_USING_CRLF
1378 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1379 O_BINARY so we can look for it in mode.
1381 if (!(mode & O_BINARY)) {
1383 /* FIXME?: Looking down the layer stack seems wrong,
1384 but is a way of reaching past (say) an encoding layer
1385 to flip CRLF-ness of the layer(s) below
1388 /* Perhaps we should turn on bottom-most aware layer
1389 e.g. Ilya's idea that UNIX TTY could serve
1391 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1392 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1393 /* Not in text mode - flush any pending stuff and flip it */
1395 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1397 /* Only need to turn it on in one layer so we are done */
1402 /* Not finding a CRLF aware layer presumably means we are binary
1403 which is not what was requested - so we failed
1404 We _could_ push :crlf layer but so could caller
1409 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1410 So code that used to be here is now in PerlIORaw_pushed().
1412 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1417 PerlIO__close(pTHX_ PerlIO *f)
1419 if (PerlIOValid(f)) {
1420 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1421 if (tab && tab->Close)
1422 return (*tab->Close)(aTHX_ f);
1424 return PerlIOBase_close(aTHX_ f);
1427 SETERRNO(EBADF, SS_IVCHAN);
1433 Perl_PerlIO_close(pTHX_ PerlIO *f)
1435 const int code = PerlIO__close(aTHX_ f);
1436 while (PerlIOValid(f)) {
1437 PerlIO_pop(aTHX_ f);
1443 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1446 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1450 static PerlIO_funcs *
1451 PerlIO_layer_from_ref(pTHX_ SV *sv)
1455 * For any scalar type load the handler which is bundled with perl
1457 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1458 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1459 /* This isn't supposed to happen, since PerlIO::scalar is core,
1460 * but could happen anyway in smaller installs or with PAR */
1462 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1467 * For other types allow if layer is known but don't try and load it
1469 switch (SvTYPE(sv)) {
1471 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1473 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1475 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1477 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1484 PerlIO_resolve_layers(pTHX_ const char *layers,
1485 const char *mode, int narg, SV **args)
1488 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1491 PerlIO_stdstreams(aTHX);
1493 SV * const arg = *args;
1495 * If it is a reference but not an object see if we have a handler
1498 if (SvROK(arg) && !sv_isobject(arg)) {
1499 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1501 def = PerlIO_list_alloc(aTHX);
1502 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1506 * Don't fail if handler cannot be found :via(...) etc. may do
1507 * something sensible else we will just stringfy and open
1512 if (!layers || !*layers)
1513 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1514 if (layers && *layers) {
1517 av = PerlIO_clone_list(aTHX_ def, NULL);
1522 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1526 PerlIO_list_free(aTHX_ av);
1538 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1539 int imode, int perm, PerlIO *f, int narg, SV **args)
1542 if (!f && narg == 1 && *args == &PL_sv_undef) {
1543 if ((f = PerlIO_tmpfile())) {
1544 if (!layers || !*layers)
1545 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1546 if (layers && *layers)
1547 PerlIO_apply_layers(aTHX_ f, mode, layers);
1551 PerlIO_list_t *layera;
1553 PerlIO_funcs *tab = NULL;
1554 if (PerlIOValid(f)) {
1556 * This is "reopen" - it is not tested as perl does not use it
1560 layera = PerlIO_list_alloc(aTHX);
1564 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1565 PerlIO_list_push(aTHX_ layera, l->tab,
1566 (arg) ? arg : &PL_sv_undef);
1568 l = *PerlIONext(&l);
1572 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1578 * Start at "top" of layer stack
1580 n = layera->cur - 1;
1582 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1591 * Found that layer 'n' can do opens - call it
1593 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1594 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1596 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1597 tab->name, layers ? layers : "(Null)", mode, fd,
1598 imode, perm, (void*)f, narg, (void*)args);
1600 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1603 SETERRNO(EINVAL, LIB_INVARG);
1607 if (n + 1 < layera->cur) {
1609 * More layers above the one that we used to open -
1612 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1613 /* If pushing layers fails close the file */
1620 PerlIO_list_free(aTHX_ layera);
1627 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1629 PERL_ARGS_ASSERT_PERLIO_READ;
1631 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1635 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1637 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1639 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1643 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1645 PERL_ARGS_ASSERT_PERLIO_WRITE;
1647 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1651 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1653 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1657 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1659 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1663 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1668 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1670 if (tab && tab->Flush)
1671 return (*tab->Flush) (aTHX_ f);
1673 return 0; /* If no Flush defined, silently succeed. */
1676 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1677 SETERRNO(EBADF, SS_IVCHAN);
1683 * Is it good API design to do flush-all on NULL, a potentially
1684 * errorneous input? Maybe some magical value (PerlIO*
1685 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1686 * things on fflush(NULL), but should we be bound by their design
1689 PerlIO **table = &PL_perlio;
1691 while ((f = *table)) {
1693 table = (PerlIO **) (f++);
1694 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1695 if (*f && PerlIO_flush(f) != 0)
1705 PerlIOBase_flush_linebuf(pTHX)
1708 PerlIO **table = &PL_perlio;
1710 while ((f = *table)) {
1712 table = (PerlIO **) (f++);
1713 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1716 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1717 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1725 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1727 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1731 PerlIO_isutf8(PerlIO *f)
1734 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1736 SETERRNO(EBADF, SS_IVCHAN);
1742 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1744 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1748 Perl_PerlIO_error(pTHX_ PerlIO *f)
1750 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1754 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1756 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1760 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1762 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1766 PerlIO_has_base(PerlIO *f)
1768 if (PerlIOValid(f)) {
1769 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1772 return (tab->Get_base != NULL);
1779 PerlIO_fast_gets(PerlIO *f)
1781 if (PerlIOValid(f)) {
1782 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1783 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1786 return (tab->Set_ptrcnt != NULL);
1794 PerlIO_has_cntptr(PerlIO *f)
1796 if (PerlIOValid(f)) {
1797 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1800 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1807 PerlIO_canset_cnt(PerlIO *f)
1809 if (PerlIOValid(f)) {
1810 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1813 return (tab->Set_ptrcnt != NULL);
1820 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1822 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1826 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1828 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1832 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1834 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1838 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1840 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1844 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1846 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1850 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1852 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1856 /*--------------------------------------------------------------------------------------*/
1858 * utf8 and raw dummy layers
1862 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1864 PERL_UNUSED_CONTEXT;
1865 PERL_UNUSED_ARG(mode);
1866 PERL_UNUSED_ARG(arg);
1867 if (PerlIOValid(f)) {
1868 if (tab->kind & PERLIO_K_UTF8)
1869 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1871 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1877 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1878 sizeof(PerlIO_funcs),
1881 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1901 NULL, /* get_base */
1902 NULL, /* get_bufsiz */
1905 NULL, /* set_ptrcnt */
1908 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1909 sizeof(PerlIO_funcs),
1932 NULL, /* get_base */
1933 NULL, /* get_bufsiz */
1936 NULL, /* set_ptrcnt */
1940 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1941 IV n, const char *mode, int fd, int imode, int perm,
1942 PerlIO *old, int narg, SV **args)
1944 PerlIO_funcs * const tab = PerlIO_default_btm();
1945 PERL_UNUSED_ARG(self);
1946 if (tab && tab->Open)
1947 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1949 SETERRNO(EINVAL, LIB_INVARG);
1953 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1954 sizeof(PerlIO_funcs),
1977 NULL, /* get_base */
1978 NULL, /* get_bufsiz */
1981 NULL, /* set_ptrcnt */
1983 /*--------------------------------------------------------------------------------------*/
1984 /*--------------------------------------------------------------------------------------*/
1986 * "Methods" of the "base class"
1990 PerlIOBase_fileno(pTHX_ PerlIO *f)
1992 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1996 PerlIO_modestr(PerlIO * f, char *buf)
1999 if (PerlIOValid(f)) {
2000 const IV flags = PerlIOBase(f)->flags;
2001 if (flags & PERLIO_F_APPEND) {
2003 if (flags & PERLIO_F_CANREAD) {
2007 else if (flags & PERLIO_F_CANREAD) {
2009 if (flags & PERLIO_F_CANWRITE)
2012 else if (flags & PERLIO_F_CANWRITE) {
2014 if (flags & PERLIO_F_CANREAD) {
2018 #ifdef PERLIO_USING_CRLF
2019 if (!(flags & PERLIO_F_CRLF))
2029 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2031 PerlIOl * const l = PerlIOBase(f);
2032 PERL_UNUSED_CONTEXT;
2033 PERL_UNUSED_ARG(arg);
2035 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2036 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2037 if (tab->Set_ptrcnt != NULL)
2038 l->flags |= PERLIO_F_FASTGETS;
2040 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2044 l->flags |= PERLIO_F_CANREAD;
2047 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2050 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2053 SETERRNO(EINVAL, LIB_INVARG);
2059 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2062 l->flags &= ~PERLIO_F_CRLF;
2065 l->flags |= PERLIO_F_CRLF;
2068 SETERRNO(EINVAL, LIB_INVARG);
2075 l->flags |= l->next->flags &
2076 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2081 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2082 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2083 l->flags, PerlIO_modestr(f, temp));
2089 PerlIOBase_popped(pTHX_ PerlIO *f)
2091 PERL_UNUSED_CONTEXT;
2097 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2100 * Save the position as current head considers it
2102 const Off_t old = PerlIO_tell(f);
2103 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2104 PerlIOSelf(f, PerlIOBuf)->posn = old;
2105 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2109 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2111 STDCHAR *buf = (STDCHAR *) vbuf;
2113 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2114 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2115 SETERRNO(EBADF, SS_IVCHAN);
2121 SSize_t avail = PerlIO_get_cnt(f);
2124 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2126 STDCHAR *ptr = PerlIO_get_ptr(f);
2127 Copy(ptr, buf, take, STDCHAR);
2128 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2131 if (avail == 0) /* set_ptrcnt could have reset avail */
2134 if (count > 0 && avail <= 0) {
2135 if (PerlIO_fill(f) != 0)
2140 return (buf - (STDCHAR *) vbuf);
2146 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2148 PERL_UNUSED_CONTEXT;
2154 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2156 PERL_UNUSED_CONTEXT;
2162 PerlIOBase_close(pTHX_ PerlIO *f)
2165 if (PerlIOValid(f)) {
2166 PerlIO *n = PerlIONext(f);
2167 code = PerlIO_flush(f);
2168 PerlIOBase(f)->flags &=
2169 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2170 while (PerlIOValid(n)) {
2171 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2172 if (tab && tab->Close) {
2173 if ((*tab->Close)(aTHX_ n) != 0)
2178 PerlIOBase(n)->flags &=
2179 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2185 SETERRNO(EBADF, SS_IVCHAN);
2191 PerlIOBase_eof(pTHX_ PerlIO *f)
2193 PERL_UNUSED_CONTEXT;
2194 if (PerlIOValid(f)) {
2195 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2201 PerlIOBase_error(pTHX_ PerlIO *f)
2203 PERL_UNUSED_CONTEXT;
2204 if (PerlIOValid(f)) {
2205 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2211 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2213 if (PerlIOValid(f)) {
2214 PerlIO * const n = PerlIONext(f);
2215 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2222 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2224 PERL_UNUSED_CONTEXT;
2225 if (PerlIOValid(f)) {
2226 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2231 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2237 arg = sv_dup(arg, param);
2238 SvREFCNT_inc_simple_void_NN(arg);
2242 return newSVsv(arg);
2245 PERL_UNUSED_ARG(param);
2246 return newSVsv(arg);
2251 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2253 PerlIO * const nexto = PerlIONext(o);
2254 if (PerlIOValid(nexto)) {
2255 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2256 if (tab && tab->Dup)
2257 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2259 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2262 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2265 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2266 self->name, (void*)f, (void*)o, (void*)param);
2268 arg = (*self->Getarg)(aTHX_ o, param, flags);
2269 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2270 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2271 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2277 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2279 /* Must be called with PL_perlio_mutex locked. */
2281 S_more_refcounted_fds(pTHX_ const int new_fd) {
2283 const int old_max = PL_perlio_fd_refcnt_size;
2284 const int new_max = 16 + (new_fd & ~15);
2287 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2288 old_max, new_fd, new_max);
2290 if (new_fd < old_max) {
2294 assert (new_max > new_fd);
2296 /* Use plain realloc() since we need this memory to be really
2297 * global and visible to all the interpreters and/or threads. */
2298 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2302 MUTEX_UNLOCK(&PL_perlio_mutex);
2304 /* Can't use PerlIO to write as it allocates memory */
2305 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2306 PL_no_mem, strlen(PL_no_mem));
2310 PL_perlio_fd_refcnt_size = new_max;
2311 PL_perlio_fd_refcnt = new_array;
2313 PerlIO_debug("Zeroing %p, %d\n",
2314 (void*)(new_array + old_max),
2317 Zero(new_array + old_max, new_max - old_max, int);
2324 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2325 PERL_UNUSED_CONTEXT;
2329 PerlIOUnix_refcnt_inc(int fd)
2336 MUTEX_LOCK(&PL_perlio_mutex);
2338 if (fd >= PL_perlio_fd_refcnt_size)
2339 S_more_refcounted_fds(aTHX_ fd);
2341 PL_perlio_fd_refcnt[fd]++;
2342 if (PL_perlio_fd_refcnt[fd] <= 0) {
2343 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2344 fd, PL_perlio_fd_refcnt[fd]);
2346 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2347 fd, PL_perlio_fd_refcnt[fd]);
2350 MUTEX_UNLOCK(&PL_perlio_mutex);
2353 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2358 PerlIOUnix_refcnt_dec(int fd)
2365 MUTEX_LOCK(&PL_perlio_mutex);
2367 if (fd >= PL_perlio_fd_refcnt_size) {
2368 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2369 fd, PL_perlio_fd_refcnt_size);
2371 if (PL_perlio_fd_refcnt[fd] <= 0) {
2372 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2373 fd, PL_perlio_fd_refcnt[fd]);
2375 cnt = --PL_perlio_fd_refcnt[fd];
2376 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2378 MUTEX_UNLOCK(&PL_perlio_mutex);
2381 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2387 PerlIO_cleanup(pTHX)
2392 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2394 PerlIO_debug("Cleanup layers\n");
2397 /* Raise STDIN..STDERR refcount so we don't close them */
2398 for (i=0; i < 3; i++)
2399 PerlIOUnix_refcnt_inc(i);
2400 PerlIO_cleantable(aTHX_ &PL_perlio);
2401 /* Restore STDIN..STDERR refcount */
2402 for (i=0; i < 3; i++)
2403 PerlIOUnix_refcnt_dec(i);
2405 if (PL_known_layers) {
2406 PerlIO_list_free(aTHX_ PL_known_layers);
2407 PL_known_layers = NULL;
2409 if (PL_def_layerlist) {
2410 PerlIO_list_free(aTHX_ PL_def_layerlist);
2411 PL_def_layerlist = NULL;
2415 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2419 /* XXX we can't rely on an interpreter being present at this late stage,
2420 XXX so we can't use a function like PerlLIO_write that relies on one
2421 being present (at least in win32) :-(.
2426 /* By now all filehandles should have been closed, so any
2427 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2429 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2430 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2431 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2433 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2434 if (PL_perlio_fd_refcnt[i]) {
2436 my_snprintf(buf, sizeof(buf),
2437 "PerlIO_teardown: fd %d refcnt=%d\n",
2438 i, PL_perlio_fd_refcnt[i]);
2439 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2445 /* Not bothering with PL_perlio_mutex since by now
2446 * all the interpreters are gone. */
2447 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2448 && PL_perlio_fd_refcnt) {
2449 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2450 PL_perlio_fd_refcnt = NULL;
2451 PL_perlio_fd_refcnt_size = 0;
2455 /*--------------------------------------------------------------------------------------*/
2457 * Bottom-most level for UNIX-like case
2461 struct _PerlIO base; /* The generic part */
2462 int fd; /* UNIX like file descriptor */
2463 int oflags; /* open/fcntl flags */
2467 PerlIOUnix_oflags(const char *mode)
2470 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2475 if (*++mode == '+') {
2482 oflags = O_CREAT | O_TRUNC;
2483 if (*++mode == '+') {
2492 oflags = O_CREAT | O_APPEND;
2493 if (*++mode == '+') {
2506 else if (*mode == 't') {
2508 oflags &= ~O_BINARY;
2512 * Always open in binary mode
2515 if (*mode || oflags == -1) {
2516 SETERRNO(EINVAL, LIB_INVARG);
2523 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2525 PERL_UNUSED_CONTEXT;
2526 return PerlIOSelf(f, PerlIOUnix)->fd;
2530 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2532 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2535 if (PerlLIO_fstat(fd, &st) == 0) {
2536 if (!S_ISREG(st.st_mode)) {
2537 PerlIO_debug("%d is not regular file\n",fd);
2538 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2541 PerlIO_debug("%d _is_ a regular file\n",fd);
2547 PerlIOUnix_refcnt_inc(fd);
2548 PERL_UNUSED_CONTEXT;
2552 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2554 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2555 if (*PerlIONext(f)) {
2556 /* We never call down so do any pending stuff now */
2557 PerlIO_flush(PerlIONext(f));
2559 * XXX could (or should) we retrieve the oflags from the open file
2560 * handle rather than believing the "mode" we are passed in? XXX
2561 * Should the value on NULL mode be 0 or -1?
2563 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2564 mode ? PerlIOUnix_oflags(mode) : -1);
2566 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2572 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2574 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2576 PERL_UNUSED_CONTEXT;
2577 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2579 SETERRNO(ESPIPE, LIB_INVARG);
2581 SETERRNO(EINVAL, LIB_INVARG);
2585 new_loc = PerlLIO_lseek(fd, offset, whence);
2586 if (new_loc == (Off_t) - 1)
2588 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2593 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2594 IV n, const char *mode, int fd, int imode,
2595 int perm, PerlIO *f, int narg, SV **args)
2597 if (PerlIOValid(f)) {
2598 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2599 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2602 if (*mode == IoTYPE_NUMERIC)
2605 imode = PerlIOUnix_oflags(mode);
2607 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2613 const char *path = SvPV_nolen_const(*args);
2614 fd = PerlLIO_open3(path, imode, perm);
2618 if (*mode == IoTYPE_IMPLICIT)
2621 f = PerlIO_allocate(aTHX);
2623 if (!PerlIOValid(f)) {
2624 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2628 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2629 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2630 if (*mode == IoTYPE_APPEND)
2631 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2638 * FIXME: pop layers ???
2646 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2648 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2650 if (flags & PERLIO_DUP_FD) {
2651 fd = PerlLIO_dup(fd);
2654 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2656 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2657 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2666 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2669 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2670 #ifdef PERLIO_STD_SPECIAL
2672 return PERLIO_STD_IN(fd, vbuf, count);
2674 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2675 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2679 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2680 if (len >= 0 || errno != EINTR) {
2682 if (errno != EAGAIN) {
2683 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2686 else if (len == 0 && count != 0) {
2687 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2698 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2701 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2702 #ifdef PERLIO_STD_SPECIAL
2703 if (fd == 1 || fd == 2)
2704 return PERLIO_STD_OUT(fd, vbuf, count);
2707 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2708 if (len >= 0 || errno != EINTR) {
2710 if (errno != EAGAIN) {
2711 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2722 PerlIOUnix_tell(pTHX_ PerlIO *f)
2724 PERL_UNUSED_CONTEXT;
2726 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2731 PerlIOUnix_close(pTHX_ PerlIO *f)
2734 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2736 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2737 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2738 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2743 SETERRNO(EBADF,SS_IVCHAN);
2746 while (PerlLIO_close(fd) != 0) {
2747 if (errno != EINTR) {
2754 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2759 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2760 sizeof(PerlIO_funcs),
2767 PerlIOBase_binmode, /* binmode */
2777 PerlIOBase_noop_ok, /* flush */
2778 PerlIOBase_noop_fail, /* fill */
2781 PerlIOBase_clearerr,
2782 PerlIOBase_setlinebuf,
2783 NULL, /* get_base */
2784 NULL, /* get_bufsiz */
2787 NULL, /* set_ptrcnt */
2790 /*--------------------------------------------------------------------------------------*/
2795 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2796 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2797 broken by the last second glibc 2.3 fix
2799 #define STDIO_BUFFER_WRITABLE
2804 struct _PerlIO base;
2805 FILE *stdio; /* The stream */
2809 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2811 PERL_UNUSED_CONTEXT;
2813 if (PerlIOValid(f)) {
2814 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2816 return PerlSIO_fileno(s);
2823 PerlIOStdio_mode(const char *mode, char *tmode)
2825 char * const ret = tmode;
2831 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2839 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2842 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2843 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2844 if (toptab == tab) {
2845 /* Top is already stdio - pop self (duplicate) and use original */
2846 PerlIO_pop(aTHX_ f);
2849 const int fd = PerlIO_fileno(n);
2852 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2853 mode = PerlIOStdio_mode(mode, tmode)))) {
2854 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2855 /* We never call down so do any pending stuff now */
2856 PerlIO_flush(PerlIONext(f));
2863 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2868 PerlIO_importFILE(FILE *stdio, const char *mode)
2874 if (!mode || !*mode) {
2875 /* We need to probe to see how we can open the stream
2876 so start with read/write and then try write and read
2877 we dup() so that we can fclose without loosing the fd.
2879 Note that the errno value set by a failing fdopen
2880 varies between stdio implementations.
2882 const int fd = PerlLIO_dup(fileno(stdio));
2883 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2885 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2888 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2891 /* Don't seem to be able to open */
2897 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2898 s = PerlIOSelf(f, PerlIOStdio);
2900 PerlIOUnix_refcnt_inc(fileno(stdio));
2907 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2908 IV n, const char *mode, int fd, int imode,
2909 int perm, PerlIO *f, int narg, SV **args)
2912 if (PerlIOValid(f)) {
2913 const char * const path = SvPV_nolen_const(*args);
2914 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2916 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2917 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2922 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2927 const char * const path = SvPV_nolen_const(*args);
2928 if (*mode == IoTYPE_NUMERIC) {
2930 fd = PerlLIO_open3(path, imode, perm);
2934 bool appended = FALSE;
2936 /* Cygwin wants its 'b' early. */
2938 mode = PerlIOStdio_mode(mode, tmode);
2940 stdio = PerlSIO_fopen(path, mode);
2943 f = PerlIO_allocate(aTHX);
2946 mode = PerlIOStdio_mode(mode, tmode);
2947 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2949 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2950 PerlIOUnix_refcnt_inc(fileno(stdio));
2952 PerlSIO_fclose(stdio);
2964 if (*mode == IoTYPE_IMPLICIT) {
2971 stdio = PerlSIO_stdin;
2974 stdio = PerlSIO_stdout;
2977 stdio = PerlSIO_stderr;
2982 stdio = PerlSIO_fdopen(fd, mode =
2983 PerlIOStdio_mode(mode, tmode));
2987 f = PerlIO_allocate(aTHX);
2989 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2990 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2991 PerlIOUnix_refcnt_inc(fileno(stdio));
3001 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3003 /* This assumes no layers underneath - which is what
3004 happens, but is not how I remember it. NI-S 2001/10/16
3006 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3007 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3008 const int fd = fileno(stdio);
3010 if (flags & PERLIO_DUP_FD) {
3011 const int dfd = PerlLIO_dup(fileno(stdio));
3013 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3018 /* FIXME: To avoid messy error recovery if dup fails
3019 re-use the existing stdio as though flag was not set
3023 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3025 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3027 PerlIOUnix_refcnt_inc(fileno(stdio));
3034 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3036 PERL_UNUSED_CONTEXT;
3038 /* XXX this could use PerlIO_canset_fileno() and
3039 * PerlIO_set_fileno() support from Configure
3041 # if defined(__UCLIBC__)
3042 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3045 # elif defined(__GLIBC__)
3046 /* There may be a better way for GLIBC:
3047 - libio.h defines a flag to not close() on cleanup
3051 # elif defined(__sun__)
3054 # elif defined(__hpux)
3058 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3059 your platform does not have special entry try this one.
3060 [For OSF only have confirmation for Tru64 (alpha)
3061 but assume other OSFs will be similar.]
3063 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3066 # elif defined(__FreeBSD__)
3067 /* There may be a better way on FreeBSD:
3068 - we could insert a dummy func in the _close function entry
3069 f->_close = (int (*)(void *)) dummy_close;
3073 # elif defined(__OpenBSD__)
3074 /* There may be a better way on OpenBSD:
3075 - we could insert a dummy func in the _close function entry
3076 f->_close = (int (*)(void *)) dummy_close;
3080 # elif defined(__EMX__)
3081 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3084 # elif defined(__CYGWIN__)
3085 /* There may be a better way on CYGWIN:
3086 - we could insert a dummy func in the _close function entry
3087 f->_close = (int (*)(void *)) dummy_close;
3091 # elif defined(WIN32)
3092 # if defined(__BORLANDC__)
3093 f->fd = PerlLIO_dup(fileno(f));
3094 # elif defined(UNDER_CE)
3095 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3104 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3105 (which isn't thread safe) instead
3107 # error "Don't know how to set FILE.fileno on your platform"
3115 PerlIOStdio_close(pTHX_ PerlIO *f)
3117 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3123 const int fd = fileno(stdio);
3131 #ifdef SOCKS5_VERSION_NAME
3132 /* Socks lib overrides close() but stdio isn't linked to
3133 that library (though we are) - so we must call close()
3134 on sockets on stdio's behalf.
3137 Sock_size_t optlen = sizeof(int);
3138 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3141 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3142 that a subsequent fileno() on it returns -1. Don't want to croak()
3143 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3144 trying to close an already closed handle which somehow it still has
3145 a reference to. (via.xs, I'm looking at you). */
3146 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3147 /* File descriptor still in use */
3151 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3152 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3154 if (stdio == stdout || stdio == stderr)
3155 return PerlIO_flush(f);
3156 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3157 Use Sarathy's trick from maint-5.6 to invalidate the
3158 fileno slot of the FILE *
3160 result = PerlIO_flush(f);
3162 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3165 MUTEX_LOCK(&PL_perlio_mutex);
3166 /* Right. We need a mutex here because for a brief while we
3167 will have the situation that fd is actually closed. Hence if
3168 a second thread were to get into this block, its dup() would
3169 likely return our fd as its dupfd. (after all, it is closed)
3170 Then if we get to the dup2() first, we blat the fd back
3171 (messing up its temporary as a side effect) only for it to
3172 then close its dupfd (== our fd) in its close(dupfd) */
3174 /* There is, of course, a race condition, that any other thread
3175 trying to input/output/whatever on this fd will be stuffed
3176 for the duration of this little manoeuvrer. Perhaps we
3177 should hold an IO mutex for the duration of every IO
3178 operation if we know that invalidate doesn't work on this
3179 platform, but that would suck, and could kill performance.
3181 Except that correctness trumps speed.
3182 Advice from klortho #11912. */
3184 dupfd = PerlLIO_dup(fd);
3187 MUTEX_UNLOCK(&PL_perlio_mutex);
3188 /* Oh cXap. This isn't going to go well. Not sure if we can
3189 recover from here, or if closing this particular FILE *
3190 is a good idea now. */
3195 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3197 result = PerlSIO_fclose(stdio);
3198 /* We treat error from stdio as success if we invalidated
3199 errno may NOT be expected EBADF
3201 if (invalidate && result != 0) {
3205 #ifdef SOCKS5_VERSION_NAME
3206 /* in SOCKS' case, let close() determine return value */
3210 PerlLIO_dup2(dupfd,fd);
3211 PerlLIO_close(dupfd);
3213 MUTEX_UNLOCK(&PL_perlio_mutex);
3221 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3224 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3228 STDCHAR *buf = (STDCHAR *) vbuf;
3230 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3231 * stdio does not do that for fread()
3233 const int ch = PerlSIO_fgetc(s);
3240 got = PerlSIO_fread(vbuf, 1, count, s);
3241 if (got == 0 && PerlSIO_ferror(s))
3243 if (got >= 0 || errno != EINTR)
3246 SETERRNO(0,0); /* just in case */
3252 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3255 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3257 #ifdef STDIO_BUFFER_WRITABLE
3258 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3259 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3260 STDCHAR *base = PerlIO_get_base(f);
3261 SSize_t cnt = PerlIO_get_cnt(f);
3262 STDCHAR *ptr = PerlIO_get_ptr(f);
3263 SSize_t avail = ptr - base;
3265 if (avail > count) {
3269 Move(buf-avail,ptr,avail,STDCHAR);
3272 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3273 if (PerlSIO_feof(s) && unread >= 0)
3274 PerlSIO_clearerr(s);
3279 if (PerlIO_has_cntptr(f)) {
3280 /* We can get pointer to buffer but not its base
3281 Do ungetc() but check chars are ending up in the
3284 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3285 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3287 const int ch = *--buf & 0xFF;
3288 if (ungetc(ch,s) != ch) {
3289 /* ungetc did not work */
3292 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3293 /* Did not change pointer as expected */
3294 fgetc(s); /* get char back again */
3304 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3310 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3315 got = PerlSIO_fwrite(vbuf, 1, count,
3316 PerlIOSelf(f, PerlIOStdio)->stdio);
3317 if (got >= 0 || errno != EINTR)
3320 SETERRNO(0,0); /* just in case */
3326 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3328 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3329 PERL_UNUSED_CONTEXT;
3331 return PerlSIO_fseek(stdio, offset, whence);
3335 PerlIOStdio_tell(pTHX_ PerlIO *f)
3337 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3338 PERL_UNUSED_CONTEXT;
3340 return PerlSIO_ftell(stdio);
3344 PerlIOStdio_flush(pTHX_ PerlIO *f)
3346 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3347 PERL_UNUSED_CONTEXT;
3349 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3350 return PerlSIO_fflush(stdio);
3356 * FIXME: This discards ungetc() and pre-read stuff which is not
3357 * right if this is just a "sync" from a layer above Suspect right
3358 * design is to do _this_ but not have layer above flush this
3359 * layer read-to-read
3362 * Not writeable - sync by attempting a seek
3365 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3373 PerlIOStdio_eof(pTHX_ PerlIO *f)
3375 PERL_UNUSED_CONTEXT;
3377 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3381 PerlIOStdio_error(pTHX_ PerlIO *f)
3383 PERL_UNUSED_CONTEXT;
3385 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3389 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3391 PERL_UNUSED_CONTEXT;
3393 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3397 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3399 PERL_UNUSED_CONTEXT;
3401 #ifdef HAS_SETLINEBUF
3402 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3404 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3410 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3412 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3413 return (STDCHAR*)PerlSIO_get_base(stdio);
3417 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3419 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3420 return PerlSIO_get_bufsiz(stdio);
3424 #ifdef USE_STDIO_PTR
3426 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3428 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3429 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3433 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3435 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3436 return PerlSIO_get_cnt(stdio);
3440 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3442 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3444 #ifdef STDIO_PTR_LVALUE
3445 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3446 #ifdef STDIO_PTR_LVAL_SETS_CNT
3447 assert(PerlSIO_get_cnt(stdio) == (cnt));
3449 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3451 * Setting ptr _does_ change cnt - we are done
3455 #else /* STDIO_PTR_LVALUE */
3457 #endif /* STDIO_PTR_LVALUE */
3460 * Now (or only) set cnt
3462 #ifdef STDIO_CNT_LVALUE
3463 PerlSIO_set_cnt(stdio, cnt);
3464 #else /* STDIO_CNT_LVALUE */
3465 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3466 PerlSIO_set_ptr(stdio,
3467 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3469 #else /* STDIO_PTR_LVAL_SETS_CNT */
3471 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3472 #endif /* STDIO_CNT_LVALUE */
3479 PerlIOStdio_fill(pTHX_ PerlIO *f)
3481 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3483 PERL_UNUSED_CONTEXT;
3486 * fflush()ing read-only streams can cause trouble on some stdio-s
3488 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3489 if (PerlSIO_fflush(stdio) != 0)
3493 c = PerlSIO_fgetc(stdio);
3496 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3502 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3504 #ifdef STDIO_BUFFER_WRITABLE
3505 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3506 /* Fake ungetc() to the real buffer in case system's ungetc
3509 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3510 SSize_t cnt = PerlSIO_get_cnt(stdio);
3511 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3512 if (ptr == base+1) {
3513 *--ptr = (STDCHAR) c;
3514 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3515 if (PerlSIO_feof(stdio))
3516 PerlSIO_clearerr(stdio);
3522 if (PerlIO_has_cntptr(f)) {
3524 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3531 /* An ungetc()d char is handled separately from the regular
3532 * buffer, so we stuff it in the buffer ourselves.
3533 * Should never get called as should hit code above
3535 *(--((*stdio)->_ptr)) = (unsigned char) c;
3538 /* If buffer snoop scheme above fails fall back to
3541 if (PerlSIO_ungetc(c, stdio) != c)
3549 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3550 sizeof(PerlIO_funcs),
3552 sizeof(PerlIOStdio),
3553 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3557 PerlIOBase_binmode, /* binmode */
3571 PerlIOStdio_clearerr,
3572 PerlIOStdio_setlinebuf,
3574 PerlIOStdio_get_base,
3575 PerlIOStdio_get_bufsiz,
3580 #ifdef USE_STDIO_PTR
3581 PerlIOStdio_get_ptr,
3582 PerlIOStdio_get_cnt,
3583 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3584 PerlIOStdio_set_ptrcnt,
3587 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3592 #endif /* USE_STDIO_PTR */
3595 /* Note that calls to PerlIO_exportFILE() are reversed using
3596 * PerlIO_releaseFILE(), not importFILE. */
3598 PerlIO_exportFILE(PerlIO * f, const char *mode)
3602 if (PerlIOValid(f)) {
3605 if (!mode || !*mode) {
3606 mode = PerlIO_modestr(f, buf);
3608 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3612 /* De-link any lower layers so new :stdio sticks */
3614 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3615 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3617 PerlIOUnix_refcnt_inc(fileno(stdio));
3618 /* Link previous lower layers under new one */
3622 /* restore layers list */
3632 PerlIO_findFILE(PerlIO *f)
3637 if (l->tab == &PerlIO_stdio) {
3638 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3641 l = *PerlIONext(&l);
3643 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3644 /* However, we're not really exporting a FILE * to someone else (who
3645 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3646 So we need to undo its refernce count increase on the underlying file
3647 descriptor. We have to do this, because if the loop above returns you
3648 the FILE *, then *it* didn't increase any reference count. So there's
3649 only one way to be consistent. */
3650 stdio = PerlIO_exportFILE(f, NULL);
3652 const int fd = fileno(stdio);
3654 PerlIOUnix_refcnt_dec(fd);
3659 /* Use this to reverse PerlIO_exportFILE calls. */
3661 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3666 if (l->tab == &PerlIO_stdio) {
3667 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3668 if (s->stdio == f) {
3670 const int fd = fileno(f);
3672 PerlIOUnix_refcnt_dec(fd);
3673 PerlIO_pop(aTHX_ p);
3682 /*--------------------------------------------------------------------------------------*/
3684 * perlio buffer layer
3688 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3690 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3691 const int fd = PerlIO_fileno(f);
3692 if (fd >= 0 && PerlLIO_isatty(fd)) {
3693 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3695 if (*PerlIONext(f)) {
3696 const Off_t posn = PerlIO_tell(PerlIONext(f));
3697 if (posn != (Off_t) - 1) {
3701 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3705 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3706 IV n, const char *mode, int fd, int imode, int perm,
3707 PerlIO *f, int narg, SV **args)
3709 if (PerlIOValid(f)) {
3710 PerlIO *next = PerlIONext(f);
3712 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3713 if (tab && tab->Open)
3715 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3717 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3722 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3724 if (*mode == IoTYPE_IMPLICIT) {
3730 if (tab && tab->Open)
3731 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3734 SETERRNO(EINVAL, LIB_INVARG);
3736 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3738 * if push fails during open, open fails. close will pop us.
3743 fd = PerlIO_fileno(f);
3744 if (init && fd == 2) {
3746 * Initial stderr is unbuffered
3748 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3750 #ifdef PERLIO_USING_CRLF
3751 # ifdef PERLIO_IS_BINMODE_FD
3752 if (PERLIO_IS_BINMODE_FD(fd))
3753 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3757 * do something about failing setmode()? --jhi
3759 PerlLIO_setmode(fd, O_BINARY);
3768 * This "flush" is akin to sfio's sync in that it handles files in either
3769 * read or write state. For write state, we put the postponed data through
3770 * the next layers. For read state, we seek() the next layers to the
3771 * offset given by current position in the buffer, and discard the buffer
3772 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3773 * in any case?). Then the pass the stick further in chain.
3776 PerlIOBuf_flush(pTHX_ PerlIO *f)
3778 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3780 PerlIO *n = PerlIONext(f);
3781 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3783 * write() the buffer
3785 const STDCHAR *buf = b->buf;
3786 const STDCHAR *p = buf;
3787 while (p < b->ptr) {
3788 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3792 else if (count < 0 || PerlIO_error(n)) {
3793 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3798 b->posn += (p - buf);
3800 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3801 STDCHAR *buf = PerlIO_get_base(f);
3803 * Note position change
3805 b->posn += (b->ptr - buf);
3806 if (b->ptr < b->end) {
3807 /* We did not consume all of it - try and seek downstream to
3808 our logical position
3810 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3811 /* Reload n as some layers may pop themselves on seek */
3812 b->posn = PerlIO_tell(n = PerlIONext(f));
3815 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3816 data is lost for good - so return saying "ok" having undone
3819 b->posn -= (b->ptr - buf);
3824 b->ptr = b->end = b->buf;
3825 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3826 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3827 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3832 /* This discards the content of the buffer after b->ptr, and rereads
3833 * the buffer from the position off in the layer downstream; here off
3834 * is at offset corresponding to b->ptr - b->buf.
3837 PerlIOBuf_fill(pTHX_ PerlIO *f)
3839 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3840 PerlIO *n = PerlIONext(f);
3843 * Down-stream flush is defined not to loose read data so is harmless.
3844 * we would not normally be fill'ing if there was data left in anycase.
3846 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3848 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3849 PerlIOBase_flush_linebuf(aTHX);
3852 PerlIO_get_base(f); /* allocate via vtable */
3854 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3856 b->ptr = b->end = b->buf;
3858 if (!PerlIOValid(n)) {
3859 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3863 if (PerlIO_fast_gets(n)) {
3865 * Layer below is also buffered. We do _NOT_ want to call its
3866 * ->Read() because that will loop till it gets what we asked for
3867 * which may hang on a pipe etc. Instead take anything it has to
3868 * hand, or ask it to fill _once_.
3870 avail = PerlIO_get_cnt(n);
3872 avail = PerlIO_fill(n);
3874 avail = PerlIO_get_cnt(n);
3876 if (!PerlIO_error(n) && PerlIO_eof(n))
3881 STDCHAR *ptr = PerlIO_get_ptr(n);
3882 const SSize_t cnt = avail;
3883 if (avail > (SSize_t)b->bufsiz)
3885 Copy(ptr, b->buf, avail, STDCHAR);
3886 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3890 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3894 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3896 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3899 b->end = b->buf + avail;
3900 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3905 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3907 if (PerlIOValid(f)) {
3908 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3911 return PerlIOBase_read(aTHX_ f, vbuf, count);
3917 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3919 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3920 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3923 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3928 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3930 * Buffer is already a read buffer, we can overwrite any chars
3931 * which have been read back to buffer start
3933 avail = (b->ptr - b->buf);
3937 * Buffer is idle, set it up so whole buffer is available for
3941 b->end = b->buf + avail;
3943 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3945 * Buffer extends _back_ from where we are now
3947 b->posn -= b->bufsiz;
3949 if (avail > (SSize_t) count) {
3951 * If we have space for more than count, just move count
3959 * In simple stdio-like ungetc() case chars will be already
3962 if (buf != b->ptr) {
3963 Copy(buf, b->ptr, avail, STDCHAR);
3967 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3971 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3977 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3979 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3980 const STDCHAR *buf = (const STDCHAR *) vbuf;
3981 const STDCHAR *flushptr = buf;
3985 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3987 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3988 if (PerlIO_flush(f) != 0) {
3992 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3993 flushptr = buf + count;
3994 while (flushptr > buf && *(flushptr - 1) != '\n')
3998 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3999 if ((SSize_t) count < avail)
4001 if (flushptr > buf && flushptr <= buf + avail)
4002 avail = flushptr - buf;
4003 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4005 Copy(buf, b->ptr, avail, STDCHAR);
4010 if (buf == flushptr)
4013 if (b->ptr >= (b->buf + b->bufsiz))
4016 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4022 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4025 if ((code = PerlIO_flush(f)) == 0) {
4026 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4027 code = PerlIO_seek(PerlIONext(f), offset, whence);
4029 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4030 b->posn = PerlIO_tell(PerlIONext(f));
4037 PerlIOBuf_tell(pTHX_ PerlIO *f)
4039 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4041 * b->posn is file position where b->buf was read, or will be written
4043 Off_t posn = b->posn;
4044 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4045 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4047 /* As O_APPEND files are normally shared in some sense it is better
4052 /* when file is NOT shared then this is sufficient */
4053 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4055 posn = b->posn = PerlIO_tell(PerlIONext(f));
4059 * If buffer is valid adjust position by amount in buffer
4061 posn += (b->ptr - b->buf);
4067 PerlIOBuf_popped(pTHX_ PerlIO *f)
4069 const IV code = PerlIOBase_popped(aTHX_ f);
4070 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4071 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4074 b->ptr = b->end = b->buf = NULL;
4075 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4080 PerlIOBuf_close(pTHX_ PerlIO *f)
4082 const IV code = PerlIOBase_close(aTHX_ f);
4083 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4084 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4087 b->ptr = b->end = b->buf = NULL;
4088 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4093 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4095 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4102 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4104 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4107 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4108 return (b->end - b->ptr);
4113 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4115 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4116 PERL_UNUSED_CONTEXT;
4121 Newxz(b->buf,b->bufsiz, STDCHAR);
4123 b->buf = (STDCHAR *) & b->oneword;
4124 b->bufsiz = sizeof(b->oneword);
4126 b->end = b->ptr = b->buf;
4132 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4134 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4137 return (b->end - b->buf);
4141 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4143 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4145 PERL_UNUSED_ARG(cnt);
4150 assert(PerlIO_get_cnt(f) == cnt);
4151 assert(b->ptr >= b->buf);
4152 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4156 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4158 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4163 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4164 sizeof(PerlIO_funcs),
4167 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4171 PerlIOBase_binmode, /* binmode */
4185 PerlIOBase_clearerr,
4186 PerlIOBase_setlinebuf,
4191 PerlIOBuf_set_ptrcnt,
4194 /*--------------------------------------------------------------------------------------*/
4196 * Temp layer to hold unread chars when cannot do it any other way
4200 PerlIOPending_fill(pTHX_ PerlIO *f)
4203 * Should never happen
4210 PerlIOPending_close(pTHX_ PerlIO *f)
4213 * A tad tricky - flush pops us, then we close new top
4216 return PerlIO_close(f);
4220 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4223 * A tad tricky - flush pops us, then we seek new top
4226 return PerlIO_seek(f, offset, whence);
4231 PerlIOPending_flush(pTHX_ PerlIO *f)
4233 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4234 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4238 PerlIO_pop(aTHX_ f);
4243 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4249 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4254 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4256 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4257 PerlIOl * const l = PerlIOBase(f);
4259 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4260 * etc. get muddled when it changes mid-string when we auto-pop.
4262 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4263 (PerlIOBase(PerlIONext(f))->
4264 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4269 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4271 SSize_t avail = PerlIO_get_cnt(f);
4273 if ((SSize_t)count < avail)
4276 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4277 if (got >= 0 && got < (SSize_t)count) {
4278 const SSize_t more =
4279 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4280 if (more >= 0 || got == 0)
4286 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4287 sizeof(PerlIO_funcs),
4290 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4291 PerlIOPending_pushed,
4294 PerlIOBase_binmode, /* binmode */
4303 PerlIOPending_close,
4304 PerlIOPending_flush,
4308 PerlIOBase_clearerr,
4309 PerlIOBase_setlinebuf,
4314 PerlIOPending_set_ptrcnt,
4319 /*--------------------------------------------------------------------------------------*/
4321 * crlf - translation On read translate CR,LF to "\n" we do this by
4322 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4323 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4325 * c->nl points on the first byte of CR LF pair when it is temporarily
4326 * replaced by LF, or to the last CR of the buffer. In the former case
4327 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4328 * that it ends at c->nl; these two cases can be distinguished by
4329 * *c->nl. c->nl is set during _getcnt() call, and unset during
4330 * _unread() and _flush() calls.
4331 * It only matters for read operations.
4335 PerlIOBuf base; /* PerlIOBuf stuff */
4336 STDCHAR *nl; /* Position of crlf we "lied" about in the
4340 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4341 * Otherwise the :crlf layer would always revert back to
4345 S_inherit_utf8_flag(PerlIO *f)
4347 PerlIO *g = PerlIONext(f);
4348 if (PerlIOValid(g)) {
4349 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4350 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4356 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4359 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4360 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4362 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4363 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4364 PerlIOBase(f)->flags);
4367 /* Enable the first CRLF capable layer you can find, but if none
4368 * found, the one we just pushed is fine. This results in at
4369 * any given moment at most one CRLF-capable layer being enabled
4370 * in the whole layer stack. */
4371 PerlIO *g = PerlIONext(f);
4372 while (PerlIOValid(g)) {
4373 PerlIOl *b = PerlIOBase(g);
4374 if (b && b->tab == &PerlIO_crlf) {
4375 if (!(b->flags & PERLIO_F_CRLF))
4376 b->flags |= PERLIO_F_CRLF;
4377 S_inherit_utf8_flag(g);
4378 PerlIO_pop(aTHX_ f);
4384 S_inherit_utf8_flag(f);
4390 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4392 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4393 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4397 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4398 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4400 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4401 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4403 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4408 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4409 b->end = b->ptr = b->buf + b->bufsiz;
4410 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4411 b->posn -= b->bufsiz;
4413 while (count > 0 && b->ptr > b->buf) {
4414 const int ch = *--buf;
4416 if (b->ptr - 2 >= b->buf) {
4423 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4424 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4440 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4442 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4444 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4447 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4448 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4449 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4450 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4452 while (nl < b->end && *nl != 0xd)
4454 if (nl < b->end && *nl == 0xd) {
4456 if (nl + 1 < b->end) {
4463 * Not CR,LF but just CR
4471 * Blast - found CR as last char in buffer
4476 * They may not care, defer work as long as
4480 return (nl - b->ptr);
4484 b->ptr++; /* say we have read it as far as
4485 * flush() is concerned */
4486 b->buf++; /* Leave space in front of buffer */
4487 /* Note as we have moved buf up flush's
4489 will naturally make posn point at CR
4491 b->bufsiz--; /* Buffer is thus smaller */
4492 code = PerlIO_fill(f); /* Fetch some more */
4493 b->bufsiz++; /* Restore size for next time */
4494 b->buf--; /* Point at space */
4495 b->ptr = nl = b->buf; /* Which is what we hand
4497 *nl = 0xd; /* Fill in the CR */
4499 goto test; /* fill() call worked */
4501 * CR at EOF - just fall through
4503 /* Should we clear EOF though ??? */
4508 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4514 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4516 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4517 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4523 if (ptr == b->end && *c->nl == 0xd) {
4524 /* Defered CR at end of buffer case - we lied about count */
4537 * Test code - delete when it works ...
4539 IV flags = PerlIOBase(f)->flags;
4540 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4541 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4542 /* Defered CR at end of buffer case - we lied about count */
4548 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4549 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4550 flags, c->nl, b->end, cnt);
4557 * They have taken what we lied about
4565 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4569 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4571 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4572 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4574 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4575 const STDCHAR *buf = (const STDCHAR *) vbuf;
4576 const STDCHAR * const ebuf = buf + count;
4579 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4581 while (buf < ebuf) {
4582 const STDCHAR * const eptr = b->buf + b->bufsiz;
4583 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4584 while (buf < ebuf && b->ptr < eptr) {
4586 if ((b->ptr + 2) > eptr) {
4594 *(b->ptr)++ = 0xd; /* CR */
4595 *(b->ptr)++ = 0xa; /* LF */
4597 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4604 *(b->ptr)++ = *buf++;
4606 if (b->ptr >= eptr) {
4612 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4614 return (buf - (STDCHAR *) vbuf);
4619 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4621 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4626 return PerlIOBuf_flush(aTHX_ f);
4630 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4632 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4633 /* In text mode - flush any pending stuff and flip it */
4634 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4635 #ifndef PERLIO_USING_CRLF
4636 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4637 PerlIO_pop(aTHX_ f);
4643 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4644 sizeof(PerlIO_funcs),
4647 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4649 PerlIOBuf_popped, /* popped */
4651 PerlIOCrlf_binmode, /* binmode */
4655 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4656 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4657 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4665 PerlIOBase_clearerr,
4666 PerlIOBase_setlinebuf,
4671 PerlIOCrlf_set_ptrcnt,
4675 /*--------------------------------------------------------------------------------------*/
4677 * mmap as "buffer" layer
4681 PerlIOBuf base; /* PerlIOBuf stuff */
4682 Mmap_t mptr; /* Mapped address */
4683 Size_t len; /* mapped length */
4684 STDCHAR *bbuf; /* malloced buffer if map fails */
4688 PerlIOMmap_map(pTHX_ PerlIO *f)
4691 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4692 const IV flags = PerlIOBase(f)->flags;
4696 if (flags & PERLIO_F_CANREAD) {
4697 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4698 const int fd = PerlIO_fileno(f);
4700 code = Fstat(fd, &st);
4701 if (code == 0 && S_ISREG(st.st_mode)) {
4702 SSize_t len = st.st_size - b->posn;
4705 if (PL_mmap_page_size <= 0)
4706 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4710 * This is a hack - should never happen - open should
4713 b->posn = PerlIO_tell(PerlIONext(f));
4715 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4716 len = st.st_size - posn;
4717 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4718 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4719 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4720 madvise(m->mptr, len, MADV_SEQUENTIAL);
4722 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4723 madvise(m->mptr, len, MADV_WILLNEED);
4725 PerlIOBase(f)->flags =
4726 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4727 b->end = ((STDCHAR *) m->mptr) + len;
4728 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4737 PerlIOBase(f)->flags =
4738 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4740 b->ptr = b->end = b->ptr;
4749 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4751 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4754 PerlIOBuf * const b = &m->base;
4756 /* The munmap address argument is tricky: depending on the
4757 * standard it is either "void *" or "caddr_t" (which is
4758 * usually "char *" (signed or unsigned). If we cast it
4759 * to "void *", those that have it caddr_t and an uptight
4760 * C++ compiler, will freak out. But casting it as char*
4761 * should work. Maybe. (Using Mmap_t figured out by
4762 * Configure doesn't always work, apparently.) */
4763 code = munmap((char*)m->mptr, m->len);
4767 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4770 b->ptr = b->end = b->buf;
4771 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4777 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4779 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4780 PerlIOBuf * const b = &m->base;
4781 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4783 * Already have a readbuffer in progress
4789 * We have a write buffer or flushed PerlIOBuf read buffer
4791 m->bbuf = b->buf; /* save it in case we need it again */
4792 b->buf = NULL; /* Clear to trigger below */
4795 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4798 * Map did not work - recover PerlIOBuf buffer if we have one
4803 b->ptr = b->end = b->buf;
4806 return PerlIOBuf_get_base(aTHX_ f);
4810 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4812 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4813 PerlIOBuf * const b = &m->base;
4814 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4816 if (b->ptr && (b->ptr - count) >= b->buf
4817 && memEQ(b->ptr - count, vbuf, count)) {
4819 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4824 * Loose the unwritable mapped buffer
4828 * If flush took the "buffer" see if we have one from before
4830 if (!b->buf && m->bbuf)
4833 PerlIOBuf_get_base(aTHX_ f);
4837 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4841 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4843 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4844 PerlIOBuf * const b = &m->base;
4846 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4848 * No, or wrong sort of, buffer
4851 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4855 * If unmap took the "buffer" see if we have one from before
4857 if (!b->buf && m->bbuf)
4860 PerlIOBuf_get_base(aTHX_ f);
4864 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4868 PerlIOMmap_flush(pTHX_ PerlIO *f)
4870 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4871 PerlIOBuf * const b = &m->base;
4872 IV code = PerlIOBuf_flush(aTHX_ f);
4874 * Now we are "synced" at PerlIOBuf level
4881 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4886 * We seem to have a PerlIOBuf buffer which was not mapped
4887 * remember it in case we need one later
4896 PerlIOMmap_fill(pTHX_ PerlIO *f)
4898 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4899 IV code = PerlIO_flush(f);
4900 if (code == 0 && !b->buf) {
4901 code = PerlIOMmap_map(aTHX_ f);
4903 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4904 code = PerlIOBuf_fill(aTHX_ f);
4910 PerlIOMmap_close(pTHX_ PerlIO *f)
4912 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4913 PerlIOBuf * const b = &m->base;
4914 IV code = PerlIO_flush(f);
4918 b->ptr = b->end = b->buf;
4920 if (PerlIOBuf_close(aTHX_ f) != 0)
4926 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4928 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4932 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4933 sizeof(PerlIO_funcs),
4936 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4940 PerlIOBase_binmode, /* binmode */
4954 PerlIOBase_clearerr,
4955 PerlIOBase_setlinebuf,
4956 PerlIOMmap_get_base,
4960 PerlIOBuf_set_ptrcnt,
4963 #endif /* HAS_MMAP */
4966 Perl_PerlIO_stdin(pTHX)
4970 PerlIO_stdstreams(aTHX);
4972 return &PL_perlio[1];
4976 Perl_PerlIO_stdout(pTHX)
4980 PerlIO_stdstreams(aTHX);
4982 return &PL_perlio[2];
4986 Perl_PerlIO_stderr(pTHX)
4990 PerlIO_stdstreams(aTHX);
4992 return &PL_perlio[3];
4995 /*--------------------------------------------------------------------------------------*/
4998 PerlIO_getname(PerlIO *f, char *buf)
5003 bool exported = FALSE;
5004 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5006 stdio = PerlIO_exportFILE(f,0);
5010 name = fgetname(stdio, buf);
5011 if (exported) PerlIO_releaseFILE(f,stdio);
5016 PERL_UNUSED_ARG(buf);
5017 Perl_croak(aTHX_ "Don't know how to get file name");
5023 /*--------------------------------------------------------------------------------------*/
5025 * Functions which can be called on any kind of PerlIO implemented in
5029 #undef PerlIO_fdopen
5031 PerlIO_fdopen(int fd, const char *mode)
5034 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5039 PerlIO_open(const char *path, const char *mode)
5042 SV *name = sv_2mortal(newSVpv(path, 0));
5043 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5046 #undef Perlio_reopen
5048 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5051 SV *name = sv_2mortal(newSVpv(path,0));
5052 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5057 PerlIO_getc(PerlIO *f)
5061 if ( 1 == PerlIO_read(f, buf, 1) ) {
5062 return (unsigned char) buf[0];
5067 #undef PerlIO_ungetc
5069 PerlIO_ungetc(PerlIO *f, int ch)
5074 if (PerlIO_unread(f, &buf, 1) == 1)
5082 PerlIO_putc(PerlIO *f, int ch)
5086 return PerlIO_write(f, &buf, 1);
5091 PerlIO_puts(PerlIO *f, const char *s)
5094 return PerlIO_write(f, s, strlen(s));
5097 #undef PerlIO_rewind
5099 PerlIO_rewind(PerlIO *f)
5102 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5106 #undef PerlIO_vprintf
5108 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5117 Perl_va_copy(ap, apc);
5118 sv = vnewSVpvf(fmt, &apc);
5120 sv = vnewSVpvf(fmt, &ap);
5122 s = SvPV_const(sv, len);
5123 wrote = PerlIO_write(f, s, len);
5128 #undef PerlIO_printf
5130 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5135 result = PerlIO_vprintf(f, fmt, ap);
5140 #undef PerlIO_stdoutf
5142 PerlIO_stdoutf(const char *fmt, ...)
5148 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5153 #undef PerlIO_tmpfile
5155 PerlIO_tmpfile(void)
5160 const int fd = win32_tmpfd();
5162 f = PerlIO_fdopen(fd, "w+b");
5164 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5166 char tempname[] = "/tmp/PerlIO_XXXXXX";
5167 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5170 * I have no idea how portable mkstemp() is ... NI-S
5172 if (tmpdir && *tmpdir) {
5173 /* if TMPDIR is set and not empty, we try that first */
5174 sv = newSVpv(tmpdir, 0);
5175 sv_catpv(sv, tempname + 4);
5176 fd = mkstemp(SvPVX(sv));
5180 /* else we try /tmp */
5181 fd = mkstemp(tempname);
5184 f = PerlIO_fdopen(fd, "w+");
5186 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5187 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5190 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5191 FILE * const stdio = PerlSIO_tmpfile();
5194 f = PerlIO_fdopen(fileno(stdio), "w+");
5196 # endif /* else HAS_MKSTEMP */
5197 #endif /* else WIN32 */
5204 #endif /* USE_SFIO */
5205 #endif /* PERLIO_IS_STDIO */
5207 /*======================================================================================*/
5209 * Now some functions in terms of above which may be needed even if we are
5210 * not in true PerlIO mode
5213 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5216 const char *direction = NULL;
5219 * Need to supply default layer info from open.pm
5225 if (mode && mode[0] != 'r') {
5226 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5227 direction = "open>";
5229 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5230 direction = "open<";
5235 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5238 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5243 #undef PerlIO_setpos
5245 PerlIO_setpos(PerlIO *f, SV *pos)
5250 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5251 if (f && len == sizeof(Off_t))
5252 return PerlIO_seek(f, *posn, SEEK_SET);
5254 SETERRNO(EINVAL, SS_IVCHAN);
5258 #undef PerlIO_setpos
5260 PerlIO_setpos(PerlIO *f, SV *pos)
5265 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5266 if (f && len == sizeof(Fpos_t)) {
5267 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5268 return fsetpos64(f, fpos);
5270 return fsetpos(f, fpos);
5274 SETERRNO(EINVAL, SS_IVCHAN);
5280 #undef PerlIO_getpos
5282 PerlIO_getpos(PerlIO *f, SV *pos)
5285 Off_t posn = PerlIO_tell(f);
5286 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5287 return (posn == (Off_t) - 1) ? -1 : 0;
5290 #undef PerlIO_getpos
5292 PerlIO_getpos(PerlIO *f, SV *pos)
5297 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5298 code = fgetpos64(f, &fpos);
5300 code = fgetpos(f, &fpos);
5302 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5307 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5310 vprintf(char *pat, char *args)
5312 _doprnt(pat, args, stdout);
5313 return 0; /* wrong, but perl doesn't use the return
5318 vfprintf(FILE *fd, char *pat, char *args)
5320 _doprnt(pat, args, fd);
5321 return 0; /* wrong, but perl doesn't use the return
5327 #ifndef PerlIO_vsprintf
5329 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5332 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5333 PERL_UNUSED_CONTEXT;
5335 #ifndef PERL_MY_VSNPRINTF_GUARDED
5336 if (val < 0 || (n > 0 ? val >= n : 0)) {
5337 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5344 #ifndef PerlIO_sprintf
5346 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5351 result = PerlIO_vsprintf(s, n, fmt, ap);
5359 * c-indentation-style: bsd
5361 * indent-tabs-mode: t
5364 * ex: set ts=8 sts=4 sw=4 noet: