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 if (list->array[i].arg)
619 SvREFCNT_dec(list->array[i].arg);
621 Safefree(list->array);
629 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
635 if (list->cur >= list->len) {
638 Renew(list->array, list->len, PerlIO_pair_t);
640 Newx(list->array, list->len, PerlIO_pair_t);
642 p = &(list->array[list->cur++]);
644 if ((p->arg = arg)) {
645 SvREFCNT_inc_simple_void_NN(arg);
650 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
652 PerlIO_list_t *list = NULL;
655 list = PerlIO_list_alloc(aTHX);
656 for (i=0; i < proto->cur; i++) {
657 SV *arg = proto->array[i].arg;
660 arg = sv_dup(arg, param);
662 PERL_UNUSED_ARG(param);
664 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
671 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
674 PerlIO **table = &proto->Iperlio;
677 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
678 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
679 PerlIO_allocate(aTHX); /* root slot is never used */
680 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
681 while ((f = *table)) {
683 table = (PerlIO **) (f++);
684 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
686 (void) fp_dup(f, 0, param);
693 PERL_UNUSED_ARG(proto);
694 PERL_UNUSED_ARG(param);
699 PerlIO_destruct(pTHX)
702 PerlIO **table = &PL_perlio;
705 PerlIO_debug("Destruct %p\n",(void*)aTHX);
707 while ((f = *table)) {
709 table = (PerlIO **) (f++);
710 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
714 if (l->tab->kind & PERLIO_K_DESTRUCT) {
715 PerlIO_debug("Destruct popping %s\n", l->tab->name);
729 PerlIO_pop(pTHX_ PerlIO *f)
731 const PerlIOl *l = *f;
733 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
734 if (l->tab->Popped) {
736 * If popped returns non-zero do not free its layer structure
737 * it has either done so itself, or it is shared and still in
740 if ((*l->tab->Popped) (aTHX_ f) != 0)
748 /* Return as an array the stack of layers on a filehandle. Note that
749 * the stack is returned top-first in the array, and there are three
750 * times as many array elements as there are layers in the stack: the
751 * first element of a layer triplet is the name, the second one is the
752 * arguments, and the third one is the flags. */
755 PerlIO_get_layers(pTHX_ PerlIO *f)
758 AV * const av = newAV();
760 if (PerlIOValid(f)) {
761 PerlIOl *l = PerlIOBase(f);
764 /* There is some collusion in the implementation of
765 XS_PerlIO_get_layers - it knows that name and flags are
766 generated as fresh SVs here, and takes advantage of that to
767 "copy" them by taking a reference. If it changes here, it needs
768 to change there too. */
769 SV * const name = l->tab && l->tab->name ?
770 newSVpv(l->tab->name, 0) : &PL_sv_undef;
771 SV * const arg = l->tab && l->tab->Getarg ?
772 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
775 av_push(av, newSViv((IV)l->flags));
783 /*--------------------------------------------------------------------------------------*/
785 * XS Interface for perl code
789 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
793 if ((SSize_t) len <= 0)
795 for (i = 0; i < PL_known_layers->cur; i++) {
796 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
797 if (memEQ(f->name, name, len) && f->name[len] == 0) {
798 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
802 if (load && PL_subname && PL_def_layerlist
803 && PL_def_layerlist->cur >= 2) {
804 if (PL_in_load_module) {
805 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
808 SV * const pkgsv = newSVpvs("PerlIO");
809 SV * const layer = newSVpvn(name, len);
810 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
812 SAVEINT(PL_in_load_module);
814 SAVEGENERICSV(PL_warnhook);
815 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
819 * The two SVs are magically freed by load_module
821 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
824 return PerlIO_find_layer(aTHX_ name, len, 0);
827 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
831 #ifdef USE_ATTRIBUTES_FOR_PERLIO
834 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
837 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
838 PerlIO * const ifp = IoIFP(io);
839 PerlIO * const ofp = IoOFP(io);
840 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
841 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
847 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
850 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
851 PerlIO * const ifp = IoIFP(io);
852 PerlIO * const ofp = IoOFP(io);
853 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
854 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
860 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
862 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
867 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
869 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
873 MGVTBL perlio_vtab = {
881 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
884 SV * const sv = SvRV(ST(1));
885 AV * const av = newAV();
889 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
891 mg = mg_find(sv, PERL_MAGIC_ext);
892 mg->mg_virtual = &perlio_vtab;
894 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
895 for (i = 2; i < items; i++) {
897 const char * const name = SvPV_const(ST(i), len);
898 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
900 av_push(av, SvREFCNT_inc_simple_NN(layer));
911 #endif /* USE_ATTIBUTES_FOR_PERLIO */
914 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
916 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
917 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
921 XS(XS_PerlIO__Layer__NoWarnings)
923 /* This is used as a %SIG{__WARN__} handler to supress warnings
924 during loading of layers.
930 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
934 XS(XS_PerlIO__Layer__find)
940 Perl_croak(aTHX_ "Usage class->find(name[,load])");
943 const char * const name = SvPV_const(ST(1), len);
944 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
945 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
947 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
954 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
957 if (!PL_known_layers)
958 PL_known_layers = PerlIO_list_alloc(aTHX);
959 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
960 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
964 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
968 const char *s = names;
970 while (isSPACE(*s) || *s == ':')
975 const char *as = NULL;
977 if (!isIDFIRST(*s)) {
979 * Message is consistent with how attribute lists are
980 * passed. Even though this means "foo : : bar" is
981 * seen as an invalid separator character.
983 const char q = ((*s == '\'') ? '"' : '\'');
984 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
985 "Invalid separator character %c%c%c in PerlIO layer specification %s",
987 SETERRNO(EINVAL, LIB_INVARG);
992 } while (isALNUM(*e));
1001 alen = (e - 1) - as;
1008 * It's a nul terminated string, not allowed
1009 * to \ the terminating null. Anything other
1010 * character is passed over.
1020 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1021 "Argument list not closed for PerlIO layer \"%.*s\"",
1033 PerlIO_funcs * const layer =
1034 PerlIO_find_layer(aTHX_ s, llen, 1);
1038 arg = newSVpvn(as, alen);
1039 PerlIO_list_push(aTHX_ av, layer,
1040 (arg) ? arg : &PL_sv_undef);
1045 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1058 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1061 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1062 #ifdef PERLIO_USING_CRLF
1065 if (PerlIO_stdio.Set_ptrcnt)
1066 tab = &PerlIO_stdio;
1068 PerlIO_debug("Pushing %s\n", tab->name);
1069 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1074 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1076 return av->array[n].arg;
1080 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1082 if (n >= 0 && n < av->cur) {
1083 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1084 av->array[n].funcs->name);
1085 return av->array[n].funcs;
1088 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1093 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1095 PERL_UNUSED_ARG(mode);
1096 PERL_UNUSED_ARG(arg);
1097 PERL_UNUSED_ARG(tab);
1098 if (PerlIOValid(f)) {
1100 PerlIO_pop(aTHX_ f);
1106 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1107 sizeof(PerlIO_funcs),
1110 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1130 NULL, /* get_base */
1131 NULL, /* get_bufsiz */
1134 NULL, /* set_ptrcnt */
1138 PerlIO_default_layers(pTHX)
1141 if (!PL_def_layerlist) {
1142 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1143 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1144 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1145 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1147 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1149 osLayer = &PerlIO_win32;
1152 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1153 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1154 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1155 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1157 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1159 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1160 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1161 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1162 PerlIO_list_push(aTHX_ PL_def_layerlist,
1163 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1166 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1169 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1172 if (PL_def_layerlist->cur < 2) {
1173 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1175 return PL_def_layerlist;
1179 Perl_boot_core_PerlIO(pTHX)
1181 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1182 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1185 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1186 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1190 PerlIO_default_layer(pTHX_ I32 n)
1193 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1196 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1199 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1200 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1203 PerlIO_stdstreams(pTHX)
1207 PerlIO_allocate(aTHX);
1208 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1209 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1210 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1215 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1217 if (tab->fsize != sizeof(PerlIO_funcs)) {
1219 Perl_croak(aTHX_ "Layer does not match this perl");
1223 if (tab->size < sizeof(PerlIOl)) {
1226 /* Real layer with a data area */
1229 Newxz(temp, tab->size, char);
1233 l->tab = (PerlIO_funcs*) tab;
1235 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1236 (void*)f, tab->name,
1237 (mode) ? mode : "(Null)", (void*)arg);
1238 if (*l->tab->Pushed &&
1240 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1241 PerlIO_pop(aTHX_ f);
1250 /* Pseudo-layer where push does its own stack adjust */
1251 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1252 (mode) ? mode : "(Null)", (void*)arg);
1254 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1262 PerlIOBase_binmode(pTHX_ PerlIO *f)
1264 if (PerlIOValid(f)) {
1265 /* Is layer suitable for raw stream ? */
1266 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1267 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1268 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1271 /* Not suitable - pop it */
1272 PerlIO_pop(aTHX_ f);
1280 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1282 PERL_UNUSED_ARG(mode);
1283 PERL_UNUSED_ARG(arg);
1284 PERL_UNUSED_ARG(tab);
1286 if (PerlIOValid(f)) {
1291 * Strip all layers that are not suitable for a raw stream
1294 while (t && (l = *t)) {
1295 if (l->tab->Binmode) {
1296 /* Has a handler - normal case */
1297 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1299 /* Layer still there - move down a layer */
1308 /* No handler - pop it */
1309 PerlIO_pop(aTHX_ t);
1312 if (PerlIOValid(f)) {
1313 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1321 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1322 PerlIO_list_t *layers, IV n, IV max)
1326 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1328 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1339 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1343 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1344 code = PerlIO_parse_layers(aTHX_ layers, names);
1346 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1348 PerlIO_list_free(aTHX_ layers);
1354 /*--------------------------------------------------------------------------------------*/
1356 * Given the abstraction above the public API functions
1360 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1362 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1363 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1364 iotype, mode, (names) ? names : "(Null)");
1367 /* Do not flush etc. if (e.g.) switching encodings.
1368 if a pushed layer knows it needs to flush lower layers
1369 (for example :unix which is never going to call them)
1370 it can do the flush when it is pushed.
1372 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1375 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1376 #ifdef PERLIO_USING_CRLF
1377 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1378 O_BINARY so we can look for it in mode.
1380 if (!(mode & O_BINARY)) {
1382 /* FIXME?: Looking down the layer stack seems wrong,
1383 but is a way of reaching past (say) an encoding layer
1384 to flip CRLF-ness of the layer(s) below
1387 /* Perhaps we should turn on bottom-most aware layer
1388 e.g. Ilya's idea that UNIX TTY could serve
1390 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1391 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1392 /* Not in text mode - flush any pending stuff and flip it */
1394 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1396 /* Only need to turn it on in one layer so we are done */
1401 /* Not finding a CRLF aware layer presumably means we are binary
1402 which is not what was requested - so we failed
1403 We _could_ push :crlf layer but so could caller
1408 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1409 So code that used to be here is now in PerlIORaw_pushed().
1411 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1416 PerlIO__close(pTHX_ PerlIO *f)
1418 if (PerlIOValid(f)) {
1419 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1420 if (tab && tab->Close)
1421 return (*tab->Close)(aTHX_ f);
1423 return PerlIOBase_close(aTHX_ f);
1426 SETERRNO(EBADF, SS_IVCHAN);
1432 Perl_PerlIO_close(pTHX_ PerlIO *f)
1434 const int code = PerlIO__close(aTHX_ f);
1435 while (PerlIOValid(f)) {
1436 PerlIO_pop(aTHX_ f);
1442 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1445 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1449 static PerlIO_funcs *
1450 PerlIO_layer_from_ref(pTHX_ SV *sv)
1454 * For any scalar type load the handler which is bundled with perl
1456 if (SvTYPE(sv) < SVt_PVAV) {
1457 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1458 /* This isn't supposed to happen, since PerlIO::scalar is core,
1459 * but could happen anyway in smaller installs or with PAR */
1461 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1466 * For other types allow if layer is known but don't try and load it
1468 switch (SvTYPE(sv)) {
1470 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1472 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1474 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1476 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1483 PerlIO_resolve_layers(pTHX_ const char *layers,
1484 const char *mode, int narg, SV **args)
1487 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1490 PerlIO_stdstreams(aTHX);
1492 SV * const arg = *args;
1494 * If it is a reference but not an object see if we have a handler
1497 if (SvROK(arg) && !sv_isobject(arg)) {
1498 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1500 def = PerlIO_list_alloc(aTHX);
1501 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1505 * Don't fail if handler cannot be found :via(...) etc. may do
1506 * something sensible else we will just stringfy and open
1511 if (!layers || !*layers)
1512 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1513 if (layers && *layers) {
1516 av = PerlIO_clone_list(aTHX_ def, NULL);
1521 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1525 PerlIO_list_free(aTHX_ av);
1537 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1538 int imode, int perm, PerlIO *f, int narg, SV **args)
1541 if (!f && narg == 1 && *args == &PL_sv_undef) {
1542 if ((f = PerlIO_tmpfile())) {
1543 if (!layers || !*layers)
1544 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1545 if (layers && *layers)
1546 PerlIO_apply_layers(aTHX_ f, mode, layers);
1550 PerlIO_list_t *layera;
1552 PerlIO_funcs *tab = NULL;
1553 if (PerlIOValid(f)) {
1555 * This is "reopen" - it is not tested as perl does not use it
1559 layera = PerlIO_list_alloc(aTHX);
1563 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1564 PerlIO_list_push(aTHX_ layera, l->tab,
1565 (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;
2278 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2280 /* Must be called with PL_perlio_mutex locked. */
2282 S_more_refcounted_fds(pTHX_ const int new_fd) {
2284 const int old_max = PL_perlio_fd_refcnt_size;
2285 const int new_max = 16 + (new_fd & ~15);
2288 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2289 old_max, new_fd, new_max);
2291 if (new_fd < old_max) {
2295 assert (new_max > new_fd);
2297 /* Use plain realloc() since we need this memory to be really
2298 * global and visible to all the interpreters and/or threads. */
2299 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2303 MUTEX_UNLOCK(&PL_perlio_mutex);
2305 /* Can't use PerlIO to write as it allocates memory */
2306 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2307 PL_no_mem, strlen(PL_no_mem));
2311 PL_perlio_fd_refcnt_size = new_max;
2312 PL_perlio_fd_refcnt = new_array;
2314 PerlIO_debug("Zeroing %p, %d\n",
2315 (void*)(new_array + old_max),
2318 Zero(new_array + old_max, new_max - old_max, int);
2325 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2326 PERL_UNUSED_CONTEXT;
2330 PerlIOUnix_refcnt_inc(int fd)
2337 MUTEX_LOCK(&PL_perlio_mutex);
2339 if (fd >= PL_perlio_fd_refcnt_size)
2340 S_more_refcounted_fds(aTHX_ fd);
2342 PL_perlio_fd_refcnt[fd]++;
2343 if (PL_perlio_fd_refcnt[fd] <= 0) {
2344 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2345 fd, PL_perlio_fd_refcnt[fd]);
2347 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2348 fd, PL_perlio_fd_refcnt[fd]);
2351 MUTEX_UNLOCK(&PL_perlio_mutex);
2354 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2359 PerlIOUnix_refcnt_dec(int fd)
2366 MUTEX_LOCK(&PL_perlio_mutex);
2368 if (fd >= PL_perlio_fd_refcnt_size) {
2369 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2370 fd, PL_perlio_fd_refcnt_size);
2372 if (PL_perlio_fd_refcnt[fd] <= 0) {
2373 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2374 fd, PL_perlio_fd_refcnt[fd]);
2376 cnt = --PL_perlio_fd_refcnt[fd];
2377 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2379 MUTEX_UNLOCK(&PL_perlio_mutex);
2382 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2388 PerlIO_cleanup(pTHX)
2393 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2395 PerlIO_debug("Cleanup layers\n");
2398 /* Raise STDIN..STDERR refcount so we don't close them */
2399 for (i=0; i < 3; i++)
2400 PerlIOUnix_refcnt_inc(i);
2401 PerlIO_cleantable(aTHX_ &PL_perlio);
2402 /* Restore STDIN..STDERR refcount */
2403 for (i=0; i < 3; i++)
2404 PerlIOUnix_refcnt_dec(i);
2406 if (PL_known_layers) {
2407 PerlIO_list_free(aTHX_ PL_known_layers);
2408 PL_known_layers = NULL;
2410 if (PL_def_layerlist) {
2411 PerlIO_list_free(aTHX_ PL_def_layerlist);
2412 PL_def_layerlist = NULL;
2416 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2420 /* XXX we can't rely on an interpreter being present at this late stage,
2421 XXX so we can't use a function like PerlLIO_write that relies on one
2422 being present (at least in win32) :-(.
2427 /* By now all filehandles should have been closed, so any
2428 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2430 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2431 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2432 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2434 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2435 if (PL_perlio_fd_refcnt[i]) {
2437 my_snprintf(buf, sizeof(buf),
2438 "PerlIO_teardown: fd %d refcnt=%d\n",
2439 i, PL_perlio_fd_refcnt[i]);
2440 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2446 /* Not bothering with PL_perlio_mutex since by now
2447 * all the interpreters are gone. */
2448 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2449 && PL_perlio_fd_refcnt) {
2450 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2451 PL_perlio_fd_refcnt = NULL;
2452 PL_perlio_fd_refcnt_size = 0;
2456 /*--------------------------------------------------------------------------------------*/
2458 * Bottom-most level for UNIX-like case
2462 struct _PerlIO base; /* The generic part */
2463 int fd; /* UNIX like file descriptor */
2464 int oflags; /* open/fcntl flags */
2468 PerlIOUnix_oflags(const char *mode)
2471 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2476 if (*++mode == '+') {
2483 oflags = O_CREAT | O_TRUNC;
2484 if (*++mode == '+') {
2493 oflags = O_CREAT | O_APPEND;
2494 if (*++mode == '+') {
2507 else if (*mode == 't') {
2509 oflags &= ~O_BINARY;
2513 * Always open in binary mode
2516 if (*mode || oflags == -1) {
2517 SETERRNO(EINVAL, LIB_INVARG);
2524 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2526 PERL_UNUSED_CONTEXT;
2527 return PerlIOSelf(f, PerlIOUnix)->fd;
2531 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2533 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2536 if (PerlLIO_fstat(fd, &st) == 0) {
2537 if (!S_ISREG(st.st_mode)) {
2538 PerlIO_debug("%d is not regular file\n",fd);
2539 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2542 PerlIO_debug("%d _is_ a regular file\n",fd);
2548 PerlIOUnix_refcnt_inc(fd);
2549 PERL_UNUSED_CONTEXT;
2553 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2555 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2556 if (*PerlIONext(f)) {
2557 /* We never call down so do any pending stuff now */
2558 PerlIO_flush(PerlIONext(f));
2560 * XXX could (or should) we retrieve the oflags from the open file
2561 * handle rather than believing the "mode" we are passed in? XXX
2562 * Should the value on NULL mode be 0 or -1?
2564 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2565 mode ? PerlIOUnix_oflags(mode) : -1);
2567 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2573 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2575 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2577 PERL_UNUSED_CONTEXT;
2578 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2580 SETERRNO(ESPIPE, LIB_INVARG);
2582 SETERRNO(EINVAL, LIB_INVARG);
2586 new_loc = PerlLIO_lseek(fd, offset, whence);
2587 if (new_loc == (Off_t) - 1)
2589 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2594 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2595 IV n, const char *mode, int fd, int imode,
2596 int perm, PerlIO *f, int narg, SV **args)
2598 if (PerlIOValid(f)) {
2599 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2600 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2603 if (*mode == IoTYPE_NUMERIC)
2606 imode = PerlIOUnix_oflags(mode);
2610 const char *path = SvPV_nolen_const(*args);
2611 fd = PerlLIO_open3(path, imode, perm);
2615 if (*mode == IoTYPE_IMPLICIT)
2618 f = PerlIO_allocate(aTHX);
2620 if (!PerlIOValid(f)) {
2621 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2625 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2626 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2627 if (*mode == IoTYPE_APPEND)
2628 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2635 * FIXME: pop layers ???
2643 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2645 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2647 if (flags & PERLIO_DUP_FD) {
2648 fd = PerlLIO_dup(fd);
2651 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2653 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2654 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2663 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2666 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2667 #ifdef PERLIO_STD_SPECIAL
2669 return PERLIO_STD_IN(fd, vbuf, count);
2671 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2672 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2676 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2677 if (len >= 0 || errno != EINTR) {
2679 if (errno != EAGAIN) {
2680 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2683 else if (len == 0 && count != 0) {
2684 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2695 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2698 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2699 #ifdef PERLIO_STD_SPECIAL
2700 if (fd == 1 || fd == 2)
2701 return PERLIO_STD_OUT(fd, vbuf, count);
2704 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2705 if (len >= 0 || errno != EINTR) {
2707 if (errno != EAGAIN) {
2708 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2719 PerlIOUnix_tell(pTHX_ PerlIO *f)
2721 PERL_UNUSED_CONTEXT;
2723 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2728 PerlIOUnix_close(pTHX_ PerlIO *f)
2731 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2733 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2734 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2735 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2740 SETERRNO(EBADF,SS_IVCHAN);
2743 while (PerlLIO_close(fd) != 0) {
2744 if (errno != EINTR) {
2751 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2756 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2757 sizeof(PerlIO_funcs),
2764 PerlIOBase_binmode, /* binmode */
2774 PerlIOBase_noop_ok, /* flush */
2775 PerlIOBase_noop_fail, /* fill */
2778 PerlIOBase_clearerr,
2779 PerlIOBase_setlinebuf,
2780 NULL, /* get_base */
2781 NULL, /* get_bufsiz */
2784 NULL, /* set_ptrcnt */
2787 /*--------------------------------------------------------------------------------------*/
2792 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2793 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2794 broken by the last second glibc 2.3 fix
2796 #define STDIO_BUFFER_WRITABLE
2801 struct _PerlIO base;
2802 FILE *stdio; /* The stream */
2806 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2808 PERL_UNUSED_CONTEXT;
2810 if (PerlIOValid(f)) {
2811 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2813 return PerlSIO_fileno(s);
2820 PerlIOStdio_mode(const char *mode, char *tmode)
2822 char * const ret = tmode;
2828 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2836 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2839 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2840 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2841 if (toptab == tab) {
2842 /* Top is already stdio - pop self (duplicate) and use original */
2843 PerlIO_pop(aTHX_ f);
2846 const int fd = PerlIO_fileno(n);
2849 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2850 mode = PerlIOStdio_mode(mode, tmode)))) {
2851 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2852 /* We never call down so do any pending stuff now */
2853 PerlIO_flush(PerlIONext(f));
2860 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2865 PerlIO_importFILE(FILE *stdio, const char *mode)
2871 if (!mode || !*mode) {
2872 /* We need to probe to see how we can open the stream
2873 so start with read/write and then try write and read
2874 we dup() so that we can fclose without loosing the fd.
2876 Note that the errno value set by a failing fdopen
2877 varies between stdio implementations.
2879 const int fd = PerlLIO_dup(fileno(stdio));
2880 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2882 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2885 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2888 /* Don't seem to be able to open */
2894 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2895 s = PerlIOSelf(f, PerlIOStdio);
2897 PerlIOUnix_refcnt_inc(fileno(stdio));
2904 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2905 IV n, const char *mode, int fd, int imode,
2906 int perm, PerlIO *f, int narg, SV **args)
2909 if (PerlIOValid(f)) {
2910 const char * const path = SvPV_nolen_const(*args);
2911 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2913 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2914 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2919 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2924 const char * const path = SvPV_nolen_const(*args);
2925 if (*mode == IoTYPE_NUMERIC) {
2927 fd = PerlLIO_open3(path, imode, perm);
2931 bool appended = FALSE;
2933 /* Cygwin wants its 'b' early. */
2935 mode = PerlIOStdio_mode(mode, tmode);
2937 stdio = PerlSIO_fopen(path, mode);
2940 f = PerlIO_allocate(aTHX);
2943 mode = PerlIOStdio_mode(mode, tmode);
2944 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2946 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2947 PerlIOUnix_refcnt_inc(fileno(stdio));
2949 PerlSIO_fclose(stdio);
2961 if (*mode == IoTYPE_IMPLICIT) {
2968 stdio = PerlSIO_stdin;
2971 stdio = PerlSIO_stdout;
2974 stdio = PerlSIO_stderr;
2979 stdio = PerlSIO_fdopen(fd, mode =
2980 PerlIOStdio_mode(mode, tmode));
2984 f = PerlIO_allocate(aTHX);
2986 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2987 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2988 PerlIOUnix_refcnt_inc(fileno(stdio));
2998 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3000 /* This assumes no layers underneath - which is what
3001 happens, but is not how I remember it. NI-S 2001/10/16
3003 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3004 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3005 const int fd = fileno(stdio);
3007 if (flags & PERLIO_DUP_FD) {
3008 const int dfd = PerlLIO_dup(fileno(stdio));
3010 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3015 /* FIXME: To avoid messy error recovery if dup fails
3016 re-use the existing stdio as though flag was not set
3020 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3022 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3024 PerlIOUnix_refcnt_inc(fileno(stdio));
3031 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3033 PERL_UNUSED_CONTEXT;
3035 /* XXX this could use PerlIO_canset_fileno() and
3036 * PerlIO_set_fileno() support from Configure
3038 # if defined(__UCLIBC__)
3039 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3042 # elif defined(__GLIBC__)
3043 /* There may be a better way for GLIBC:
3044 - libio.h defines a flag to not close() on cleanup
3048 # elif defined(__sun__)
3051 # elif defined(__hpux)
3055 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3056 your platform does not have special entry try this one.
3057 [For OSF only have confirmation for Tru64 (alpha)
3058 but assume other OSFs will be similar.]
3060 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3063 # elif defined(__FreeBSD__)
3064 /* There may be a better way on FreeBSD:
3065 - we could insert a dummy func in the _close function entry
3066 f->_close = (int (*)(void *)) dummy_close;
3070 # elif defined(__OpenBSD__)
3071 /* There may be a better way on OpenBSD:
3072 - we could insert a dummy func in the _close function entry
3073 f->_close = (int (*)(void *)) dummy_close;
3077 # elif defined(__EMX__)
3078 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3081 # elif defined(__CYGWIN__)
3082 /* There may be a better way on CYGWIN:
3083 - we could insert a dummy func in the _close function entry
3084 f->_close = (int (*)(void *)) dummy_close;
3088 # elif defined(WIN32)
3089 # if defined(__BORLANDC__)
3090 f->fd = PerlLIO_dup(fileno(f));
3091 # elif defined(UNDER_CE)
3092 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3101 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3102 (which isn't thread safe) instead
3104 # error "Don't know how to set FILE.fileno on your platform"
3112 PerlIOStdio_close(pTHX_ PerlIO *f)
3114 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3120 const int fd = fileno(stdio);
3128 #ifdef SOCKS5_VERSION_NAME
3129 /* Socks lib overrides close() but stdio isn't linked to
3130 that library (though we are) - so we must call close()
3131 on sockets on stdio's behalf.
3134 Sock_size_t optlen = sizeof(int);
3135 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3138 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3139 that a subsequent fileno() on it returns -1. Don't want to croak()
3140 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3141 trying to close an already closed handle which somehow it still has
3142 a reference to. (via.xs, I'm looking at you). */
3143 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3144 /* File descriptor still in use */
3148 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3149 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3151 if (stdio == stdout || stdio == stderr)
3152 return PerlIO_flush(f);
3153 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3154 Use Sarathy's trick from maint-5.6 to invalidate the
3155 fileno slot of the FILE *
3157 result = PerlIO_flush(f);
3159 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3162 MUTEX_LOCK(&PL_perlio_mutex);
3163 /* Right. We need a mutex here because for a brief while we
3164 will have the situation that fd is actually closed. Hence if
3165 a second thread were to get into this block, its dup() would
3166 likely return our fd as its dupfd. (after all, it is closed)
3167 Then if we get to the dup2() first, we blat the fd back
3168 (messing up its temporary as a side effect) only for it to
3169 then close its dupfd (== our fd) in its close(dupfd) */
3171 /* There is, of course, a race condition, that any other thread
3172 trying to input/output/whatever on this fd will be stuffed
3173 for the duration of this little manoeuvrer. Perhaps we
3174 should hold an IO mutex for the duration of every IO
3175 operation if we know that invalidate doesn't work on this
3176 platform, but that would suck, and could kill performance.
3178 Except that correctness trumps speed.
3179 Advice from klortho #11912. */
3181 dupfd = PerlLIO_dup(fd);
3184 MUTEX_UNLOCK(&PL_perlio_mutex);
3185 /* Oh cXap. This isn't going to go well. Not sure if we can
3186 recover from here, or if closing this particular FILE *
3187 is a good idea now. */
3192 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3194 result = PerlSIO_fclose(stdio);
3195 /* We treat error from stdio as success if we invalidated
3196 errno may NOT be expected EBADF
3198 if (invalidate && result != 0) {
3202 #ifdef SOCKS5_VERSION_NAME
3203 /* in SOCKS' case, let close() determine return value */
3207 PerlLIO_dup2(dupfd,fd);
3208 PerlLIO_close(dupfd);
3210 MUTEX_UNLOCK(&PL_perlio_mutex);
3218 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3221 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3225 STDCHAR *buf = (STDCHAR *) vbuf;
3227 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3228 * stdio does not do that for fread()
3230 const int ch = PerlSIO_fgetc(s);
3237 got = PerlSIO_fread(vbuf, 1, count, s);
3238 if (got == 0 && PerlSIO_ferror(s))
3240 if (got >= 0 || errno != EINTR)
3243 SETERRNO(0,0); /* just in case */
3249 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3252 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3254 #ifdef STDIO_BUFFER_WRITABLE
3255 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3256 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3257 STDCHAR *base = PerlIO_get_base(f);
3258 SSize_t cnt = PerlIO_get_cnt(f);
3259 STDCHAR *ptr = PerlIO_get_ptr(f);
3260 SSize_t avail = ptr - base;
3262 if (avail > count) {
3266 Move(buf-avail,ptr,avail,STDCHAR);
3269 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3270 if (PerlSIO_feof(s) && unread >= 0)
3271 PerlSIO_clearerr(s);
3276 if (PerlIO_has_cntptr(f)) {
3277 /* We can get pointer to buffer but not its base
3278 Do ungetc() but check chars are ending up in the
3281 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3282 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3284 const int ch = *--buf & 0xFF;
3285 if (ungetc(ch,s) != ch) {
3286 /* ungetc did not work */
3289 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3290 /* Did not change pointer as expected */
3291 fgetc(s); /* get char back again */
3301 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3307 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3312 got = PerlSIO_fwrite(vbuf, 1, count,
3313 PerlIOSelf(f, PerlIOStdio)->stdio);
3314 if (got >= 0 || errno != EINTR)
3317 SETERRNO(0,0); /* just in case */
3323 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3325 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3326 PERL_UNUSED_CONTEXT;
3328 return PerlSIO_fseek(stdio, offset, whence);
3332 PerlIOStdio_tell(pTHX_ PerlIO *f)
3334 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3335 PERL_UNUSED_CONTEXT;
3337 return PerlSIO_ftell(stdio);
3341 PerlIOStdio_flush(pTHX_ PerlIO *f)
3343 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3344 PERL_UNUSED_CONTEXT;
3346 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3347 return PerlSIO_fflush(stdio);
3353 * FIXME: This discards ungetc() and pre-read stuff which is not
3354 * right if this is just a "sync" from a layer above Suspect right
3355 * design is to do _this_ but not have layer above flush this
3356 * layer read-to-read
3359 * Not writeable - sync by attempting a seek
3362 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3370 PerlIOStdio_eof(pTHX_ PerlIO *f)
3372 PERL_UNUSED_CONTEXT;
3374 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3378 PerlIOStdio_error(pTHX_ PerlIO *f)
3380 PERL_UNUSED_CONTEXT;
3382 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3386 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3388 PERL_UNUSED_CONTEXT;
3390 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3394 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3396 PERL_UNUSED_CONTEXT;
3398 #ifdef HAS_SETLINEBUF
3399 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3401 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3407 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3409 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3410 return (STDCHAR*)PerlSIO_get_base(stdio);
3414 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3416 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3417 return PerlSIO_get_bufsiz(stdio);
3421 #ifdef USE_STDIO_PTR
3423 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3425 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3426 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3430 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3432 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3433 return PerlSIO_get_cnt(stdio);
3437 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3439 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3441 #ifdef STDIO_PTR_LVALUE
3442 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3443 #ifdef STDIO_PTR_LVAL_SETS_CNT
3444 assert(PerlSIO_get_cnt(stdio) == (cnt));
3446 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3448 * Setting ptr _does_ change cnt - we are done
3452 #else /* STDIO_PTR_LVALUE */
3454 #endif /* STDIO_PTR_LVALUE */
3457 * Now (or only) set cnt
3459 #ifdef STDIO_CNT_LVALUE
3460 PerlSIO_set_cnt(stdio, cnt);
3461 #else /* STDIO_CNT_LVALUE */
3462 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3463 PerlSIO_set_ptr(stdio,
3464 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3466 #else /* STDIO_PTR_LVAL_SETS_CNT */
3468 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3469 #endif /* STDIO_CNT_LVALUE */
3476 PerlIOStdio_fill(pTHX_ PerlIO *f)
3478 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3480 PERL_UNUSED_CONTEXT;
3483 * fflush()ing read-only streams can cause trouble on some stdio-s
3485 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3486 if (PerlSIO_fflush(stdio) != 0)
3490 c = PerlSIO_fgetc(stdio);
3493 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3499 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3501 #ifdef STDIO_BUFFER_WRITABLE
3502 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3503 /* Fake ungetc() to the real buffer in case system's ungetc
3506 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3507 SSize_t cnt = PerlSIO_get_cnt(stdio);
3508 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3509 if (ptr == base+1) {
3510 *--ptr = (STDCHAR) c;
3511 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3512 if (PerlSIO_feof(stdio))
3513 PerlSIO_clearerr(stdio);
3519 if (PerlIO_has_cntptr(f)) {
3521 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3528 /* An ungetc()d char is handled separately from the regular
3529 * buffer, so we stuff it in the buffer ourselves.
3530 * Should never get called as should hit code above
3532 *(--((*stdio)->_ptr)) = (unsigned char) c;
3535 /* If buffer snoop scheme above fails fall back to
3538 if (PerlSIO_ungetc(c, stdio) != c)
3546 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3547 sizeof(PerlIO_funcs),
3549 sizeof(PerlIOStdio),
3550 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3554 PerlIOBase_binmode, /* binmode */
3568 PerlIOStdio_clearerr,
3569 PerlIOStdio_setlinebuf,
3571 PerlIOStdio_get_base,
3572 PerlIOStdio_get_bufsiz,
3577 #ifdef USE_STDIO_PTR
3578 PerlIOStdio_get_ptr,
3579 PerlIOStdio_get_cnt,
3580 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3581 PerlIOStdio_set_ptrcnt,
3584 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3589 #endif /* USE_STDIO_PTR */
3592 /* Note that calls to PerlIO_exportFILE() are reversed using
3593 * PerlIO_releaseFILE(), not importFILE. */
3595 PerlIO_exportFILE(PerlIO * f, const char *mode)
3599 if (PerlIOValid(f)) {
3602 if (!mode || !*mode) {
3603 mode = PerlIO_modestr(f, buf);
3605 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3609 /* De-link any lower layers so new :stdio sticks */
3611 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3612 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3614 PerlIOUnix_refcnt_inc(fileno(stdio));
3615 /* Link previous lower layers under new one */
3619 /* restore layers list */
3629 PerlIO_findFILE(PerlIO *f)
3634 if (l->tab == &PerlIO_stdio) {
3635 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3638 l = *PerlIONext(&l);
3640 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3641 /* However, we're not really exporting a FILE * to someone else (who
3642 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3643 So we need to undo its refernce count increase on the underlying file
3644 descriptor. We have to do this, because if the loop above returns you
3645 the FILE *, then *it* didn't increase any reference count. So there's
3646 only one way to be consistent. */
3647 stdio = PerlIO_exportFILE(f, NULL);
3649 const int fd = fileno(stdio);
3651 PerlIOUnix_refcnt_dec(fd);
3656 /* Use this to reverse PerlIO_exportFILE calls. */
3658 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3663 if (l->tab == &PerlIO_stdio) {
3664 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3665 if (s->stdio == f) {
3667 const int fd = fileno(f);
3669 PerlIOUnix_refcnt_dec(fd);
3670 PerlIO_pop(aTHX_ p);
3679 /*--------------------------------------------------------------------------------------*/
3681 * perlio buffer layer
3685 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3687 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3688 const int fd = PerlIO_fileno(f);
3689 if (fd >= 0 && PerlLIO_isatty(fd)) {
3690 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3692 if (*PerlIONext(f)) {
3693 const Off_t posn = PerlIO_tell(PerlIONext(f));
3694 if (posn != (Off_t) - 1) {
3698 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3702 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3703 IV n, const char *mode, int fd, int imode, int perm,
3704 PerlIO *f, int narg, SV **args)
3706 if (PerlIOValid(f)) {
3707 PerlIO *next = PerlIONext(f);
3709 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3710 if (tab && tab->Open)
3712 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3714 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3719 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3721 if (*mode == IoTYPE_IMPLICIT) {
3727 if (tab && tab->Open)
3728 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3731 SETERRNO(EINVAL, LIB_INVARG);
3733 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3735 * if push fails during open, open fails. close will pop us.
3740 fd = PerlIO_fileno(f);
3741 if (init && fd == 2) {
3743 * Initial stderr is unbuffered
3745 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3747 #ifdef PERLIO_USING_CRLF
3748 # ifdef PERLIO_IS_BINMODE_FD
3749 if (PERLIO_IS_BINMODE_FD(fd))
3750 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3754 * do something about failing setmode()? --jhi
3756 PerlLIO_setmode(fd, O_BINARY);
3765 * This "flush" is akin to sfio's sync in that it handles files in either
3766 * read or write state. For write state, we put the postponed data through
3767 * the next layers. For read state, we seek() the next layers to the
3768 * offset given by current position in the buffer, and discard the buffer
3769 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3770 * in any case?). Then the pass the stick further in chain.
3773 PerlIOBuf_flush(pTHX_ PerlIO *f)
3775 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3777 PerlIO *n = PerlIONext(f);
3778 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3780 * write() the buffer
3782 const STDCHAR *buf = b->buf;
3783 const STDCHAR *p = buf;
3784 while (p < b->ptr) {
3785 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3789 else if (count < 0 || PerlIO_error(n)) {
3790 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3795 b->posn += (p - buf);
3797 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3798 STDCHAR *buf = PerlIO_get_base(f);
3800 * Note position change
3802 b->posn += (b->ptr - buf);
3803 if (b->ptr < b->end) {
3804 /* We did not consume all of it - try and seek downstream to
3805 our logical position
3807 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3808 /* Reload n as some layers may pop themselves on seek */
3809 b->posn = PerlIO_tell(n = PerlIONext(f));
3812 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3813 data is lost for good - so return saying "ok" having undone
3816 b->posn -= (b->ptr - buf);
3821 b->ptr = b->end = b->buf;
3822 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3823 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3824 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3829 /* This discards the content of the buffer after b->ptr, and rereads
3830 * the buffer from the position off in the layer downstream; here off
3831 * is at offset corresponding to b->ptr - b->buf.
3834 PerlIOBuf_fill(pTHX_ PerlIO *f)
3836 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3837 PerlIO *n = PerlIONext(f);
3840 * Down-stream flush is defined not to loose read data so is harmless.
3841 * we would not normally be fill'ing if there was data left in anycase.
3843 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3845 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3846 PerlIOBase_flush_linebuf(aTHX);
3849 PerlIO_get_base(f); /* allocate via vtable */
3851 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3853 b->ptr = b->end = b->buf;
3855 if (!PerlIOValid(n)) {
3856 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3860 if (PerlIO_fast_gets(n)) {
3862 * Layer below is also buffered. We do _NOT_ want to call its
3863 * ->Read() because that will loop till it gets what we asked for
3864 * which may hang on a pipe etc. Instead take anything it has to
3865 * hand, or ask it to fill _once_.
3867 avail = PerlIO_get_cnt(n);
3869 avail = PerlIO_fill(n);
3871 avail = PerlIO_get_cnt(n);
3873 if (!PerlIO_error(n) && PerlIO_eof(n))
3878 STDCHAR *ptr = PerlIO_get_ptr(n);
3879 const SSize_t cnt = avail;
3880 if (avail > (SSize_t)b->bufsiz)
3882 Copy(ptr, b->buf, avail, STDCHAR);
3883 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3887 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3891 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3893 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3896 b->end = b->buf + avail;
3897 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3902 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3904 if (PerlIOValid(f)) {
3905 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3908 return PerlIOBase_read(aTHX_ f, vbuf, count);
3914 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3916 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3917 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3920 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3925 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3927 * Buffer is already a read buffer, we can overwrite any chars
3928 * which have been read back to buffer start
3930 avail = (b->ptr - b->buf);
3934 * Buffer is idle, set it up so whole buffer is available for
3938 b->end = b->buf + avail;
3940 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3942 * Buffer extends _back_ from where we are now
3944 b->posn -= b->bufsiz;
3946 if (avail > (SSize_t) count) {
3948 * If we have space for more than count, just move count
3956 * In simple stdio-like ungetc() case chars will be already
3959 if (buf != b->ptr) {
3960 Copy(buf, b->ptr, avail, STDCHAR);
3964 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3968 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3974 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3976 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3977 const STDCHAR *buf = (const STDCHAR *) vbuf;
3978 const STDCHAR *flushptr = buf;
3982 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3984 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3985 if (PerlIO_flush(f) != 0) {
3989 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3990 flushptr = buf + count;
3991 while (flushptr > buf && *(flushptr - 1) != '\n')
3995 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3996 if ((SSize_t) count < avail)
3998 if (flushptr > buf && flushptr <= buf + avail)
3999 avail = flushptr - buf;
4000 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4002 Copy(buf, b->ptr, avail, STDCHAR);
4007 if (buf == flushptr)
4010 if (b->ptr >= (b->buf + b->bufsiz))
4013 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4019 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4022 if ((code = PerlIO_flush(f)) == 0) {
4023 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4024 code = PerlIO_seek(PerlIONext(f), offset, whence);
4026 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4027 b->posn = PerlIO_tell(PerlIONext(f));
4034 PerlIOBuf_tell(pTHX_ PerlIO *f)
4036 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4038 * b->posn is file position where b->buf was read, or will be written
4040 Off_t posn = b->posn;
4041 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4042 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4044 /* As O_APPEND files are normally shared in some sense it is better
4049 /* when file is NOT shared then this is sufficient */
4050 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4052 posn = b->posn = PerlIO_tell(PerlIONext(f));
4056 * If buffer is valid adjust position by amount in buffer
4058 posn += (b->ptr - b->buf);
4064 PerlIOBuf_popped(pTHX_ PerlIO *f)
4066 const IV code = PerlIOBase_popped(aTHX_ f);
4067 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4068 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4071 b->ptr = b->end = b->buf = NULL;
4072 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4077 PerlIOBuf_close(pTHX_ PerlIO *f)
4079 const IV code = PerlIOBase_close(aTHX_ f);
4080 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4081 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4084 b->ptr = b->end = b->buf = NULL;
4085 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4090 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4092 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4099 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4101 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4104 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4105 return (b->end - b->ptr);
4110 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4112 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4113 PERL_UNUSED_CONTEXT;
4118 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4120 b->buf = (STDCHAR *) & b->oneword;
4121 b->bufsiz = sizeof(b->oneword);
4123 b->end = b->ptr = b->buf;
4129 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4131 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4134 return (b->end - b->buf);
4138 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4140 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4142 PERL_UNUSED_ARG(cnt);
4147 assert(PerlIO_get_cnt(f) == cnt);
4148 assert(b->ptr >= b->buf);
4149 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4153 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4155 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4160 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4161 sizeof(PerlIO_funcs),
4164 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4168 PerlIOBase_binmode, /* binmode */
4182 PerlIOBase_clearerr,
4183 PerlIOBase_setlinebuf,
4188 PerlIOBuf_set_ptrcnt,
4191 /*--------------------------------------------------------------------------------------*/
4193 * Temp layer to hold unread chars when cannot do it any other way
4197 PerlIOPending_fill(pTHX_ PerlIO *f)
4200 * Should never happen
4207 PerlIOPending_close(pTHX_ PerlIO *f)
4210 * A tad tricky - flush pops us, then we close new top
4213 return PerlIO_close(f);
4217 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4220 * A tad tricky - flush pops us, then we seek new top
4223 return PerlIO_seek(f, offset, whence);
4228 PerlIOPending_flush(pTHX_ PerlIO *f)
4230 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4231 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4235 PerlIO_pop(aTHX_ f);
4240 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4246 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4251 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4253 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4254 PerlIOl * const l = PerlIOBase(f);
4256 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4257 * etc. get muddled when it changes mid-string when we auto-pop.
4259 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4260 (PerlIOBase(PerlIONext(f))->
4261 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4266 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4268 SSize_t avail = PerlIO_get_cnt(f);
4270 if ((SSize_t)count < avail)
4273 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4274 if (got >= 0 && got < (SSize_t)count) {
4275 const SSize_t more =
4276 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4277 if (more >= 0 || got == 0)
4283 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4284 sizeof(PerlIO_funcs),
4287 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4288 PerlIOPending_pushed,
4291 PerlIOBase_binmode, /* binmode */
4300 PerlIOPending_close,
4301 PerlIOPending_flush,
4305 PerlIOBase_clearerr,
4306 PerlIOBase_setlinebuf,
4311 PerlIOPending_set_ptrcnt,
4316 /*--------------------------------------------------------------------------------------*/
4318 * crlf - translation On read translate CR,LF to "\n" we do this by
4319 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4320 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4322 * c->nl points on the first byte of CR LF pair when it is temporarily
4323 * replaced by LF, or to the last CR of the buffer. In the former case
4324 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4325 * that it ends at c->nl; these two cases can be distinguished by
4326 * *c->nl. c->nl is set during _getcnt() call, and unset during
4327 * _unread() and _flush() calls.
4328 * It only matters for read operations.
4332 PerlIOBuf base; /* PerlIOBuf stuff */
4333 STDCHAR *nl; /* Position of crlf we "lied" about in the
4337 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4338 * Otherwise the :crlf layer would always revert back to
4342 S_inherit_utf8_flag(PerlIO *f)
4344 PerlIO *g = PerlIONext(f);
4345 if (PerlIOValid(g)) {
4346 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4347 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4353 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4356 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4357 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4359 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4360 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4361 PerlIOBase(f)->flags);
4364 /* Enable the first CRLF capable layer you can find, but if none
4365 * found, the one we just pushed is fine. This results in at
4366 * any given moment at most one CRLF-capable layer being enabled
4367 * in the whole layer stack. */
4368 PerlIO *g = PerlIONext(f);
4369 while (PerlIOValid(g)) {
4370 PerlIOl *b = PerlIOBase(g);
4371 if (b && b->tab == &PerlIO_crlf) {
4372 if (!(b->flags & PERLIO_F_CRLF))
4373 b->flags |= PERLIO_F_CRLF;
4374 S_inherit_utf8_flag(g);
4375 PerlIO_pop(aTHX_ f);
4381 S_inherit_utf8_flag(f);
4387 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4389 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4390 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4394 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4395 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4397 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4398 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4400 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4405 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4406 b->end = b->ptr = b->buf + b->bufsiz;
4407 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4408 b->posn -= b->bufsiz;
4410 while (count > 0 && b->ptr > b->buf) {
4411 const int ch = *--buf;
4413 if (b->ptr - 2 >= b->buf) {
4420 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4421 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4437 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4439 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4441 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4444 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4445 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4446 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4447 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4449 while (nl < b->end && *nl != 0xd)
4451 if (nl < b->end && *nl == 0xd) {
4453 if (nl + 1 < b->end) {
4460 * Not CR,LF but just CR
4468 * Blast - found CR as last char in buffer
4473 * They may not care, defer work as long as
4477 return (nl - b->ptr);
4481 b->ptr++; /* say we have read it as far as
4482 * flush() is concerned */
4483 b->buf++; /* Leave space in front of buffer */
4484 /* Note as we have moved buf up flush's
4486 will naturally make posn point at CR
4488 b->bufsiz--; /* Buffer is thus smaller */
4489 code = PerlIO_fill(f); /* Fetch some more */
4490 b->bufsiz++; /* Restore size for next time */
4491 b->buf--; /* Point at space */
4492 b->ptr = nl = b->buf; /* Which is what we hand
4494 *nl = 0xd; /* Fill in the CR */
4496 goto test; /* fill() call worked */
4498 * CR at EOF - just fall through
4500 /* Should we clear EOF though ??? */
4505 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4511 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4513 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4514 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4520 if (ptr == b->end && *c->nl == 0xd) {
4521 /* Defered CR at end of buffer case - we lied about count */
4534 * Test code - delete when it works ...
4536 IV flags = PerlIOBase(f)->flags;
4537 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4538 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4539 /* Defered CR at end of buffer case - we lied about count */
4545 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4546 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4547 flags, c->nl, b->end, cnt);
4554 * They have taken what we lied about
4562 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4566 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4568 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4569 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4571 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4572 const STDCHAR *buf = (const STDCHAR *) vbuf;
4573 const STDCHAR * const ebuf = buf + count;
4576 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4578 while (buf < ebuf) {
4579 const STDCHAR * const eptr = b->buf + b->bufsiz;
4580 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4581 while (buf < ebuf && b->ptr < eptr) {
4583 if ((b->ptr + 2) > eptr) {
4591 *(b->ptr)++ = 0xd; /* CR */
4592 *(b->ptr)++ = 0xa; /* LF */
4594 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4601 *(b->ptr)++ = *buf++;
4603 if (b->ptr >= eptr) {
4609 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4611 return (buf - (STDCHAR *) vbuf);
4616 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4618 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4623 return PerlIOBuf_flush(aTHX_ f);
4627 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4629 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4630 /* In text mode - flush any pending stuff and flip it */
4631 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4632 #ifndef PERLIO_USING_CRLF
4633 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4634 PerlIO_pop(aTHX_ f);
4640 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4641 sizeof(PerlIO_funcs),
4644 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4646 PerlIOBuf_popped, /* popped */
4648 PerlIOCrlf_binmode, /* binmode */
4652 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4653 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4654 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4662 PerlIOBase_clearerr,
4663 PerlIOBase_setlinebuf,
4668 PerlIOCrlf_set_ptrcnt,
4672 /*--------------------------------------------------------------------------------------*/
4674 * mmap as "buffer" layer
4678 PerlIOBuf base; /* PerlIOBuf stuff */
4679 Mmap_t mptr; /* Mapped address */
4680 Size_t len; /* mapped length */
4681 STDCHAR *bbuf; /* malloced buffer if map fails */
4685 PerlIOMmap_map(pTHX_ PerlIO *f)
4688 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4689 const IV flags = PerlIOBase(f)->flags;
4693 if (flags & PERLIO_F_CANREAD) {
4694 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4695 const int fd = PerlIO_fileno(f);
4697 code = Fstat(fd, &st);
4698 if (code == 0 && S_ISREG(st.st_mode)) {
4699 SSize_t len = st.st_size - b->posn;
4702 if (PL_mmap_page_size <= 0)
4703 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4707 * This is a hack - should never happen - open should
4710 b->posn = PerlIO_tell(PerlIONext(f));
4712 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4713 len = st.st_size - posn;
4714 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4715 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4716 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4717 madvise(m->mptr, len, MADV_SEQUENTIAL);
4719 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4720 madvise(m->mptr, len, MADV_WILLNEED);
4722 PerlIOBase(f)->flags =
4723 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4724 b->end = ((STDCHAR *) m->mptr) + len;
4725 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4734 PerlIOBase(f)->flags =
4735 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4737 b->ptr = b->end = b->ptr;
4746 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4748 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4751 PerlIOBuf * const b = &m->base;
4753 /* The munmap address argument is tricky: depending on the
4754 * standard it is either "void *" or "caddr_t" (which is
4755 * usually "char *" (signed or unsigned). If we cast it
4756 * to "void *", those that have it caddr_t and an uptight
4757 * C++ compiler, will freak out. But casting it as char*
4758 * should work. Maybe. (Using Mmap_t figured out by
4759 * Configure doesn't always work, apparently.) */
4760 code = munmap((char*)m->mptr, m->len);
4764 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4767 b->ptr = b->end = b->buf;
4768 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4774 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4776 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4777 PerlIOBuf * const b = &m->base;
4778 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4780 * Already have a readbuffer in progress
4786 * We have a write buffer or flushed PerlIOBuf read buffer
4788 m->bbuf = b->buf; /* save it in case we need it again */
4789 b->buf = NULL; /* Clear to trigger below */
4792 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4795 * Map did not work - recover PerlIOBuf buffer if we have one
4800 b->ptr = b->end = b->buf;
4803 return PerlIOBuf_get_base(aTHX_ f);
4807 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4809 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4810 PerlIOBuf * const b = &m->base;
4811 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4813 if (b->ptr && (b->ptr - count) >= b->buf
4814 && memEQ(b->ptr - count, vbuf, count)) {
4816 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4821 * Loose the unwritable mapped buffer
4825 * If flush took the "buffer" see if we have one from before
4827 if (!b->buf && m->bbuf)
4830 PerlIOBuf_get_base(aTHX_ f);
4834 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4838 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4840 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4841 PerlIOBuf * const b = &m->base;
4843 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4845 * No, or wrong sort of, buffer
4848 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4852 * If unmap took the "buffer" see if we have one from before
4854 if (!b->buf && m->bbuf)
4857 PerlIOBuf_get_base(aTHX_ f);
4861 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4865 PerlIOMmap_flush(pTHX_ PerlIO *f)
4867 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4868 PerlIOBuf * const b = &m->base;
4869 IV code = PerlIOBuf_flush(aTHX_ f);
4871 * Now we are "synced" at PerlIOBuf level
4878 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4883 * We seem to have a PerlIOBuf buffer which was not mapped
4884 * remember it in case we need one later
4893 PerlIOMmap_fill(pTHX_ PerlIO *f)
4895 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4896 IV code = PerlIO_flush(f);
4897 if (code == 0 && !b->buf) {
4898 code = PerlIOMmap_map(aTHX_ f);
4900 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4901 code = PerlIOBuf_fill(aTHX_ f);
4907 PerlIOMmap_close(pTHX_ PerlIO *f)
4909 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4910 PerlIOBuf * const b = &m->base;
4911 IV code = PerlIO_flush(f);
4915 b->ptr = b->end = b->buf;
4917 if (PerlIOBuf_close(aTHX_ f) != 0)
4923 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4925 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4929 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4930 sizeof(PerlIO_funcs),
4933 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4937 PerlIOBase_binmode, /* binmode */
4951 PerlIOBase_clearerr,
4952 PerlIOBase_setlinebuf,
4953 PerlIOMmap_get_base,
4957 PerlIOBuf_set_ptrcnt,
4960 #endif /* HAS_MMAP */
4963 Perl_PerlIO_stdin(pTHX)
4967 PerlIO_stdstreams(aTHX);
4969 return &PL_perlio[1];
4973 Perl_PerlIO_stdout(pTHX)
4977 PerlIO_stdstreams(aTHX);
4979 return &PL_perlio[2];
4983 Perl_PerlIO_stderr(pTHX)
4987 PerlIO_stdstreams(aTHX);
4989 return &PL_perlio[3];
4992 /*--------------------------------------------------------------------------------------*/
4995 PerlIO_getname(PerlIO *f, char *buf)
5000 bool exported = FALSE;
5001 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5003 stdio = PerlIO_exportFILE(f,0);
5007 name = fgetname(stdio, buf);
5008 if (exported) PerlIO_releaseFILE(f,stdio);
5013 PERL_UNUSED_ARG(buf);
5014 Perl_croak(aTHX_ "Don't know how to get file name");
5020 /*--------------------------------------------------------------------------------------*/
5022 * Functions which can be called on any kind of PerlIO implemented in
5026 #undef PerlIO_fdopen
5028 PerlIO_fdopen(int fd, const char *mode)
5031 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5036 PerlIO_open(const char *path, const char *mode)
5039 SV *name = sv_2mortal(newSVpv(path, 0));
5040 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5043 #undef Perlio_reopen
5045 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5048 SV *name = sv_2mortal(newSVpv(path,0));
5049 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5054 PerlIO_getc(PerlIO *f)
5058 if ( 1 == PerlIO_read(f, buf, 1) ) {
5059 return (unsigned char) buf[0];
5064 #undef PerlIO_ungetc
5066 PerlIO_ungetc(PerlIO *f, int ch)
5071 if (PerlIO_unread(f, &buf, 1) == 1)
5079 PerlIO_putc(PerlIO *f, int ch)
5083 return PerlIO_write(f, &buf, 1);
5088 PerlIO_puts(PerlIO *f, const char *s)
5091 return PerlIO_write(f, s, strlen(s));
5094 #undef PerlIO_rewind
5096 PerlIO_rewind(PerlIO *f)
5099 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5103 #undef PerlIO_vprintf
5105 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5114 Perl_va_copy(ap, apc);
5115 sv = vnewSVpvf(fmt, &apc);
5117 sv = vnewSVpvf(fmt, &ap);
5119 s = SvPV_const(sv, len);
5120 wrote = PerlIO_write(f, s, len);
5125 #undef PerlIO_printf
5127 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5132 result = PerlIO_vprintf(f, fmt, ap);
5137 #undef PerlIO_stdoutf
5139 PerlIO_stdoutf(const char *fmt, ...)
5145 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5150 #undef PerlIO_tmpfile
5152 PerlIO_tmpfile(void)
5157 const int fd = win32_tmpfd();
5159 f = PerlIO_fdopen(fd, "w+b");
5161 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5163 char tempname[] = "/tmp/PerlIO_XXXXXX";
5164 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5165 SV * const sv = tmpdir && *tmpdir ? newSVpv(tmpdir, 0) : NULL;
5167 * I have no idea how portable mkstemp() is ... NI-S
5170 /* if TMPDIR is set and not empty, we try that first */
5171 sv_catpv(sv, tempname + 4);
5172 fd = mkstemp(SvPVX(sv));
5175 /* else we try /tmp */
5176 fd = mkstemp(tempname);
5179 f = PerlIO_fdopen(fd, "w+");
5181 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5182 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5186 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5187 FILE * const stdio = PerlSIO_tmpfile();
5190 f = PerlIO_fdopen(fileno(stdio), "w+");
5192 # endif /* else HAS_MKSTEMP */
5193 #endif /* else WIN32 */
5200 #endif /* USE_SFIO */
5201 #endif /* PERLIO_IS_STDIO */
5203 /*======================================================================================*/
5205 * Now some functions in terms of above which may be needed even if we are
5206 * not in true PerlIO mode
5209 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5212 const char *direction = NULL;
5215 * Need to supply default layer info from open.pm
5221 if (mode && mode[0] != 'r') {
5222 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5223 direction = "open>";
5225 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5226 direction = "open<";
5231 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5232 0, direction, 5, 0, 0);
5235 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5240 #undef PerlIO_setpos
5242 PerlIO_setpos(PerlIO *f, SV *pos)
5247 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5248 if (f && len == sizeof(Off_t))
5249 return PerlIO_seek(f, *posn, SEEK_SET);
5251 SETERRNO(EINVAL, SS_IVCHAN);
5255 #undef PerlIO_setpos
5257 PerlIO_setpos(PerlIO *f, SV *pos)
5262 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5263 if (f && len == sizeof(Fpos_t)) {
5264 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5265 return fsetpos64(f, fpos);
5267 return fsetpos(f, fpos);
5271 SETERRNO(EINVAL, SS_IVCHAN);
5277 #undef PerlIO_getpos
5279 PerlIO_getpos(PerlIO *f, SV *pos)
5282 Off_t posn = PerlIO_tell(f);
5283 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5284 return (posn == (Off_t) - 1) ? -1 : 0;
5287 #undef PerlIO_getpos
5289 PerlIO_getpos(PerlIO *f, SV *pos)
5294 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5295 code = fgetpos64(f, &fpos);
5297 code = fgetpos(f, &fpos);
5299 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5304 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5307 vprintf(char *pat, char *args)
5309 _doprnt(pat, args, stdout);
5310 return 0; /* wrong, but perl doesn't use the return
5315 vfprintf(FILE *fd, char *pat, char *args)
5317 _doprnt(pat, args, fd);
5318 return 0; /* wrong, but perl doesn't use the return
5324 #ifndef PerlIO_vsprintf
5326 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5329 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5330 PERL_UNUSED_CONTEXT;
5332 #ifndef PERL_MY_VSNPRINTF_GUARDED
5333 if (val < 0 || (n > 0 ? val >= n : 0)) {
5334 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5341 #ifndef PerlIO_sprintf
5343 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5348 result = PerlIO_vsprintf(s, n, fmt, ap);
5356 * c-indentation-style: bsd
5358 * indent-tabs-mode: t
5361 * ex: set ts=8 sts=4 sw=4 noet: