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 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
75 /* Call the callback or PerlIOBase, and return failure. */
76 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
77 if (PerlIOValid(f)) { \
78 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
79 if (tab && tab->callback) \
80 return (*tab->callback) args; \
82 return PerlIOBase_ ## base args; \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or fail, and return failure. */
89 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 return (*tab->callback) args; \
94 SETERRNO(EINVAL, LIB_INVARG); \
97 SETERRNO(EBADF, SS_IVCHAN); \
100 /* Call the callback or PerlIOBase, and be void. */
101 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 PerlIOBase_ ## base args; \
110 SETERRNO(EBADF, SS_IVCHAN)
112 /* Call the callback or fail, and be void. */
113 #define Perl_PerlIO_or_fail_void(f, callback, args) \
114 if (PerlIOValid(f)) { \
115 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
116 if (tab && tab->callback) \
117 (*tab->callback) args; \
119 SETERRNO(EINVAL, LIB_INVARG); \
122 SETERRNO(EBADF, SS_IVCHAN)
124 #if defined(__osf__) && _XOPEN_SOURCE < 500
125 extern int fseeko(FILE *, off_t, int);
126 extern off_t ftello(FILE *);
131 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
134 perlsio_binmode(FILE *fp, int iotype, int mode)
137 * This used to be contents of do_binmode in doio.c
140 # if defined(atarist)
141 PERL_UNUSED_ARG(iotype);
144 ((FILE *) fp)->_flag |= _IOBIN;
146 ((FILE *) fp)->_flag &= ~_IOBIN;
152 PERL_UNUSED_ARG(iotype);
154 if (PerlLIO_setmode(fp, mode) != -1) {
156 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
158 # if defined(WIN32) && defined(__BORLANDC__)
160 * The translation mode of the stream is maintained independent
162 * the translation mode of the fd in the Borland RTL (heavy
163 * digging through their runtime sources reveal). User has to
165 * the mode explicitly for the stream (though they don't
167 * this anywhere). GSAR 97-5-24
173 fp->flags &= ~_F_BIN;
181 # if defined(USEMYBINMODE)
183 # if defined(__CYGWIN__)
184 PERL_UNUSED_ARG(iotype);
186 if (my_binmode(fp, iotype, mode) != FALSE)
192 PERL_UNUSED_ARG(iotype);
193 PERL_UNUSED_ARG(mode);
201 #define O_ACCMODE 3 /* Assume traditional implementation */
205 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
207 const int result = rawmode & O_ACCMODE;
212 ptype = IoTYPE_RDONLY;
215 ptype = IoTYPE_WRONLY;
223 *writing = (result != O_RDONLY);
225 if (result == O_RDONLY) {
229 else if (rawmode & O_APPEND) {
231 if (result != O_WRONLY)
236 if (result == O_WRONLY)
243 if (rawmode & O_BINARY)
249 #ifndef PERLIO_LAYERS
251 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
253 if (!names || !*names
254 || strEQ(names, ":crlf")
255 || strEQ(names, ":raw")
256 || strEQ(names, ":bytes")
260 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
268 PerlIO_destruct(pTHX)
273 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
276 PERL_UNUSED_ARG(iotype);
277 PERL_UNUSED_ARG(mode);
278 PERL_UNUSED_ARG(names);
281 return perlsio_binmode(fp, iotype, mode);
286 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
288 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
291 #ifdef PERL_IMPLICIT_SYS
292 return PerlSIO_fdupopen(f);
295 return win32_fdupopen(f);
298 const int fd = PerlLIO_dup(PerlIO_fileno(f));
302 const int omode = djgpp_get_stream_mode(f);
304 const int omode = fcntl(fd, F_GETFL);
306 PerlIO_intmode2str(omode,mode,NULL);
307 /* the r+ is a hack */
308 return PerlIO_fdopen(fd, mode);
313 SETERRNO(EBADF, SS_IVCHAN);
323 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
327 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
328 int imode, int perm, PerlIO *old, int narg, SV **args)
332 Perl_croak(aTHX_ "More than one argument to open");
334 if (*args == &PL_sv_undef)
335 return PerlIO_tmpfile();
337 const char *name = SvPV_nolen_const(*args);
338 if (*mode == IoTYPE_NUMERIC) {
339 fd = PerlLIO_open3(name, imode, perm);
341 return PerlIO_fdopen(fd, mode + 1);
344 return PerlIO_reopen(name, mode, old);
347 return PerlIO_open(name, mode);
352 return PerlIO_fdopen(fd, (char *) mode);
357 XS(XS_PerlIO__Layer__find)
361 Perl_croak(aTHX_ "Usage class->find(name[,load])");
363 const char * const name = SvPV_nolen_const(ST(1));
364 ST(0) = (strEQ(name, "crlf")
365 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
372 Perl_boot_core_PerlIO(pTHX)
374 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
380 #ifdef PERLIO_IS_STDIO
387 * Does nothing (yet) except force this file to be included in perl
388 * binary. That allows this file to force inclusion of other functions
389 * that may be required by loadable extensions e.g. for
390 * FileHandle::tmpfile
394 #undef PerlIO_tmpfile
401 #else /* PERLIO_IS_STDIO */
409 * This section is just to make sure these functions get pulled in from
413 #undef PerlIO_tmpfile
425 * Force this file to be included in perl binary. Which allows this
426 * file to force inclusion of other functions that may be required by
427 * loadable extensions e.g. for FileHandle::tmpfile
431 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
432 * results in a lot of lseek()s to regular files and lot of small
435 sfset(sfstdout, SF_SHARE, 0);
438 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
440 PerlIO_importFILE(FILE *stdio, const char *mode)
442 const int fd = fileno(stdio);
443 if (!mode || !*mode) {
446 return PerlIO_fdopen(fd, mode);
450 PerlIO_findFILE(PerlIO *pio)
452 const int fd = PerlIO_fileno(pio);
453 FILE * const f = fdopen(fd, "r+");
455 if (!f && errno == EINVAL)
457 if (!f && errno == EINVAL)
464 /*======================================================================================*/
466 * Implement all the PerlIO interface ourselves.
472 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
479 #include <sys/mman.h>
483 PerlIO_debug(const char *fmt, ...)
488 if (!PL_perlio_debug_fd) {
489 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
490 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
493 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
495 PL_perlio_debug_fd = -1;
497 /* tainting or set*id, so ignore the environment, and ensure we
498 skip these tests next time through. */
499 PL_perlio_debug_fd = -1;
502 if (PL_perlio_debug_fd > 0) {
505 const char * const s = CopFILE(PL_curcop);
506 /* Use fixed buffer as sv_catpvf etc. needs SVs */
508 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
509 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
510 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
512 const char *s = CopFILE(PL_curcop);
514 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
515 (IV) CopLINE(PL_curcop));
516 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
518 s = SvPV_const(sv, len);
519 PerlLIO_write(PL_perlio_debug_fd, s, len);
526 /*--------------------------------------------------------------------------------------*/
529 * Inner level routines
532 /* check that the head field of each layer points back to the head */
535 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
537 PerlIO_verify_head(pTHX_ PerlIO *f)
543 p = head = PerlIOBase(f)->head;
546 assert(p->head == head);
547 if (p == (PerlIOl*)f)
554 # define VERIFY_HEAD(f)
559 * Table of pointers to the PerlIO structs (malloc'ed)
561 #define PERLIO_TABLE_SIZE 64
564 PerlIO_init_table(pTHX)
568 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
574 PerlIO_allocate(pTHX)
578 * Find a free slot in the table, allocating new table as necessary
583 while ((f = *last)) {
585 last = (PerlIOl **) (f);
586 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
587 if (!((++f)->next)) {
588 f->flags = 0; /* lockcnt */
595 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
599 *last = (PerlIOl*) f++;
600 f->flags = 0; /* lockcnt */
606 #undef PerlIO_fdupopen
608 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
610 if (PerlIOValid(f)) {
611 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
612 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
614 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
616 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
620 SETERRNO(EBADF, SS_IVCHAN);
626 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
628 PerlIOl * const table = *tablep;
631 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
632 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
633 PerlIOl * const f = table + i;
635 PerlIO_close(&(f->next));
645 PerlIO_list_alloc(pTHX)
649 Newxz(list, 1, PerlIO_list_t);
655 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
658 if (--list->refcnt == 0) {
661 for (i = 0; i < list->cur; i++)
662 SvREFCNT_dec(list->array[i].arg);
663 Safefree(list->array);
671 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
677 if (list->cur >= list->len) {
680 Renew(list->array, list->len, PerlIO_pair_t);
682 Newx(list->array, list->len, PerlIO_pair_t);
684 p = &(list->array[list->cur++]);
686 if ((p->arg = arg)) {
687 SvREFCNT_inc_simple_void_NN(arg);
692 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
694 PerlIO_list_t *list = NULL;
697 list = PerlIO_list_alloc(aTHX);
698 for (i=0; i < proto->cur; i++) {
699 SV *arg = proto->array[i].arg;
702 arg = sv_dup(arg, param);
704 PERL_UNUSED_ARG(param);
706 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
713 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
716 PerlIOl **table = &proto->Iperlio;
719 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
720 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
721 PerlIO_init_table(aTHX);
722 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
723 while ((f = *table)) {
725 table = (PerlIOl **) (f++);
726 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
728 (void) fp_dup(&(f->next), 0, param);
735 PERL_UNUSED_ARG(proto);
736 PERL_UNUSED_ARG(param);
741 PerlIO_destruct(pTHX)
744 PerlIOl **table = &PL_perlio;
747 PerlIO_debug("Destruct %p\n",(void*)aTHX);
749 while ((f = *table)) {
751 table = (PerlIOl **) (f++);
752 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
753 PerlIO *x = &(f->next);
756 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
757 PerlIO_debug("Destruct popping %s\n", l->tab->name);
771 PerlIO_pop(pTHX_ PerlIO *f)
773 const PerlIOl *l = *f;
776 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
777 l->tab ? l->tab->name : "(Null)");
778 if (l->tab && l->tab->Popped) {
780 * If popped returns non-zero do not free its layer structure
781 * it has either done so itself, or it is shared and still in
784 if ((*l->tab->Popped) (aTHX_ f) != 0)
787 if (PerlIO_lockcnt(f)) {
788 /* we're in use; defer freeing the structure */
789 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
790 PerlIOBase(f)->tab = NULL;
800 /* Return as an array the stack of layers on a filehandle. Note that
801 * the stack is returned top-first in the array, and there are three
802 * times as many array elements as there are layers in the stack: the
803 * first element of a layer triplet is the name, the second one is the
804 * arguments, and the third one is the flags. */
807 PerlIO_get_layers(pTHX_ PerlIO *f)
810 AV * const av = newAV();
812 if (PerlIOValid(f)) {
813 PerlIOl *l = PerlIOBase(f);
816 /* There is some collusion in the implementation of
817 XS_PerlIO_get_layers - it knows that name and flags are
818 generated as fresh SVs here, and takes advantage of that to
819 "copy" them by taking a reference. If it changes here, it needs
820 to change there too. */
821 SV * const name = l->tab && l->tab->name ?
822 newSVpv(l->tab->name, 0) : &PL_sv_undef;
823 SV * const arg = l->tab && l->tab->Getarg ?
824 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
827 av_push(av, newSViv((IV)l->flags));
835 /*--------------------------------------------------------------------------------------*/
837 * XS Interface for perl code
841 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
845 if ((SSize_t) len <= 0)
847 for (i = 0; i < PL_known_layers->cur; i++) {
848 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
849 if (memEQ(f->name, name, len) && f->name[len] == 0) {
850 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
854 if (load && PL_subname && PL_def_layerlist
855 && PL_def_layerlist->cur >= 2) {
856 if (PL_in_load_module) {
857 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
860 SV * const pkgsv = newSVpvs("PerlIO");
861 SV * const layer = newSVpvn(name, len);
862 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
864 SAVEBOOL(PL_in_load_module);
866 SAVEGENERICSV(PL_warnhook);
867 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
869 PL_in_load_module = TRUE;
871 * The two SVs are magically freed by load_module
873 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
875 return PerlIO_find_layer(aTHX_ name, len, 0);
878 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
882 #ifdef USE_ATTRIBUTES_FOR_PERLIO
885 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
888 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
889 PerlIO * const ifp = IoIFP(io);
890 PerlIO * const ofp = IoOFP(io);
891 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
892 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
898 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
901 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
902 PerlIO * const ifp = IoIFP(io);
903 PerlIO * const ofp = IoOFP(io);
904 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
905 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
911 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
913 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
918 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
920 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
924 MGVTBL perlio_vtab = {
932 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
935 SV * const sv = SvRV(ST(1));
936 AV * const av = newAV();
940 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
942 mg = mg_find(sv, PERL_MAGIC_ext);
943 mg->mg_virtual = &perlio_vtab;
945 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
946 for (i = 2; i < items; i++) {
948 const char * const name = SvPV_const(ST(i), len);
949 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
951 av_push(av, SvREFCNT_inc_simple_NN(layer));
962 #endif /* USE_ATTIBUTES_FOR_PERLIO */
965 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
967 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
968 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
972 XS(XS_PerlIO__Layer__NoWarnings)
974 /* This is used as a %SIG{__WARN__} handler to suppress warnings
975 during loading of layers.
981 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
985 XS(XS_PerlIO__Layer__find)
991 Perl_croak(aTHX_ "Usage class->find(name[,load])");
994 const char * const name = SvPV_const(ST(1), len);
995 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
996 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
998 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
1005 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
1008 if (!PL_known_layers)
1009 PL_known_layers = PerlIO_list_alloc(aTHX);
1010 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
1011 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
1015 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1019 const char *s = names;
1021 while (isSPACE(*s) || *s == ':')
1026 const char *as = NULL;
1028 if (!isIDFIRST(*s)) {
1030 * Message is consistent with how attribute lists are
1031 * passed. Even though this means "foo : : bar" is
1032 * seen as an invalid separator character.
1034 const char q = ((*s == '\'') ? '"' : '\'');
1035 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1036 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1038 SETERRNO(EINVAL, LIB_INVARG);
1043 } while (isALNUM(*e));
1052 alen = (e - 1) - as;
1059 * It's a nul terminated string, not allowed
1060 * to \ the terminating null. Anything other
1061 * character is passed over.
1071 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1072 "Argument list not closed for PerlIO layer \"%.*s\"",
1084 PerlIO_funcs * const layer =
1085 PerlIO_find_layer(aTHX_ s, llen, 1);
1089 arg = newSVpvn(as, alen);
1090 PerlIO_list_push(aTHX_ av, layer,
1091 (arg) ? arg : &PL_sv_undef);
1095 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1108 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1111 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1112 #ifdef PERLIO_USING_CRLF
1115 if (PerlIO_stdio.Set_ptrcnt)
1116 tab = &PerlIO_stdio;
1118 PerlIO_debug("Pushing %s\n", tab->name);
1119 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1124 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1126 return av->array[n].arg;
1130 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1132 if (n >= 0 && n < av->cur) {
1133 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1134 av->array[n].funcs->name);
1135 return av->array[n].funcs;
1138 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1143 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1145 PERL_UNUSED_ARG(mode);
1146 PERL_UNUSED_ARG(arg);
1147 PERL_UNUSED_ARG(tab);
1148 if (PerlIOValid(f)) {
1150 PerlIO_pop(aTHX_ f);
1156 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1157 sizeof(PerlIO_funcs),
1160 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1180 NULL, /* get_base */
1181 NULL, /* get_bufsiz */
1184 NULL, /* set_ptrcnt */
1188 PerlIO_default_layers(pTHX)
1191 if (!PL_def_layerlist) {
1192 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1193 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1194 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1195 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1197 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1199 osLayer = &PerlIO_win32;
1202 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1203 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1204 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1205 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1207 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1209 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1210 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1211 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1212 PerlIO_list_push(aTHX_ PL_def_layerlist,
1213 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1216 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1219 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1222 if (PL_def_layerlist->cur < 2) {
1223 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1225 return PL_def_layerlist;
1229 Perl_boot_core_PerlIO(pTHX)
1231 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1232 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1235 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1236 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1240 PerlIO_default_layer(pTHX_ I32 n)
1243 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1246 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1249 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1250 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1253 PerlIO_stdstreams(pTHX)
1257 PerlIO_init_table(aTHX);
1258 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1259 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1260 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1265 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1268 if (tab->fsize != sizeof(PerlIO_funcs)) {
1270 "%s (%d) does not match %s (%d)",
1271 "PerlIO layer function table size", tab->fsize,
1272 "size expected by this perl", sizeof(PerlIO_funcs) );
1276 if (tab->size < sizeof(PerlIOl)) {
1278 "%s (%d) smaller than %s (%d)",
1279 "PerlIO layer instance size", tab->size,
1280 "size expected by this perl", sizeof(PerlIOl) );
1282 /* Real layer with a data area */
1285 Newxz(temp, tab->size, char);
1289 l->tab = (PerlIO_funcs*) tab;
1290 l->head = ((PerlIOl*)f)->head;
1292 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1293 (void*)f, tab->name,
1294 (mode) ? mode : "(Null)", (void*)arg);
1295 if (*l->tab->Pushed &&
1297 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1298 PerlIO_pop(aTHX_ f);
1307 /* Pseudo-layer where push does its own stack adjust */
1308 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1309 (mode) ? mode : "(Null)", (void*)arg);
1311 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1319 PerlIOBase_binmode(pTHX_ PerlIO *f)
1321 if (PerlIOValid(f)) {
1322 /* Is layer suitable for raw stream ? */
1323 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1324 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1325 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1328 /* Not suitable - pop it */
1329 PerlIO_pop(aTHX_ f);
1337 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1339 PERL_UNUSED_ARG(mode);
1340 PERL_UNUSED_ARG(arg);
1341 PERL_UNUSED_ARG(tab);
1343 if (PerlIOValid(f)) {
1348 * Strip all layers that are not suitable for a raw stream
1351 while (t && (l = *t)) {
1352 if (l->tab && l->tab->Binmode) {
1353 /* Has a handler - normal case */
1354 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1356 /* Layer still there - move down a layer */
1365 /* No handler - pop it */
1366 PerlIO_pop(aTHX_ t);
1369 if (PerlIOValid(f)) {
1370 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1371 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1379 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1380 PerlIO_list_t *layers, IV n, IV max)
1384 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1386 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1397 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1401 save_scalar(PL_errgv);
1403 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1404 code = PerlIO_parse_layers(aTHX_ layers, names);
1406 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1408 PerlIO_list_free(aTHX_ layers);
1415 /*--------------------------------------------------------------------------------------*/
1417 * Given the abstraction above the public API functions
1421 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1423 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1424 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1425 PerlIOBase(f)->tab->name : "(Null)",
1426 iotype, mode, (names) ? names : "(Null)");
1429 /* Do not flush etc. if (e.g.) switching encodings.
1430 if a pushed layer knows it needs to flush lower layers
1431 (for example :unix which is never going to call them)
1432 it can do the flush when it is pushed.
1434 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1437 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1438 #ifdef PERLIO_USING_CRLF
1439 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1440 O_BINARY so we can look for it in mode.
1442 if (!(mode & O_BINARY)) {
1444 /* FIXME?: Looking down the layer stack seems wrong,
1445 but is a way of reaching past (say) an encoding layer
1446 to flip CRLF-ness of the layer(s) below
1449 /* Perhaps we should turn on bottom-most aware layer
1450 e.g. Ilya's idea that UNIX TTY could serve
1452 if (PerlIOBase(f)->tab &&
1453 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1455 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1456 /* Not in text mode - flush any pending stuff and flip it */
1458 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1460 /* Only need to turn it on in one layer so we are done */
1465 /* Not finding a CRLF aware layer presumably means we are binary
1466 which is not what was requested - so we failed
1467 We _could_ push :crlf layer but so could caller
1472 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1473 So code that used to be here is now in PerlIORaw_pushed().
1475 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1480 PerlIO__close(pTHX_ PerlIO *f)
1482 if (PerlIOValid(f)) {
1483 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1484 if (tab && tab->Close)
1485 return (*tab->Close)(aTHX_ f);
1487 return PerlIOBase_close(aTHX_ f);
1490 SETERRNO(EBADF, SS_IVCHAN);
1496 Perl_PerlIO_close(pTHX_ PerlIO *f)
1498 const int code = PerlIO__close(aTHX_ f);
1499 while (PerlIOValid(f)) {
1500 PerlIO_pop(aTHX_ f);
1501 if (PerlIO_lockcnt(f))
1502 /* we're in use; the 'pop' deferred freeing the structure */
1509 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1512 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1516 static PerlIO_funcs *
1517 PerlIO_layer_from_ref(pTHX_ SV *sv)
1521 * For any scalar type load the handler which is bundled with perl
1523 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1524 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1525 /* This isn't supposed to happen, since PerlIO::scalar is core,
1526 * but could happen anyway in smaller installs or with PAR */
1528 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1533 * For other types allow if layer is known but don't try and load it
1535 switch (SvTYPE(sv)) {
1537 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1539 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1541 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1543 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1550 PerlIO_resolve_layers(pTHX_ const char *layers,
1551 const char *mode, int narg, SV **args)
1554 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1557 PerlIO_stdstreams(aTHX);
1559 SV * const arg = *args;
1561 * If it is a reference but not an object see if we have a handler
1564 if (SvROK(arg) && !sv_isobject(arg)) {
1565 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1567 def = PerlIO_list_alloc(aTHX);
1568 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1572 * Don't fail if handler cannot be found :via(...) etc. may do
1573 * something sensible else we will just stringfy and open
1578 if (!layers || !*layers)
1579 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1580 if (layers && *layers) {
1583 av = PerlIO_clone_list(aTHX_ def, NULL);
1588 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1592 PerlIO_list_free(aTHX_ av);
1604 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1605 int imode, int perm, PerlIO *f, int narg, SV **args)
1608 if (!f && narg == 1 && *args == &PL_sv_undef) {
1609 if ((f = PerlIO_tmpfile())) {
1610 if (!layers || !*layers)
1611 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1612 if (layers && *layers)
1613 PerlIO_apply_layers(aTHX_ f, mode, layers);
1617 PerlIO_list_t *layera;
1619 PerlIO_funcs *tab = NULL;
1620 if (PerlIOValid(f)) {
1622 * This is "reopen" - it is not tested as perl does not use it
1626 layera = PerlIO_list_alloc(aTHX);
1629 if (l->tab && l->tab->Getarg)
1630 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1631 PerlIO_list_push(aTHX_ layera, l->tab,
1632 (arg) ? arg : &PL_sv_undef);
1634 l = *PerlIONext(&l);
1638 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1644 * Start at "top" of layer stack
1646 n = layera->cur - 1;
1648 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1657 * Found that layer 'n' can do opens - call it
1659 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1660 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1662 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1663 tab->name, layers ? layers : "(Null)", mode, fd,
1664 imode, perm, (void*)f, narg, (void*)args);
1666 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1669 SETERRNO(EINVAL, LIB_INVARG);
1673 if (n + 1 < layera->cur) {
1675 * More layers above the one that we used to open -
1678 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1679 /* If pushing layers fails close the file */
1686 PerlIO_list_free(aTHX_ layera);
1693 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1695 PERL_ARGS_ASSERT_PERLIO_READ;
1697 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1701 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1703 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1705 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1709 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1711 PERL_ARGS_ASSERT_PERLIO_WRITE;
1713 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1717 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1719 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1723 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1725 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1729 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1734 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1736 if (tab && tab->Flush)
1737 return (*tab->Flush) (aTHX_ f);
1739 return 0; /* If no Flush defined, silently succeed. */
1742 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1743 SETERRNO(EBADF, SS_IVCHAN);
1749 * Is it good API design to do flush-all on NULL, a potentially
1750 * erroneous input? Maybe some magical value (PerlIO*
1751 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1752 * things on fflush(NULL), but should we be bound by their design
1755 PerlIOl **table = &PL_perlio;
1758 while ((ff = *table)) {
1760 table = (PerlIOl **) (ff++);
1761 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1762 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1772 PerlIOBase_flush_linebuf(pTHX)
1775 PerlIOl **table = &PL_perlio;
1777 while ((f = *table)) {
1779 table = (PerlIOl **) (f++);
1780 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1782 && (PerlIOBase(&(f->next))->
1783 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1784 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1785 PerlIO_flush(&(f->next));
1792 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1794 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1798 PerlIO_isutf8(PerlIO *f)
1801 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1803 SETERRNO(EBADF, SS_IVCHAN);
1809 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1811 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1815 Perl_PerlIO_error(pTHX_ PerlIO *f)
1817 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1821 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1823 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1827 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1829 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1833 PerlIO_has_base(PerlIO *f)
1835 if (PerlIOValid(f)) {
1836 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1839 return (tab->Get_base != NULL);
1846 PerlIO_fast_gets(PerlIO *f)
1848 if (PerlIOValid(f)) {
1849 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1850 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1853 return (tab->Set_ptrcnt != NULL);
1861 PerlIO_has_cntptr(PerlIO *f)
1863 if (PerlIOValid(f)) {
1864 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1867 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1874 PerlIO_canset_cnt(PerlIO *f)
1876 if (PerlIOValid(f)) {
1877 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1880 return (tab->Set_ptrcnt != NULL);
1887 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1889 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1893 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1895 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1899 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1901 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1905 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1907 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1911 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1913 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1917 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1919 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1923 /*--------------------------------------------------------------------------------------*/
1925 * utf8 and raw dummy layers
1929 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1931 PERL_UNUSED_CONTEXT;
1932 PERL_UNUSED_ARG(mode);
1933 PERL_UNUSED_ARG(arg);
1934 if (PerlIOValid(f)) {
1935 if (tab && tab->kind & PERLIO_K_UTF8)
1936 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1938 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1944 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1945 sizeof(PerlIO_funcs),
1948 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1968 NULL, /* get_base */
1969 NULL, /* get_bufsiz */
1972 NULL, /* set_ptrcnt */
1975 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1976 sizeof(PerlIO_funcs),
1999 NULL, /* get_base */
2000 NULL, /* get_bufsiz */
2003 NULL, /* set_ptrcnt */
2007 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2008 IV n, const char *mode, int fd, int imode, int perm,
2009 PerlIO *old, int narg, SV **args)
2011 PerlIO_funcs * const tab = PerlIO_default_btm();
2012 PERL_UNUSED_ARG(self);
2013 if (tab && tab->Open)
2014 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2016 SETERRNO(EINVAL, LIB_INVARG);
2020 PERLIO_FUNCS_DECL(PerlIO_raw) = {
2021 sizeof(PerlIO_funcs),
2044 NULL, /* get_base */
2045 NULL, /* get_bufsiz */
2048 NULL, /* set_ptrcnt */
2050 /*--------------------------------------------------------------------------------------*/
2051 /*--------------------------------------------------------------------------------------*/
2053 * "Methods" of the "base class"
2057 PerlIOBase_fileno(pTHX_ PerlIO *f)
2059 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2063 PerlIO_modestr(PerlIO * f, char *buf)
2066 if (PerlIOValid(f)) {
2067 const IV flags = PerlIOBase(f)->flags;
2068 if (flags & PERLIO_F_APPEND) {
2070 if (flags & PERLIO_F_CANREAD) {
2074 else if (flags & PERLIO_F_CANREAD) {
2076 if (flags & PERLIO_F_CANWRITE)
2079 else if (flags & PERLIO_F_CANWRITE) {
2081 if (flags & PERLIO_F_CANREAD) {
2085 #ifdef PERLIO_USING_CRLF
2086 if (!(flags & PERLIO_F_CRLF))
2096 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2098 PerlIOl * const l = PerlIOBase(f);
2099 PERL_UNUSED_CONTEXT;
2100 PERL_UNUSED_ARG(arg);
2102 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2103 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2104 if (tab && tab->Set_ptrcnt != NULL)
2105 l->flags |= PERLIO_F_FASTGETS;
2107 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2111 l->flags |= PERLIO_F_CANREAD;
2114 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2117 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2120 SETERRNO(EINVAL, LIB_INVARG);
2126 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2129 l->flags &= ~PERLIO_F_CRLF;
2132 l->flags |= PERLIO_F_CRLF;
2135 SETERRNO(EINVAL, LIB_INVARG);
2142 l->flags |= l->next->flags &
2143 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2148 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2149 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2150 l->flags, PerlIO_modestr(f, temp));
2156 PerlIOBase_popped(pTHX_ PerlIO *f)
2158 PERL_UNUSED_CONTEXT;
2164 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2167 * Save the position as current head considers it
2169 const Off_t old = PerlIO_tell(f);
2170 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2171 PerlIOSelf(f, PerlIOBuf)->posn = old;
2172 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2176 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2178 STDCHAR *buf = (STDCHAR *) vbuf;
2180 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2181 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2182 SETERRNO(EBADF, SS_IVCHAN);
2188 SSize_t avail = PerlIO_get_cnt(f);
2191 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2193 STDCHAR *ptr = PerlIO_get_ptr(f);
2194 Copy(ptr, buf, take, STDCHAR);
2195 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2198 if (avail == 0) /* set_ptrcnt could have reset avail */
2201 if (count > 0 && avail <= 0) {
2202 if (PerlIO_fill(f) != 0)
2207 return (buf - (STDCHAR *) vbuf);
2213 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2215 PERL_UNUSED_CONTEXT;
2221 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2223 PERL_UNUSED_CONTEXT;
2229 PerlIOBase_close(pTHX_ PerlIO *f)
2232 if (PerlIOValid(f)) {
2233 PerlIO *n = PerlIONext(f);
2234 code = PerlIO_flush(f);
2235 PerlIOBase(f)->flags &=
2236 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2237 while (PerlIOValid(n)) {
2238 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2239 if (tab && tab->Close) {
2240 if ((*tab->Close)(aTHX_ n) != 0)
2245 PerlIOBase(n)->flags &=
2246 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2252 SETERRNO(EBADF, SS_IVCHAN);
2258 PerlIOBase_eof(pTHX_ PerlIO *f)
2260 PERL_UNUSED_CONTEXT;
2261 if (PerlIOValid(f)) {
2262 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2268 PerlIOBase_error(pTHX_ PerlIO *f)
2270 PERL_UNUSED_CONTEXT;
2271 if (PerlIOValid(f)) {
2272 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2278 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2280 if (PerlIOValid(f)) {
2281 PerlIO * const n = PerlIONext(f);
2282 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2289 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2291 PERL_UNUSED_CONTEXT;
2292 if (PerlIOValid(f)) {
2293 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2298 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2304 arg = sv_dup(arg, param);
2305 SvREFCNT_inc_simple_void_NN(arg);
2309 return newSVsv(arg);
2312 PERL_UNUSED_ARG(param);
2313 return newSVsv(arg);
2318 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2320 PerlIO * const nexto = PerlIONext(o);
2321 if (PerlIOValid(nexto)) {
2322 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2323 if (tab && tab->Dup)
2324 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2326 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2329 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2332 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2333 self ? self->name : "(Null)",
2334 (void*)f, (void*)o, (void*)param);
2335 if (self && self->Getarg)
2336 arg = (*self->Getarg)(aTHX_ o, param, flags);
2337 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2338 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2339 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2345 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2347 /* Must be called with PL_perlio_mutex locked. */
2349 S_more_refcounted_fds(pTHX_ const int new_fd) {
2351 const int old_max = PL_perlio_fd_refcnt_size;
2352 const int new_max = 16 + (new_fd & ~15);
2355 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2356 old_max, new_fd, new_max);
2358 if (new_fd < old_max) {
2362 assert (new_max > new_fd);
2364 /* Use plain realloc() since we need this memory to be really
2365 * global and visible to all the interpreters and/or threads. */
2366 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2370 MUTEX_UNLOCK(&PL_perlio_mutex);
2372 /* Can't use PerlIO to write as it allocates memory */
2373 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2374 PL_no_mem, strlen(PL_no_mem));
2378 PL_perlio_fd_refcnt_size = new_max;
2379 PL_perlio_fd_refcnt = new_array;
2381 PerlIO_debug("Zeroing %p, %d\n",
2382 (void*)(new_array + old_max),
2385 Zero(new_array + old_max, new_max - old_max, int);
2392 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2393 PERL_UNUSED_CONTEXT;
2397 PerlIOUnix_refcnt_inc(int fd)
2404 MUTEX_LOCK(&PL_perlio_mutex);
2406 if (fd >= PL_perlio_fd_refcnt_size)
2407 S_more_refcounted_fds(aTHX_ fd);
2409 PL_perlio_fd_refcnt[fd]++;
2410 if (PL_perlio_fd_refcnt[fd] <= 0) {
2411 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2412 fd, PL_perlio_fd_refcnt[fd]);
2414 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2415 fd, PL_perlio_fd_refcnt[fd]);
2418 MUTEX_UNLOCK(&PL_perlio_mutex);
2421 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2426 PerlIOUnix_refcnt_dec(int fd)
2433 MUTEX_LOCK(&PL_perlio_mutex);
2435 if (fd >= PL_perlio_fd_refcnt_size) {
2436 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2437 fd, PL_perlio_fd_refcnt_size);
2439 if (PL_perlio_fd_refcnt[fd] <= 0) {
2440 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2441 fd, PL_perlio_fd_refcnt[fd]);
2443 cnt = --PL_perlio_fd_refcnt[fd];
2444 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2446 MUTEX_UNLOCK(&PL_perlio_mutex);
2449 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2455 PerlIO_cleanup(pTHX)
2460 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2462 PerlIO_debug("Cleanup layers\n");
2465 /* Raise STDIN..STDERR refcount so we don't close them */
2466 for (i=0; i < 3; i++)
2467 PerlIOUnix_refcnt_inc(i);
2468 PerlIO_cleantable(aTHX_ &PL_perlio);
2469 /* Restore STDIN..STDERR refcount */
2470 for (i=0; i < 3; i++)
2471 PerlIOUnix_refcnt_dec(i);
2473 if (PL_known_layers) {
2474 PerlIO_list_free(aTHX_ PL_known_layers);
2475 PL_known_layers = NULL;
2477 if (PL_def_layerlist) {
2478 PerlIO_list_free(aTHX_ PL_def_layerlist);
2479 PL_def_layerlist = NULL;
2483 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2487 /* XXX we can't rely on an interpreter being present at this late stage,
2488 XXX so we can't use a function like PerlLIO_write that relies on one
2489 being present (at least in win32) :-(.
2494 /* By now all filehandles should have been closed, so any
2495 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2497 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2498 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2499 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2501 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2502 if (PL_perlio_fd_refcnt[i]) {
2504 my_snprintf(buf, sizeof(buf),
2505 "PerlIO_teardown: fd %d refcnt=%d\n",
2506 i, PL_perlio_fd_refcnt[i]);
2507 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2513 /* Not bothering with PL_perlio_mutex since by now
2514 * all the interpreters are gone. */
2515 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2516 && PL_perlio_fd_refcnt) {
2517 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2518 PL_perlio_fd_refcnt = NULL;
2519 PL_perlio_fd_refcnt_size = 0;
2523 /*--------------------------------------------------------------------------------------*/
2525 * Bottom-most level for UNIX-like case
2529 struct _PerlIO base; /* The generic part */
2530 int fd; /* UNIX like file descriptor */
2531 int oflags; /* open/fcntl flags */
2535 S_lockcnt_dec(pTHX_ const void* f)
2537 PerlIO_lockcnt((PerlIO*)f)--;
2541 /* call the signal handler, and if that handler happens to clear
2542 * this handle, free what we can and return true */
2545 S_perlio_async_run(pTHX_ PerlIO* f) {
2547 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2548 PerlIO_lockcnt(f)++;
2550 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
2552 /* we've just run some perl-level code that could have done
2553 * anything, including closing the file or clearing this layer.
2554 * If so, free any lower layers that have already been
2555 * cleared, then return an error. */
2556 while (PerlIOValid(f) &&
2557 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2559 const PerlIOl *l = *f;
2567 PerlIOUnix_oflags(const char *mode)
2570 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2575 if (*++mode == '+') {
2582 oflags = O_CREAT | O_TRUNC;
2583 if (*++mode == '+') {
2592 oflags = O_CREAT | O_APPEND;
2593 if (*++mode == '+') {
2606 else if (*mode == 't') {
2608 oflags &= ~O_BINARY;
2612 * Always open in binary mode
2615 if (*mode || oflags == -1) {
2616 SETERRNO(EINVAL, LIB_INVARG);
2623 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2625 PERL_UNUSED_CONTEXT;
2626 return PerlIOSelf(f, PerlIOUnix)->fd;
2630 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2632 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2635 if (PerlLIO_fstat(fd, &st) == 0) {
2636 if (!S_ISREG(st.st_mode)) {
2637 PerlIO_debug("%d is not regular file\n",fd);
2638 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2641 PerlIO_debug("%d _is_ a regular file\n",fd);
2647 PerlIOUnix_refcnt_inc(fd);
2648 PERL_UNUSED_CONTEXT;
2652 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2654 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2655 if (*PerlIONext(f)) {
2656 /* We never call down so do any pending stuff now */
2657 PerlIO_flush(PerlIONext(f));
2659 * XXX could (or should) we retrieve the oflags from the open file
2660 * handle rather than believing the "mode" we are passed in? XXX
2661 * Should the value on NULL mode be 0 or -1?
2663 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2664 mode ? PerlIOUnix_oflags(mode) : -1);
2666 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2672 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2674 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2676 PERL_UNUSED_CONTEXT;
2677 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2679 SETERRNO(ESPIPE, LIB_INVARG);
2681 SETERRNO(EINVAL, LIB_INVARG);
2685 new_loc = PerlLIO_lseek(fd, offset, whence);
2686 if (new_loc == (Off_t) - 1)
2688 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2693 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2694 IV n, const char *mode, int fd, int imode,
2695 int perm, PerlIO *f, int narg, SV **args)
2697 if (PerlIOValid(f)) {
2698 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2699 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2702 if (*mode == IoTYPE_NUMERIC)
2705 imode = PerlIOUnix_oflags(mode);
2707 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2713 const char *path = SvPV_nolen_const(*args);
2714 fd = PerlLIO_open3(path, imode, perm);
2718 if (*mode == IoTYPE_IMPLICIT)
2721 f = PerlIO_allocate(aTHX);
2723 if (!PerlIOValid(f)) {
2724 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2728 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2729 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2730 if (*mode == IoTYPE_APPEND)
2731 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2738 * FIXME: pop layers ???
2746 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2748 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2750 if (flags & PERLIO_DUP_FD) {
2751 fd = PerlLIO_dup(fd);
2754 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2756 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2757 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2766 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2770 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2772 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2773 #ifdef PERLIO_STD_SPECIAL
2775 return PERLIO_STD_IN(fd, vbuf, count);
2777 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2778 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2782 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2783 if (len >= 0 || errno != EINTR) {
2785 if (errno != EAGAIN) {
2786 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2789 else if (len == 0 && count != 0) {
2790 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2796 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2803 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2807 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2809 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2810 #ifdef PERLIO_STD_SPECIAL
2811 if (fd == 1 || fd == 2)
2812 return PERLIO_STD_OUT(fd, vbuf, count);
2815 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2816 if (len >= 0 || errno != EINTR) {
2818 if (errno != EAGAIN) {
2819 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2825 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2832 PerlIOUnix_tell(pTHX_ PerlIO *f)
2834 PERL_UNUSED_CONTEXT;
2836 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2841 PerlIOUnix_close(pTHX_ PerlIO *f)
2844 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2846 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2847 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2848 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2853 SETERRNO(EBADF,SS_IVCHAN);
2856 while (PerlLIO_close(fd) != 0) {
2857 if (errno != EINTR) {
2862 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2866 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2871 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2872 sizeof(PerlIO_funcs),
2879 PerlIOBase_binmode, /* binmode */
2889 PerlIOBase_noop_ok, /* flush */
2890 PerlIOBase_noop_fail, /* fill */
2893 PerlIOBase_clearerr,
2894 PerlIOBase_setlinebuf,
2895 NULL, /* get_base */
2896 NULL, /* get_bufsiz */
2899 NULL, /* set_ptrcnt */
2902 /*--------------------------------------------------------------------------------------*/
2907 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2908 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2909 broken by the last second glibc 2.3 fix
2911 #define STDIO_BUFFER_WRITABLE
2916 struct _PerlIO base;
2917 FILE *stdio; /* The stream */
2921 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2923 PERL_UNUSED_CONTEXT;
2925 if (PerlIOValid(f)) {
2926 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2928 return PerlSIO_fileno(s);
2935 PerlIOStdio_mode(const char *mode, char *tmode)
2937 char * const ret = tmode;
2943 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2951 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2954 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2955 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2956 if (toptab == tab) {
2957 /* Top is already stdio - pop self (duplicate) and use original */
2958 PerlIO_pop(aTHX_ f);
2961 const int fd = PerlIO_fileno(n);
2964 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2965 mode = PerlIOStdio_mode(mode, tmode)))) {
2966 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2967 /* We never call down so do any pending stuff now */
2968 PerlIO_flush(PerlIONext(f));
2975 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2980 PerlIO_importFILE(FILE *stdio, const char *mode)
2986 if (!mode || !*mode) {
2987 /* We need to probe to see how we can open the stream
2988 so start with read/write and then try write and read
2989 we dup() so that we can fclose without loosing the fd.
2991 Note that the errno value set by a failing fdopen
2992 varies between stdio implementations.
2994 const int fd = PerlLIO_dup(fileno(stdio));
2995 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2997 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3000 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3003 /* Don't seem to be able to open */
3009 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3010 s = PerlIOSelf(f, PerlIOStdio);
3012 PerlIOUnix_refcnt_inc(fileno(stdio));
3019 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3020 IV n, const char *mode, int fd, int imode,
3021 int perm, PerlIO *f, int narg, SV **args)
3024 if (PerlIOValid(f)) {
3025 const char * const path = SvPV_nolen_const(*args);
3026 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3028 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3029 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3034 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3039 const char * const path = SvPV_nolen_const(*args);
3040 if (*mode == IoTYPE_NUMERIC) {
3042 fd = PerlLIO_open3(path, imode, perm);
3046 bool appended = FALSE;
3048 /* Cygwin wants its 'b' early. */
3050 mode = PerlIOStdio_mode(mode, tmode);
3052 stdio = PerlSIO_fopen(path, mode);
3055 f = PerlIO_allocate(aTHX);
3058 mode = PerlIOStdio_mode(mode, tmode);
3059 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3061 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3062 PerlIOUnix_refcnt_inc(fileno(stdio));
3064 PerlSIO_fclose(stdio);
3076 if (*mode == IoTYPE_IMPLICIT) {
3083 stdio = PerlSIO_stdin;
3086 stdio = PerlSIO_stdout;
3089 stdio = PerlSIO_stderr;
3094 stdio = PerlSIO_fdopen(fd, mode =
3095 PerlIOStdio_mode(mode, tmode));
3099 f = PerlIO_allocate(aTHX);
3101 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3102 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3103 PerlIOUnix_refcnt_inc(fileno(stdio));
3113 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3115 /* This assumes no layers underneath - which is what
3116 happens, but is not how I remember it. NI-S 2001/10/16
3118 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3119 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3120 const int fd = fileno(stdio);
3122 if (flags & PERLIO_DUP_FD) {
3123 const int dfd = PerlLIO_dup(fileno(stdio));
3125 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3130 /* FIXME: To avoid messy error recovery if dup fails
3131 re-use the existing stdio as though flag was not set
3135 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3137 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3139 PerlIOUnix_refcnt_inc(fileno(stdio));
3146 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3148 PERL_UNUSED_CONTEXT;
3150 /* XXX this could use PerlIO_canset_fileno() and
3151 * PerlIO_set_fileno() support from Configure
3153 # if defined(__UCLIBC__)
3154 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3157 # elif defined(__GLIBC__)
3158 /* There may be a better way for GLIBC:
3159 - libio.h defines a flag to not close() on cleanup
3163 # elif defined(__sun__)
3166 # elif defined(__hpux)
3170 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3171 your platform does not have special entry try this one.
3172 [For OSF only have confirmation for Tru64 (alpha)
3173 but assume other OSFs will be similar.]
3175 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3178 # elif defined(__FreeBSD__)
3179 /* There may be a better way on FreeBSD:
3180 - we could insert a dummy func in the _close function entry
3181 f->_close = (int (*)(void *)) dummy_close;
3185 # elif defined(__OpenBSD__)
3186 /* There may be a better way on OpenBSD:
3187 - we could insert a dummy func in the _close function entry
3188 f->_close = (int (*)(void *)) dummy_close;
3192 # elif defined(__EMX__)
3193 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3196 # elif defined(__CYGWIN__)
3197 /* There may be a better way on CYGWIN:
3198 - we could insert a dummy func in the _close function entry
3199 f->_close = (int (*)(void *)) dummy_close;
3203 # elif defined(WIN32)
3204 # if defined(__BORLANDC__)
3205 f->fd = PerlLIO_dup(fileno(f));
3206 # elif defined(UNDER_CE)
3207 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3216 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3217 (which isn't thread safe) instead
3219 # error "Don't know how to set FILE.fileno on your platform"
3227 PerlIOStdio_close(pTHX_ PerlIO *f)
3229 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3235 const int fd = fileno(stdio);
3243 #ifdef SOCKS5_VERSION_NAME
3244 /* Socks lib overrides close() but stdio isn't linked to
3245 that library (though we are) - so we must call close()
3246 on sockets on stdio's behalf.
3249 Sock_size_t optlen = sizeof(int);
3250 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3253 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3254 that a subsequent fileno() on it returns -1. Don't want to croak()
3255 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3256 trying to close an already closed handle which somehow it still has
3257 a reference to. (via.xs, I'm looking at you). */
3258 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3259 /* File descriptor still in use */
3263 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3264 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3266 if (stdio == stdout || stdio == stderr)
3267 return PerlIO_flush(f);
3268 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3269 Use Sarathy's trick from maint-5.6 to invalidate the
3270 fileno slot of the FILE *
3272 result = PerlIO_flush(f);
3274 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3277 MUTEX_LOCK(&PL_perlio_mutex);
3278 /* Right. We need a mutex here because for a brief while we
3279 will have the situation that fd is actually closed. Hence if
3280 a second thread were to get into this block, its dup() would
3281 likely return our fd as its dupfd. (after all, it is closed)
3282 Then if we get to the dup2() first, we blat the fd back
3283 (messing up its temporary as a side effect) only for it to
3284 then close its dupfd (== our fd) in its close(dupfd) */
3286 /* There is, of course, a race condition, that any other thread
3287 trying to input/output/whatever on this fd will be stuffed
3288 for the duration of this little manoeuvrer. Perhaps we
3289 should hold an IO mutex for the duration of every IO
3290 operation if we know that invalidate doesn't work on this
3291 platform, but that would suck, and could kill performance.
3293 Except that correctness trumps speed.
3294 Advice from klortho #11912. */
3296 dupfd = PerlLIO_dup(fd);
3299 MUTEX_UNLOCK(&PL_perlio_mutex);
3300 /* Oh cXap. This isn't going to go well. Not sure if we can
3301 recover from here, or if closing this particular FILE *
3302 is a good idea now. */
3307 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3309 result = PerlSIO_fclose(stdio);
3310 /* We treat error from stdio as success if we invalidated
3311 errno may NOT be expected EBADF
3313 if (invalidate && result != 0) {
3317 #ifdef SOCKS5_VERSION_NAME
3318 /* in SOCKS' case, let close() determine return value */
3322 PerlLIO_dup2(dupfd,fd);
3323 PerlLIO_close(dupfd);
3325 MUTEX_UNLOCK(&PL_perlio_mutex);
3333 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3338 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3340 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3343 STDCHAR *buf = (STDCHAR *) vbuf;
3345 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3346 * stdio does not do that for fread()
3348 const int ch = PerlSIO_fgetc(s);
3355 got = PerlSIO_fread(vbuf, 1, count, s);
3356 if (got == 0 && PerlSIO_ferror(s))
3358 if (got >= 0 || errno != EINTR)
3360 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3362 SETERRNO(0,0); /* just in case */
3368 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3371 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3373 #ifdef STDIO_BUFFER_WRITABLE
3374 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3375 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3376 STDCHAR *base = PerlIO_get_base(f);
3377 SSize_t cnt = PerlIO_get_cnt(f);
3378 STDCHAR *ptr = PerlIO_get_ptr(f);
3379 SSize_t avail = ptr - base;
3381 if (avail > count) {
3385 Move(buf-avail,ptr,avail,STDCHAR);
3388 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3389 if (PerlSIO_feof(s) && unread >= 0)
3390 PerlSIO_clearerr(s);
3395 if (PerlIO_has_cntptr(f)) {
3396 /* We can get pointer to buffer but not its base
3397 Do ungetc() but check chars are ending up in the
3400 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3401 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3403 const int ch = *--buf & 0xFF;
3404 if (ungetc(ch,s) != ch) {
3405 /* ungetc did not work */
3408 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3409 /* Did not change pointer as expected */
3410 fgetc(s); /* get char back again */
3420 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3426 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3430 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3433 got = PerlSIO_fwrite(vbuf, 1, count,
3434 PerlIOSelf(f, PerlIOStdio)->stdio);
3435 if (got >= 0 || errno != EINTR)
3437 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3439 SETERRNO(0,0); /* just in case */
3445 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3447 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3448 PERL_UNUSED_CONTEXT;
3450 return PerlSIO_fseek(stdio, offset, whence);
3454 PerlIOStdio_tell(pTHX_ PerlIO *f)
3456 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3457 PERL_UNUSED_CONTEXT;
3459 return PerlSIO_ftell(stdio);
3463 PerlIOStdio_flush(pTHX_ PerlIO *f)
3465 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3466 PERL_UNUSED_CONTEXT;
3468 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3469 return PerlSIO_fflush(stdio);
3475 * FIXME: This discards ungetc() and pre-read stuff which is not
3476 * right if this is just a "sync" from a layer above Suspect right
3477 * design is to do _this_ but not have layer above flush this
3478 * layer read-to-read
3481 * Not writeable - sync by attempting a seek
3484 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3492 PerlIOStdio_eof(pTHX_ PerlIO *f)
3494 PERL_UNUSED_CONTEXT;
3496 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3500 PerlIOStdio_error(pTHX_ PerlIO *f)
3502 PERL_UNUSED_CONTEXT;
3504 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3508 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3510 PERL_UNUSED_CONTEXT;
3512 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3516 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3518 PERL_UNUSED_CONTEXT;
3520 #ifdef HAS_SETLINEBUF
3521 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3523 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3529 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3531 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3532 return (STDCHAR*)PerlSIO_get_base(stdio);
3536 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3538 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3539 return PerlSIO_get_bufsiz(stdio);
3543 #ifdef USE_STDIO_PTR
3545 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3547 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3548 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3552 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3554 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3555 return PerlSIO_get_cnt(stdio);
3559 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3561 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3563 #ifdef STDIO_PTR_LVALUE
3564 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3565 #ifdef STDIO_PTR_LVAL_SETS_CNT
3566 assert(PerlSIO_get_cnt(stdio) == (cnt));
3568 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3570 * Setting ptr _does_ change cnt - we are done
3574 #else /* STDIO_PTR_LVALUE */
3576 #endif /* STDIO_PTR_LVALUE */
3579 * Now (or only) set cnt
3581 #ifdef STDIO_CNT_LVALUE
3582 PerlSIO_set_cnt(stdio, cnt);
3583 #else /* STDIO_CNT_LVALUE */
3584 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3585 PerlSIO_set_ptr(stdio,
3586 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3588 #else /* STDIO_PTR_LVAL_SETS_CNT */
3590 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3591 #endif /* STDIO_CNT_LVALUE */
3598 PerlIOStdio_fill(pTHX_ PerlIO *f)
3602 PERL_UNUSED_CONTEXT;
3603 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3605 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3608 * fflush()ing read-only streams can cause trouble on some stdio-s
3610 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3611 if (PerlSIO_fflush(stdio) != 0)
3615 c = PerlSIO_fgetc(stdio);
3618 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3620 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3625 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3627 #ifdef STDIO_BUFFER_WRITABLE
3628 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3629 /* Fake ungetc() to the real buffer in case system's ungetc
3632 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3633 SSize_t cnt = PerlSIO_get_cnt(stdio);
3634 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3635 if (ptr == base+1) {
3636 *--ptr = (STDCHAR) c;
3637 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3638 if (PerlSIO_feof(stdio))
3639 PerlSIO_clearerr(stdio);
3645 if (PerlIO_has_cntptr(f)) {
3647 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3654 /* An ungetc()d char is handled separately from the regular
3655 * buffer, so we stuff it in the buffer ourselves.
3656 * Should never get called as should hit code above
3658 *(--((*stdio)->_ptr)) = (unsigned char) c;
3661 /* If buffer snoop scheme above fails fall back to
3664 if (PerlSIO_ungetc(c, stdio) != c)
3672 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3673 sizeof(PerlIO_funcs),
3675 sizeof(PerlIOStdio),
3676 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3680 PerlIOBase_binmode, /* binmode */
3694 PerlIOStdio_clearerr,
3695 PerlIOStdio_setlinebuf,
3697 PerlIOStdio_get_base,
3698 PerlIOStdio_get_bufsiz,
3703 #ifdef USE_STDIO_PTR
3704 PerlIOStdio_get_ptr,
3705 PerlIOStdio_get_cnt,
3706 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3707 PerlIOStdio_set_ptrcnt,
3710 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3715 #endif /* USE_STDIO_PTR */
3718 /* Note that calls to PerlIO_exportFILE() are reversed using
3719 * PerlIO_releaseFILE(), not importFILE. */
3721 PerlIO_exportFILE(PerlIO * f, const char *mode)
3725 if (PerlIOValid(f)) {
3728 if (!mode || !*mode) {
3729 mode = PerlIO_modestr(f, buf);
3731 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3735 /* De-link any lower layers so new :stdio sticks */
3737 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3738 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3740 PerlIOUnix_refcnt_inc(fileno(stdio));
3741 /* Link previous lower layers under new one */
3745 /* restore layers list */
3755 PerlIO_findFILE(PerlIO *f)
3760 if (l->tab == &PerlIO_stdio) {
3761 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3764 l = *PerlIONext(&l);
3766 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3767 /* However, we're not really exporting a FILE * to someone else (who
3768 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3769 So we need to undo its reference count increase on the underlying file
3770 descriptor. We have to do this, because if the loop above returns you
3771 the FILE *, then *it* didn't increase any reference count. So there's
3772 only one way to be consistent. */
3773 stdio = PerlIO_exportFILE(f, NULL);
3775 const int fd = fileno(stdio);
3777 PerlIOUnix_refcnt_dec(fd);
3782 /* Use this to reverse PerlIO_exportFILE calls. */
3784 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3789 if (l->tab == &PerlIO_stdio) {
3790 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3791 if (s->stdio == f) {
3793 const int fd = fileno(f);
3795 PerlIOUnix_refcnt_dec(fd);
3796 PerlIO_pop(aTHX_ p);
3805 /*--------------------------------------------------------------------------------------*/
3807 * perlio buffer layer
3811 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3813 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3814 const int fd = PerlIO_fileno(f);
3815 if (fd >= 0 && PerlLIO_isatty(fd)) {
3816 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3818 if (*PerlIONext(f)) {
3819 const Off_t posn = PerlIO_tell(PerlIONext(f));
3820 if (posn != (Off_t) - 1) {
3824 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3828 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3829 IV n, const char *mode, int fd, int imode, int perm,
3830 PerlIO *f, int narg, SV **args)
3832 if (PerlIOValid(f)) {
3833 PerlIO *next = PerlIONext(f);
3835 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3836 if (tab && tab->Open)
3838 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3840 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3845 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3847 if (*mode == IoTYPE_IMPLICIT) {
3853 if (tab && tab->Open)
3854 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3857 SETERRNO(EINVAL, LIB_INVARG);
3859 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3861 * if push fails during open, open fails. close will pop us.
3866 fd = PerlIO_fileno(f);
3867 if (init && fd == 2) {
3869 * Initial stderr is unbuffered
3871 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3873 #ifdef PERLIO_USING_CRLF
3874 # ifdef PERLIO_IS_BINMODE_FD
3875 if (PERLIO_IS_BINMODE_FD(fd))
3876 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3880 * do something about failing setmode()? --jhi
3882 PerlLIO_setmode(fd, O_BINARY);
3886 /* Enable line buffering with record-oriented regular files
3887 * so we don't introduce an extraneous record boundary when
3888 * the buffer fills up.
3890 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3892 if (PerlLIO_fstat(fd, &st) == 0
3893 && S_ISREG(st.st_mode)
3894 && (st.st_fab_rfm == FAB$C_VAR
3895 || st.st_fab_rfm == FAB$C_VFC)) {
3896 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3907 * This "flush" is akin to sfio's sync in that it handles files in either
3908 * read or write state. For write state, we put the postponed data through
3909 * the next layers. For read state, we seek() the next layers to the
3910 * offset given by current position in the buffer, and discard the buffer
3911 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3912 * in any case?). Then the pass the stick further in chain.
3915 PerlIOBuf_flush(pTHX_ PerlIO *f)
3917 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3919 PerlIO *n = PerlIONext(f);
3920 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3922 * write() the buffer
3924 const STDCHAR *buf = b->buf;
3925 const STDCHAR *p = buf;
3926 while (p < b->ptr) {
3927 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3931 else if (count < 0 || PerlIO_error(n)) {
3932 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3937 b->posn += (p - buf);
3939 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3940 STDCHAR *buf = PerlIO_get_base(f);
3942 * Note position change
3944 b->posn += (b->ptr - buf);
3945 if (b->ptr < b->end) {
3946 /* We did not consume all of it - try and seek downstream to
3947 our logical position
3949 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3950 /* Reload n as some layers may pop themselves on seek */
3951 b->posn = PerlIO_tell(n = PerlIONext(f));
3954 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3955 data is lost for good - so return saying "ok" having undone
3958 b->posn -= (b->ptr - buf);
3963 b->ptr = b->end = b->buf;
3964 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3965 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3966 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3971 /* This discards the content of the buffer after b->ptr, and rereads
3972 * the buffer from the position off in the layer downstream; here off
3973 * is at offset corresponding to b->ptr - b->buf.
3976 PerlIOBuf_fill(pTHX_ PerlIO *f)
3978 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3979 PerlIO *n = PerlIONext(f);
3982 * Down-stream flush is defined not to loose read data so is harmless.
3983 * we would not normally be fill'ing if there was data left in anycase.
3985 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3987 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3988 PerlIOBase_flush_linebuf(aTHX);
3991 PerlIO_get_base(f); /* allocate via vtable */
3993 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3995 b->ptr = b->end = b->buf;
3997 if (!PerlIOValid(n)) {
3998 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4002 if (PerlIO_fast_gets(n)) {
4004 * Layer below is also buffered. We do _NOT_ want to call its
4005 * ->Read() because that will loop till it gets what we asked for
4006 * which may hang on a pipe etc. Instead take anything it has to
4007 * hand, or ask it to fill _once_.
4009 avail = PerlIO_get_cnt(n);
4011 avail = PerlIO_fill(n);
4013 avail = PerlIO_get_cnt(n);
4015 if (!PerlIO_error(n) && PerlIO_eof(n))
4020 STDCHAR *ptr = PerlIO_get_ptr(n);
4021 const SSize_t cnt = avail;
4022 if (avail > (SSize_t)b->bufsiz)
4024 Copy(ptr, b->buf, avail, STDCHAR);
4025 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4029 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4033 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4035 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4038 b->end = b->buf + avail;
4039 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4044 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4046 if (PerlIOValid(f)) {
4047 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4050 return PerlIOBase_read(aTHX_ f, vbuf, count);
4056 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4058 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4059 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4062 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4067 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4069 * Buffer is already a read buffer, we can overwrite any chars
4070 * which have been read back to buffer start
4072 avail = (b->ptr - b->buf);
4076 * Buffer is idle, set it up so whole buffer is available for
4080 b->end = b->buf + avail;
4082 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4084 * Buffer extends _back_ from where we are now
4086 b->posn -= b->bufsiz;
4088 if (avail > (SSize_t) count) {
4090 * If we have space for more than count, just move count
4098 * In simple stdio-like ungetc() case chars will be already
4101 if (buf != b->ptr) {
4102 Copy(buf, b->ptr, avail, STDCHAR);
4106 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4110 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4116 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4118 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4119 const STDCHAR *buf = (const STDCHAR *) vbuf;
4120 const STDCHAR *flushptr = buf;
4124 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4126 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4127 if (PerlIO_flush(f) != 0) {
4131 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4132 flushptr = buf + count;
4133 while (flushptr > buf && *(flushptr - 1) != '\n')
4137 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4138 if ((SSize_t) count < avail)
4140 if (flushptr > buf && flushptr <= buf + avail)
4141 avail = flushptr - buf;
4142 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4144 Copy(buf, b->ptr, avail, STDCHAR);
4149 if (buf == flushptr)
4152 if (b->ptr >= (b->buf + b->bufsiz))
4153 if (PerlIO_flush(f) == -1)
4156 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4162 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4165 if ((code = PerlIO_flush(f)) == 0) {
4166 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4167 code = PerlIO_seek(PerlIONext(f), offset, whence);
4169 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4170 b->posn = PerlIO_tell(PerlIONext(f));
4177 PerlIOBuf_tell(pTHX_ PerlIO *f)
4179 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4181 * b->posn is file position where b->buf was read, or will be written
4183 Off_t posn = b->posn;
4184 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4185 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4187 /* As O_APPEND files are normally shared in some sense it is better
4192 /* when file is NOT shared then this is sufficient */
4193 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4195 posn = b->posn = PerlIO_tell(PerlIONext(f));
4199 * If buffer is valid adjust position by amount in buffer
4201 posn += (b->ptr - b->buf);
4207 PerlIOBuf_popped(pTHX_ PerlIO *f)
4209 const IV code = PerlIOBase_popped(aTHX_ f);
4210 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4211 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4214 b->ptr = b->end = b->buf = NULL;
4215 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4220 PerlIOBuf_close(pTHX_ PerlIO *f)
4222 const IV code = PerlIOBase_close(aTHX_ f);
4223 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4224 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4227 b->ptr = b->end = b->buf = NULL;
4228 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4233 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4235 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4242 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4244 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4247 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4248 return (b->end - b->ptr);
4253 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4255 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4256 PERL_UNUSED_CONTEXT;
4260 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4261 Newxz(b->buf,b->bufsiz, STDCHAR);
4263 b->buf = (STDCHAR *) & b->oneword;
4264 b->bufsiz = sizeof(b->oneword);
4266 b->end = b->ptr = b->buf;
4272 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4274 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4277 return (b->end - b->buf);
4281 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4283 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4285 PERL_UNUSED_ARG(cnt);
4290 assert(PerlIO_get_cnt(f) == cnt);
4291 assert(b->ptr >= b->buf);
4292 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4296 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4298 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4303 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4304 sizeof(PerlIO_funcs),
4307 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4311 PerlIOBase_binmode, /* binmode */
4325 PerlIOBase_clearerr,
4326 PerlIOBase_setlinebuf,
4331 PerlIOBuf_set_ptrcnt,
4334 /*--------------------------------------------------------------------------------------*/
4336 * Temp layer to hold unread chars when cannot do it any other way
4340 PerlIOPending_fill(pTHX_ PerlIO *f)
4343 * Should never happen
4350 PerlIOPending_close(pTHX_ PerlIO *f)
4353 * A tad tricky - flush pops us, then we close new top
4356 return PerlIO_close(f);
4360 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4363 * A tad tricky - flush pops us, then we seek new top
4366 return PerlIO_seek(f, offset, whence);
4371 PerlIOPending_flush(pTHX_ PerlIO *f)
4373 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4374 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4378 PerlIO_pop(aTHX_ f);
4383 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4389 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4394 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4396 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4397 PerlIOl * const l = PerlIOBase(f);
4399 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4400 * etc. get muddled when it changes mid-string when we auto-pop.
4402 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4403 (PerlIOBase(PerlIONext(f))->
4404 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4409 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4411 SSize_t avail = PerlIO_get_cnt(f);
4413 if ((SSize_t)count < avail)
4416 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4417 if (got >= 0 && got < (SSize_t)count) {
4418 const SSize_t more =
4419 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4420 if (more >= 0 || got == 0)
4426 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4427 sizeof(PerlIO_funcs),
4430 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4431 PerlIOPending_pushed,
4434 PerlIOBase_binmode, /* binmode */
4443 PerlIOPending_close,
4444 PerlIOPending_flush,
4448 PerlIOBase_clearerr,
4449 PerlIOBase_setlinebuf,
4454 PerlIOPending_set_ptrcnt,
4459 /*--------------------------------------------------------------------------------------*/
4461 * crlf - translation On read translate CR,LF to "\n" we do this by
4462 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4463 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4465 * c->nl points on the first byte of CR LF pair when it is temporarily
4466 * replaced by LF, or to the last CR of the buffer. In the former case
4467 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4468 * that it ends at c->nl; these two cases can be distinguished by
4469 * *c->nl. c->nl is set during _getcnt() call, and unset during
4470 * _unread() and _flush() calls.
4471 * It only matters for read operations.
4475 PerlIOBuf base; /* PerlIOBuf stuff */
4476 STDCHAR *nl; /* Position of crlf we "lied" about in the
4480 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4481 * Otherwise the :crlf layer would always revert back to
4485 S_inherit_utf8_flag(PerlIO *f)
4487 PerlIO *g = PerlIONext(f);
4488 if (PerlIOValid(g)) {
4489 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4490 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4496 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4499 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4500 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4502 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4503 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4504 PerlIOBase(f)->flags);
4507 /* Enable the first CRLF capable layer you can find, but if none
4508 * found, the one we just pushed is fine. This results in at
4509 * any given moment at most one CRLF-capable layer being enabled
4510 * in the whole layer stack. */
4511 PerlIO *g = PerlIONext(f);
4512 while (PerlIOValid(g)) {
4513 PerlIOl *b = PerlIOBase(g);
4514 if (b && b->tab == &PerlIO_crlf) {
4515 if (!(b->flags & PERLIO_F_CRLF))
4516 b->flags |= PERLIO_F_CRLF;
4517 S_inherit_utf8_flag(g);
4518 PerlIO_pop(aTHX_ f);
4524 S_inherit_utf8_flag(f);
4530 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4532 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4533 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4537 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4538 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4540 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4541 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4543 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4548 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4549 b->end = b->ptr = b->buf + b->bufsiz;
4550 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4551 b->posn -= b->bufsiz;
4553 while (count > 0 && b->ptr > b->buf) {
4554 const int ch = *--buf;
4556 if (b->ptr - 2 >= b->buf) {
4563 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4564 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4580 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4582 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4584 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4587 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4588 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4589 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4590 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4592 while (nl < b->end && *nl != 0xd)
4594 if (nl < b->end && *nl == 0xd) {
4596 if (nl + 1 < b->end) {
4603 * Not CR,LF but just CR
4611 * Blast - found CR as last char in buffer
4616 * They may not care, defer work as long as
4620 return (nl - b->ptr);
4624 b->ptr++; /* say we have read it as far as
4625 * flush() is concerned */
4626 b->buf++; /* Leave space in front of buffer */
4627 /* Note as we have moved buf up flush's
4629 will naturally make posn point at CR
4631 b->bufsiz--; /* Buffer is thus smaller */
4632 code = PerlIO_fill(f); /* Fetch some more */
4633 b->bufsiz++; /* Restore size for next time */
4634 b->buf--; /* Point at space */
4635 b->ptr = nl = b->buf; /* Which is what we hand
4637 *nl = 0xd; /* Fill in the CR */
4639 goto test; /* fill() call worked */
4641 * CR at EOF - just fall through
4643 /* Should we clear EOF though ??? */
4648 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4654 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4656 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4657 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4663 if (ptr == b->end && *c->nl == 0xd) {
4664 /* Deferred CR at end of buffer case - we lied about count */
4677 * Test code - delete when it works ...
4679 IV flags = PerlIOBase(f)->flags;
4680 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4681 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4682 /* Deferred CR at end of buffer case - we lied about count */
4688 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4689 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4690 flags, c->nl, b->end, cnt);
4697 * They have taken what we lied about
4705 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4709 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4711 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4712 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4714 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4715 const STDCHAR *buf = (const STDCHAR *) vbuf;
4716 const STDCHAR * const ebuf = buf + count;
4719 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4721 while (buf < ebuf) {
4722 const STDCHAR * const eptr = b->buf + b->bufsiz;
4723 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4724 while (buf < ebuf && b->ptr < eptr) {
4726 if ((b->ptr + 2) > eptr) {
4734 *(b->ptr)++ = 0xd; /* CR */
4735 *(b->ptr)++ = 0xa; /* LF */
4737 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4744 *(b->ptr)++ = *buf++;
4746 if (b->ptr >= eptr) {
4752 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4754 return (buf - (STDCHAR *) vbuf);
4759 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4761 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4766 return PerlIOBuf_flush(aTHX_ f);
4770 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4772 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4773 /* In text mode - flush any pending stuff and flip it */
4774 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4775 #ifndef PERLIO_USING_CRLF
4776 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4777 PerlIO_pop(aTHX_ f);
4783 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4784 sizeof(PerlIO_funcs),
4787 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4789 PerlIOBuf_popped, /* popped */
4791 PerlIOCrlf_binmode, /* binmode */
4795 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4796 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4797 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4805 PerlIOBase_clearerr,
4806 PerlIOBase_setlinebuf,
4811 PerlIOCrlf_set_ptrcnt,
4815 /*--------------------------------------------------------------------------------------*/
4817 * mmap as "buffer" layer
4821 PerlIOBuf base; /* PerlIOBuf stuff */
4822 Mmap_t mptr; /* Mapped address */
4823 Size_t len; /* mapped length */
4824 STDCHAR *bbuf; /* malloced buffer if map fails */
4828 PerlIOMmap_map(pTHX_ PerlIO *f)
4831 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4832 const IV flags = PerlIOBase(f)->flags;
4836 if (flags & PERLIO_F_CANREAD) {
4837 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4838 const int fd = PerlIO_fileno(f);
4840 code = Fstat(fd, &st);
4841 if (code == 0 && S_ISREG(st.st_mode)) {
4842 SSize_t len = st.st_size - b->posn;
4845 if (PL_mmap_page_size <= 0)
4846 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4850 * This is a hack - should never happen - open should
4853 b->posn = PerlIO_tell(PerlIONext(f));
4855 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4856 len = st.st_size - posn;
4857 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4858 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4859 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4860 madvise(m->mptr, len, MADV_SEQUENTIAL);
4862 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4863 madvise(m->mptr, len, MADV_WILLNEED);
4865 PerlIOBase(f)->flags =
4866 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4867 b->end = ((STDCHAR *) m->mptr) + len;
4868 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4877 PerlIOBase(f)->flags =
4878 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4880 b->ptr = b->end = b->ptr;
4889 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4891 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4894 PerlIOBuf * const b = &m->base;
4896 /* The munmap address argument is tricky: depending on the
4897 * standard it is either "void *" or "caddr_t" (which is
4898 * usually "char *" (signed or unsigned). If we cast it
4899 * to "void *", those that have it caddr_t and an uptight
4900 * C++ compiler, will freak out. But casting it as char*
4901 * should work. Maybe. (Using Mmap_t figured out by
4902 * Configure doesn't always work, apparently.) */
4903 code = munmap((char*)m->mptr, m->len);
4907 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4910 b->ptr = b->end = b->buf;
4911 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4917 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4919 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4920 PerlIOBuf * const b = &m->base;
4921 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4923 * Already have a readbuffer in progress
4929 * We have a write buffer or flushed PerlIOBuf read buffer
4931 m->bbuf = b->buf; /* save it in case we need it again */
4932 b->buf = NULL; /* Clear to trigger below */
4935 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4938 * Map did not work - recover PerlIOBuf buffer if we have one
4943 b->ptr = b->end = b->buf;
4946 return PerlIOBuf_get_base(aTHX_ f);
4950 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4952 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4953 PerlIOBuf * const b = &m->base;
4954 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4956 if (b->ptr && (b->ptr - count) >= b->buf
4957 && memEQ(b->ptr - count, vbuf, count)) {
4959 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4964 * Loose the unwritable mapped buffer
4968 * If flush took the "buffer" see if we have one from before
4970 if (!b->buf && m->bbuf)
4973 PerlIOBuf_get_base(aTHX_ f);
4977 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4981 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4983 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4984 PerlIOBuf * const b = &m->base;
4986 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4988 * No, or wrong sort of, buffer
4991 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4995 * If unmap took the "buffer" see if we have one from before
4997 if (!b->buf && m->bbuf)
5000 PerlIOBuf_get_base(aTHX_ f);
5004 return PerlIOBuf_write(aTHX_ f, vbuf, count);
5008 PerlIOMmap_flush(pTHX_ PerlIO *f)
5010 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5011 PerlIOBuf * const b = &m->base;
5012 IV code = PerlIOBuf_flush(aTHX_ f);
5014 * Now we are "synced" at PerlIOBuf level
5021 if (PerlIOMmap_unmap(aTHX_ f) != 0)
5026 * We seem to have a PerlIOBuf buffer which was not mapped
5027 * remember it in case we need one later
5036 PerlIOMmap_fill(pTHX_ PerlIO *f)
5038 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
5039 IV code = PerlIO_flush(f);
5040 if (code == 0 && !b->buf) {
5041 code = PerlIOMmap_map(aTHX_ f);
5043 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
5044 code = PerlIOBuf_fill(aTHX_ f);
5050 PerlIOMmap_close(pTHX_ PerlIO *f)
5052 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5053 PerlIOBuf * const b = &m->base;
5054 IV code = PerlIO_flush(f);
5058 b->ptr = b->end = b->buf;
5060 if (PerlIOBuf_close(aTHX_ f) != 0)
5066 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
5068 return PerlIOBase_dup(aTHX_ f, o, param, flags);
5072 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
5073 sizeof(PerlIO_funcs),
5076 PERLIO_K_BUFFERED|PERLIO_K_RAW,
5080 PerlIOBase_binmode, /* binmode */
5094 PerlIOBase_clearerr,
5095 PerlIOBase_setlinebuf,
5096 PerlIOMmap_get_base,
5100 PerlIOBuf_set_ptrcnt,
5103 #endif /* HAS_MMAP */
5106 Perl_PerlIO_stdin(pTHX)
5110 PerlIO_stdstreams(aTHX);
5112 return (PerlIO*)&PL_perlio[1];
5116 Perl_PerlIO_stdout(pTHX)
5120 PerlIO_stdstreams(aTHX);
5122 return (PerlIO*)&PL_perlio[2];
5126 Perl_PerlIO_stderr(pTHX)
5130 PerlIO_stdstreams(aTHX);
5132 return (PerlIO*)&PL_perlio[3];
5135 /*--------------------------------------------------------------------------------------*/
5138 PerlIO_getname(PerlIO *f, char *buf)
5143 bool exported = FALSE;
5144 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5146 stdio = PerlIO_exportFILE(f,0);
5150 name = fgetname(stdio, buf);
5151 if (exported) PerlIO_releaseFILE(f,stdio);
5156 PERL_UNUSED_ARG(buf);
5157 Perl_croak(aTHX_ "Don't know how to get file name");
5163 /*--------------------------------------------------------------------------------------*/
5165 * Functions which can be called on any kind of PerlIO implemented in
5169 #undef PerlIO_fdopen
5171 PerlIO_fdopen(int fd, const char *mode)
5174 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5179 PerlIO_open(const char *path, const char *mode)
5182 SV *name = sv_2mortal(newSVpv(path, 0));
5183 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5186 #undef Perlio_reopen
5188 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5191 SV *name = sv_2mortal(newSVpv(path,0));
5192 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5197 PerlIO_getc(PerlIO *f)
5201 if ( 1 == PerlIO_read(f, buf, 1) ) {
5202 return (unsigned char) buf[0];
5207 #undef PerlIO_ungetc
5209 PerlIO_ungetc(PerlIO *f, int ch)
5214 if (PerlIO_unread(f, &buf, 1) == 1)
5222 PerlIO_putc(PerlIO *f, int ch)
5226 return PerlIO_write(f, &buf, 1);
5231 PerlIO_puts(PerlIO *f, const char *s)
5234 return PerlIO_write(f, s, strlen(s));
5237 #undef PerlIO_rewind
5239 PerlIO_rewind(PerlIO *f)
5242 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5246 #undef PerlIO_vprintf
5248 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5257 Perl_va_copy(ap, apc);
5258 sv = vnewSVpvf(fmt, &apc);
5260 sv = vnewSVpvf(fmt, &ap);
5262 s = SvPV_const(sv, len);
5263 wrote = PerlIO_write(f, s, len);
5268 #undef PerlIO_printf
5270 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5275 result = PerlIO_vprintf(f, fmt, ap);
5280 #undef PerlIO_stdoutf
5282 PerlIO_stdoutf(const char *fmt, ...)
5288 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5293 #undef PerlIO_tmpfile
5295 PerlIO_tmpfile(void)
5300 const int fd = win32_tmpfd();
5302 f = PerlIO_fdopen(fd, "w+b");
5304 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5306 char tempname[] = "/tmp/PerlIO_XXXXXX";
5307 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5310 * I have no idea how portable mkstemp() is ... NI-S
5312 if (tmpdir && *tmpdir) {
5313 /* if TMPDIR is set and not empty, we try that first */
5314 sv = newSVpv(tmpdir, 0);
5315 sv_catpv(sv, tempname + 4);
5316 fd = mkstemp(SvPVX(sv));
5320 /* else we try /tmp */
5321 fd = mkstemp(tempname);
5324 f = PerlIO_fdopen(fd, "w+");
5326 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5327 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5330 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5331 FILE * const stdio = PerlSIO_tmpfile();
5334 f = PerlIO_fdopen(fileno(stdio), "w+");
5336 # endif /* else HAS_MKSTEMP */
5337 #endif /* else WIN32 */
5344 #endif /* USE_SFIO */
5345 #endif /* PERLIO_IS_STDIO */
5347 /*======================================================================================*/
5349 * Now some functions in terms of above which may be needed even if we are
5350 * not in true PerlIO mode
5353 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5356 const char *direction = NULL;
5359 * Need to supply default layer info from open.pm
5365 if (mode && mode[0] != 'r') {
5366 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5367 direction = "open>";
5369 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5370 direction = "open<";
5375 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5378 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5383 #undef PerlIO_setpos
5385 PerlIO_setpos(PerlIO *f, SV *pos)
5390 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5391 if (f && len == sizeof(Off_t))
5392 return PerlIO_seek(f, *posn, SEEK_SET);
5394 SETERRNO(EINVAL, SS_IVCHAN);
5398 #undef PerlIO_setpos
5400 PerlIO_setpos(PerlIO *f, SV *pos)
5405 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5406 if (f && len == sizeof(Fpos_t)) {
5407 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5408 return fsetpos64(f, fpos);
5410 return fsetpos(f, fpos);
5414 SETERRNO(EINVAL, SS_IVCHAN);
5420 #undef PerlIO_getpos
5422 PerlIO_getpos(PerlIO *f, SV *pos)
5425 Off_t posn = PerlIO_tell(f);
5426 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5427 return (posn == (Off_t) - 1) ? -1 : 0;
5430 #undef PerlIO_getpos
5432 PerlIO_getpos(PerlIO *f, SV *pos)
5437 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5438 code = fgetpos64(f, &fpos);
5440 code = fgetpos(f, &fpos);
5442 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5447 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5450 vprintf(char *pat, char *args)
5452 _doprnt(pat, args, stdout);
5453 return 0; /* wrong, but perl doesn't use the return
5458 vfprintf(FILE *fd, char *pat, char *args)
5460 _doprnt(pat, args, fd);
5461 return 0; /* wrong, but perl doesn't use the return
5467 #ifndef PerlIO_vsprintf
5469 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5472 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5473 PERL_UNUSED_CONTEXT;
5475 #ifndef PERL_MY_VSNPRINTF_GUARDED
5476 if (val < 0 || (n > 0 ? val >= n : 0)) {
5477 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5484 #ifndef PerlIO_sprintf
5486 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5491 result = PerlIO_vsprintf(s, n, fmt, ap);
5499 * c-indentation-style: bsd
5501 * indent-tabs-mode: t
5504 * ex: set ts=8 sts=4 sw=4 noet: