3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 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
34 #define PERLIO_NOT_STDIO 0
36 * This file provides those parts of PerlIO abstraction
37 * which are not #defined in perlio.h.
38 * Which these are depends on various Configure #ifdef's
42 #define PERL_IN_PERLIO_C
45 #ifdef PERL_IMPLICIT_CONTEXT
56 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
58 /* Call the callback or PerlIOBase, and return failure. */
59 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
60 if (PerlIOValid(f)) { \
61 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
62 if (tab && tab->callback) \
63 return (*tab->callback) args; \
65 return PerlIOBase_ ## base args; \
68 SETERRNO(EBADF, SS_IVCHAN); \
71 /* Call the callback or fail, and return failure. */
72 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
73 if (PerlIOValid(f)) { \
74 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
75 if (tab && tab->callback) \
76 return (*tab->callback) args; \
77 SETERRNO(EINVAL, LIB_INVARG); \
80 SETERRNO(EBADF, SS_IVCHAN); \
83 /* Call the callback or PerlIOBase, and be void. */
84 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
85 if (PerlIOValid(f)) { \
86 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
87 if (tab && tab->callback) \
88 (*tab->callback) args; \
90 PerlIOBase_ ## base args; \
93 SETERRNO(EBADF, SS_IVCHAN)
95 /* Call the callback or fail, and be void. */
96 #define Perl_PerlIO_or_fail_void(f, callback, args) \
97 if (PerlIOValid(f)) { \
98 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
99 if (tab && tab->callback) \
100 (*tab->callback) args; \
102 SETERRNO(EINVAL, LIB_INVARG); \
105 SETERRNO(EBADF, SS_IVCHAN)
107 #if defined(__osf__) && _XOPEN_SOURCE < 500
108 extern int fseeko(FILE *, off_t, int);
109 extern off_t ftello(FILE *);
112 #define NATIVE_0xd CR_NATIVE
113 #define NATIVE_0xa LF_NATIVE
115 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
118 perlsio_binmode(FILE *fp, int iotype, int mode)
121 * This used to be contents of do_binmode in doio.c
125 PERL_UNUSED_ARG(iotype);
127 if (PerlLIO_setmode(fp, mode) != -1) {
129 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
136 # if defined(USEMYBINMODE)
138 # if defined(__CYGWIN__)
139 PERL_UNUSED_ARG(iotype);
141 if (my_binmode(fp, iotype, mode) != FALSE)
147 PERL_UNUSED_ARG(iotype);
148 PERL_UNUSED_ARG(mode);
155 #define O_ACCMODE 3 /* Assume traditional implementation */
159 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
161 const int result = rawmode & O_ACCMODE;
166 ptype = IoTYPE_RDONLY;
169 ptype = IoTYPE_WRONLY;
177 *writing = (result != O_RDONLY);
179 if (result == O_RDONLY) {
183 else if (rawmode & O_APPEND) {
185 if (result != O_WRONLY)
190 if (result == O_WRONLY)
198 /* Unless O_BINARY is different from zero, bit-and:ing
199 * with it won't do much good. */
200 if (rawmode & O_BINARY)
207 #ifndef PERLIO_LAYERS
209 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
211 if (!names || !*names
212 || strEQ(names, ":crlf")
213 || strEQ(names, ":raw")
214 || strEQ(names, ":bytes")
218 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
226 PerlIO_destruct(pTHX)
231 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
233 return perlsio_binmode(fp, iotype, mode);
237 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
239 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
241 #elif defined(PERL_IMPLICIT_SYS)
242 return PerlSIO_fdupopen(f);
245 return win32_fdupopen(f);
248 const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f));
252 const int omode = djgpp_get_stream_mode(f);
254 const int omode = fcntl(fd, F_GETFL);
256 PerlIO_intmode2str(omode,mode,NULL);
257 /* the r+ is a hack */
258 return PerlIO_fdopen(fd, mode);
263 SETERRNO(EBADF, SS_IVCHAN);
272 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
276 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
277 int imode, int perm, PerlIO *old, int narg, SV **args)
281 Perl_croak(aTHX_ "More than one argument to open");
283 if (*args == &PL_sv_undef)
284 return PerlIO_tmpfile();
287 const char *name = SvPV_const(*args, len);
288 if (!IS_SAFE_PATHNAME(name, len, "open"))
291 if (*mode == IoTYPE_NUMERIC) {
292 fd = PerlLIO_open3_cloexec(name, imode, perm);
294 return PerlIO_fdopen(fd, mode + 1);
297 return PerlIO_reopen(name, mode, old);
300 return PerlIO_open(name, mode);
305 return PerlIO_fdopen(fd, (char *) mode);
310 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
311 XS(XS_PerlIO__Layer__find)
315 Perl_croak(aTHX_ "Usage class->find(name[,load])");
317 const char * const name = SvPV_nolen_const(ST(1));
318 ST(0) = (strEQ(name, "crlf")
319 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
326 Perl_boot_core_PerlIO(pTHX)
328 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
334 /*======================================================================================*/
336 * Implement all the PerlIO interface ourselves.
342 PerlIO_debug(const char *fmt, ...)
352 if (!PL_perlio_debug_fd) {
354 PerlProc_getuid() == PerlProc_geteuid() &&
355 PerlProc_getgid() == PerlProc_getegid()) {
356 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
358 PL_perlio_debug_fd = PerlLIO_open3_cloexec(s,
359 O_WRONLY | O_CREAT | O_APPEND, 0666);
361 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
363 /* tainting or set*id, so ignore the environment and send the
364 debug output to stderr, like other -D switches. */
365 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
368 if (PL_perlio_debug_fd > 0) {
370 const char * const s = CopFILE(PL_curcop);
371 /* Use fixed buffer as sv_catpvf etc. needs SVs */
373 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
375 # ifdef HAS_VSNPRINTF
376 /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf()
377 should be, otherwise the system isn't likely to support quadmath.
378 Nothing should be calling PerlIO_debug() with floating point anyway.
380 const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
382 STATIC_ASSERT_STMT(0);
385 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
387 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
389 const char *s = CopFILE(PL_curcop);
391 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
392 (IV) CopLINE(PL_curcop));
393 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
395 s = SvPV_const(sv, len);
396 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
403 /*--------------------------------------------------------------------------------------*/
406 * Inner level routines
409 /* check that the head field of each layer points back to the head */
412 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
414 PerlIO_verify_head(pTHX_ PerlIO *f)
418 #ifndef PERL_IMPLICIT_SYS
423 p = head = PerlIOBase(f)->head;
426 assert(p->head == head);
427 if (p == (PerlIOl*)f)
434 # define VERIFY_HEAD(f)
439 * Table of pointers to the PerlIO structs (malloc'ed)
441 #define PERLIO_TABLE_SIZE 64
444 PerlIO_init_table(pTHX)
448 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
454 PerlIO_allocate(pTHX)
457 * Find a free slot in the table, allocating new table as necessary
462 while ((f = *last)) {
464 last = (PerlIOl **) (f);
465 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
466 if (!((++f)->next)) {
471 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
475 *last = (PerlIOl*) f++;
478 f->flags = 0; /* lockcnt */
484 #undef PerlIO_fdupopen
486 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
488 if (PerlIOValid(f)) {
489 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
490 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
492 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
494 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
498 SETERRNO(EBADF, SS_IVCHAN);
504 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
506 PerlIOl * const table = *tablep;
509 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
510 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
511 PerlIOl * const f = table + i;
513 PerlIO_close(&(f->next));
523 PerlIO_list_alloc(pTHX)
527 Newxz(list, 1, PerlIO_list_t);
533 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
536 if (--list->refcnt == 0) {
539 for (i = 0; i < list->cur; i++)
540 SvREFCNT_dec(list->array[i].arg);
541 Safefree(list->array);
549 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
554 if (list->cur >= list->len) {
555 const IV new_len = list->len + 8;
557 Renew(list->array, new_len, PerlIO_pair_t);
559 Newx(list->array, new_len, PerlIO_pair_t);
562 p = &(list->array[list->cur++]);
564 if ((p->arg = arg)) {
565 SvREFCNT_inc_simple_void_NN(arg);
570 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
572 PerlIO_list_t *list = NULL;
575 list = PerlIO_list_alloc(aTHX);
576 for (i=0; i < proto->cur; i++) {
577 SV *arg = proto->array[i].arg;
580 arg = sv_dup(arg, param);
582 PERL_UNUSED_ARG(param);
584 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
591 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
594 PerlIOl **table = &proto->Iperlio;
597 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
598 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
599 PerlIO_init_table(aTHX);
600 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
601 while ((f = *table)) {
603 table = (PerlIOl **) (f++);
604 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
606 (void) fp_dup(&(f->next), 0, param);
613 PERL_UNUSED_ARG(proto);
614 PERL_UNUSED_ARG(param);
619 PerlIO_destruct(pTHX)
621 PerlIOl **table = &PL_perlio;
624 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
626 while ((f = *table)) {
628 table = (PerlIOl **) (f++);
629 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
630 PerlIO *x = &(f->next);
633 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
634 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
648 PerlIO_pop(pTHX_ PerlIO *f)
650 const PerlIOl *l = *f;
653 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
654 l->tab ? l->tab->name : "(Null)") );
655 if (l->tab && l->tab->Popped) {
657 * If popped returns non-zero do not free its layer structure
658 * it has either done so itself, or it is shared and still in
661 if ((*l->tab->Popped) (aTHX_ f) != 0)
664 if (PerlIO_lockcnt(f)) {
665 /* we're in use; defer freeing the structure */
666 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
667 PerlIOBase(f)->tab = NULL;
677 /* Return as an array the stack of layers on a filehandle. Note that
678 * the stack is returned top-first in the array, and there are three
679 * times as many array elements as there are layers in the stack: the
680 * first element of a layer triplet is the name, the second one is the
681 * arguments, and the third one is the flags. */
684 PerlIO_get_layers(pTHX_ PerlIO *f)
686 AV * const av = newAV();
688 if (PerlIOValid(f)) {
689 PerlIOl *l = PerlIOBase(f);
692 /* There is some collusion in the implementation of
693 XS_PerlIO_get_layers - it knows that name and flags are
694 generated as fresh SVs here, and takes advantage of that to
695 "copy" them by taking a reference. If it changes here, it needs
696 to change there too. */
697 SV * const name = l->tab && l->tab->name ?
698 newSVpv(l->tab->name, 0) : &PL_sv_undef;
699 SV * const arg = l->tab && l->tab->Getarg ?
700 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
703 av_push(av, newSViv((IV)l->flags));
711 /*--------------------------------------------------------------------------------------*/
713 * XS Interface for perl code
717 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
721 if ((SSize_t) len <= 0)
723 for (i = 0; i < PL_known_layers->cur; i++) {
724 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
725 const STRLEN this_len = strlen(f->name);
726 if (this_len == len && memEQ(f->name, name, len)) {
727 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
731 if (load && PL_subname && PL_def_layerlist
732 && PL_def_layerlist->cur >= 2) {
733 if (PL_in_load_module) {
734 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
737 SV * const pkgsv = newSVpvs("PerlIO");
738 SV * const layer = newSVpvn(name, len);
739 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
741 SAVEBOOL(PL_in_load_module);
743 SAVEGENERICSV(PL_warnhook);
744 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
746 PL_in_load_module = TRUE;
748 * The two SVs are magically freed by load_module
750 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
752 return PerlIO_find_layer(aTHX_ name, len, 0);
755 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
759 #ifdef USE_ATTRIBUTES_FOR_PERLIO
762 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
765 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
766 PerlIO * const ifp = IoIFP(io);
767 PerlIO * const ofp = IoOFP(io);
768 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
769 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
775 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
778 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
779 PerlIO * const ifp = IoIFP(io);
780 PerlIO * const ofp = IoOFP(io);
781 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
782 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
788 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
790 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
795 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
797 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
801 MGVTBL perlio_vtab = {
809 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
810 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
813 SV * const sv = SvRV(ST(1));
814 AV * const av = newAV();
818 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
820 mg = mg_find(sv, PERL_MAGIC_ext);
821 mg->mg_virtual = &perlio_vtab;
823 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
824 for (i = 2; i < items; i++) {
826 const char * const name = SvPV_const(ST(i), len);
827 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
829 av_push(av, SvREFCNT_inc_simple_NN(layer));
840 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
843 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
845 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
846 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
850 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
851 XS(XS_PerlIO__Layer__NoWarnings)
853 /* This is used as a %SIG{__WARN__} handler to suppress warnings
854 during loading of layers.
857 PERL_UNUSED_VAR(items);
860 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
864 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
865 XS(XS_PerlIO__Layer__find)
869 Perl_croak(aTHX_ "Usage class->find(name[,load])");
872 const char * const name = SvPV_const(ST(1), len);
873 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
874 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
876 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
883 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
885 if (!PL_known_layers)
886 PL_known_layers = PerlIO_list_alloc(aTHX);
887 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
888 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
892 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
895 const char *s = names;
897 while (isSPACE(*s) || *s == ':')
902 const char *as = NULL;
904 if (!isIDFIRST(*s)) {
906 * Message is consistent with how attribute lists are
907 * passed. Even though this means "foo : : bar" is
908 * seen as an invalid separator character.
910 const char q = ((*s == '\'') ? '"' : '\'');
911 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
912 "Invalid separator character %c%c%c in PerlIO layer specification %s",
914 SETERRNO(EINVAL, LIB_INVARG);
919 } while (isWORDCHAR(*e));
935 * It's a nul terminated string, not allowed
936 * to \ the terminating null. Anything other
937 * character is passed over.
945 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
946 "Argument list not closed for PerlIO layer \"%.*s\"",
958 PerlIO_funcs * const layer =
959 PerlIO_find_layer(aTHX_ s, llen, 1);
963 arg = newSVpvn(as, alen);
964 PerlIO_list_push(aTHX_ av, layer,
965 (arg) ? arg : &PL_sv_undef);
969 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
982 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
984 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
985 #ifdef PERLIO_USING_CRLF
988 if (PerlIO_stdio.Set_ptrcnt)
991 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
992 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
996 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
998 return av->array[n].arg;
1002 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1004 if (n >= 0 && n < av->cur) {
1005 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1006 av->array[n].funcs->name) );
1007 return av->array[n].funcs;
1010 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1015 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1017 PERL_UNUSED_ARG(mode);
1018 PERL_UNUSED_ARG(arg);
1019 PERL_UNUSED_ARG(tab);
1020 if (PerlIOValid(f)) {
1022 PerlIO_pop(aTHX_ f);
1028 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1029 sizeof(PerlIO_funcs),
1032 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1052 NULL, /* get_base */
1053 NULL, /* get_bufsiz */
1056 NULL, /* set_ptrcnt */
1060 PerlIO_default_layers(pTHX)
1062 if (!PL_def_layerlist) {
1063 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1064 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1065 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1068 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1070 osLayer = &PerlIO_win32;
1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1077 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1078 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1079 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1080 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1083 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1086 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1089 if (PL_def_layerlist->cur < 2) {
1090 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1092 return PL_def_layerlist;
1096 Perl_boot_core_PerlIO(pTHX)
1098 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1099 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1102 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1103 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1107 PerlIO_default_layer(pTHX_ I32 n)
1109 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1112 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1115 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1116 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1119 PerlIO_stdstreams(pTHX)
1122 PerlIO_init_table(aTHX);
1123 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1124 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1125 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1130 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1133 if (tab->fsize != sizeof(PerlIO_funcs)) {
1135 "%s (%" UVuf ") does not match %s (%" UVuf ")",
1136 "PerlIO layer function table size", (UV)tab->fsize,
1137 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1141 if (tab->size < sizeof(PerlIOl)) {
1143 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1144 "PerlIO layer instance size", (UV)tab->size,
1145 "size expected by this perl", (UV)sizeof(PerlIOl) );
1147 /* Real layer with a data area */
1150 Newxz(temp, tab->size, char);
1154 l->tab = (PerlIO_funcs*) tab;
1155 l->head = ((PerlIOl*)f)->head;
1157 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1158 (void*)f, tab->name,
1159 (mode) ? mode : "(Null)", (void*)arg) );
1160 if (*l->tab->Pushed &&
1162 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1163 PerlIO_pop(aTHX_ f);
1172 /* Pseudo-layer where push does its own stack adjust */
1173 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1174 (mode) ? mode : "(Null)", (void*)arg) );
1176 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1184 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1185 IV n, const char *mode, int fd, int imode, int perm,
1186 PerlIO *old, int narg, SV **args)
1188 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1189 if (tab && tab->Open) {
1190 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1191 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1197 SETERRNO(EINVAL, LIB_INVARG);
1202 PerlIOBase_binmode(pTHX_ PerlIO *f)
1204 if (PerlIOValid(f)) {
1205 /* Is layer suitable for raw stream ? */
1206 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1207 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1208 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1211 /* Not suitable - pop it */
1212 PerlIO_pop(aTHX_ f);
1220 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1222 PERL_UNUSED_ARG(mode);
1223 PERL_UNUSED_ARG(arg);
1224 PERL_UNUSED_ARG(tab);
1226 if (PerlIOValid(f)) {
1231 * Strip all layers that are not suitable for a raw stream
1234 while (t && (l = *t)) {
1235 if (l->tab && l->tab->Binmode) {
1236 /* Has a handler - normal case */
1237 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1239 /* Layer still there - move down a layer */
1248 /* No handler - pop it */
1249 PerlIO_pop(aTHX_ t);
1252 if (PerlIOValid(f)) {
1253 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1254 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1262 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1263 PerlIO_list_t *layers, IV n, IV max)
1267 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1269 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1280 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1284 save_scalar(PL_errgv);
1286 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1287 code = PerlIO_parse_layers(aTHX_ layers, names);
1289 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1291 PerlIO_list_free(aTHX_ layers);
1298 /*--------------------------------------------------------------------------------------*/
1300 * Given the abstraction above the public API functions
1304 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1306 PERL_UNUSED_ARG(iotype);
1307 PERL_UNUSED_ARG(mode);
1310 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1311 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1312 PerlIOBase(f)->tab->name : "(Null)",
1313 iotype, mode, (names) ? names : "(Null)") );
1316 /* Do not flush etc. if (e.g.) switching encodings.
1317 if a pushed layer knows it needs to flush lower layers
1318 (for example :unix which is never going to call them)
1319 it can do the flush when it is pushed.
1321 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1324 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1325 #ifdef PERLIO_USING_CRLF
1326 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1327 O_BINARY so we can look for it in mode.
1329 if (!(mode & O_BINARY)) {
1331 /* FIXME?: Looking down the layer stack seems wrong,
1332 but is a way of reaching past (say) an encoding layer
1333 to flip CRLF-ness of the layer(s) below
1336 /* Perhaps we should turn on bottom-most aware layer
1337 e.g. Ilya's idea that UNIX TTY could serve
1339 if (PerlIOBase(f)->tab &&
1340 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1342 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1343 /* Not in text mode - flush any pending stuff and flip it */
1345 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1347 /* Only need to turn it on in one layer so we are done */
1352 /* Not finding a CRLF aware layer presumably means we are binary
1353 which is not what was requested - so we failed
1354 We _could_ push :crlf layer but so could caller
1359 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1360 So code that used to be here is now in PerlIORaw_pushed().
1362 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1367 PerlIO__close(pTHX_ PerlIO *f)
1369 if (PerlIOValid(f)) {
1370 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1371 if (tab && tab->Close)
1372 return (*tab->Close)(aTHX_ f);
1374 return PerlIOBase_close(aTHX_ f);
1377 SETERRNO(EBADF, SS_IVCHAN);
1383 Perl_PerlIO_close(pTHX_ PerlIO *f)
1385 const int code = PerlIO__close(aTHX_ f);
1386 while (PerlIOValid(f)) {
1387 PerlIO_pop(aTHX_ f);
1388 if (PerlIO_lockcnt(f))
1389 /* we're in use; the 'pop' deferred freeing the structure */
1396 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1398 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1402 static PerlIO_funcs *
1403 PerlIO_layer_from_ref(pTHX_ SV *sv)
1406 * For any scalar type load the handler which is bundled with perl
1408 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1409 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1410 /* This isn't supposed to happen, since PerlIO::scalar is core,
1411 * but could happen anyway in smaller installs or with PAR */
1413 /* diag_listed_as: Unknown PerlIO layer "%s" */
1414 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1419 * For other types allow if layer is known but don't try and load it
1421 switch (SvTYPE(sv)) {
1423 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1425 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1427 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1429 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1436 PerlIO_resolve_layers(pTHX_ const char *layers,
1437 const char *mode, int narg, SV **args)
1439 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1442 PerlIO_stdstreams(aTHX);
1444 SV * const arg = *args;
1446 * If it is a reference but not an object see if we have a handler
1449 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1450 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1452 def = PerlIO_list_alloc(aTHX);
1453 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1457 * Don't fail if handler cannot be found :via(...) etc. may do
1458 * something sensible else we will just stringfy and open
1463 if (!layers || !*layers)
1464 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1465 if (layers && *layers) {
1468 av = PerlIO_clone_list(aTHX_ def, NULL);
1473 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1477 PerlIO_list_free(aTHX_ av);
1489 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1490 int imode, int perm, PerlIO *f, int narg, SV **args)
1492 if (!f && narg == 1 && *args == &PL_sv_undef) {
1493 if ((f = PerlIO_tmpfile())) {
1494 if (!layers || !*layers)
1495 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1496 if (layers && *layers)
1497 PerlIO_apply_layers(aTHX_ f, mode, layers);
1501 PerlIO_list_t *layera;
1503 PerlIO_funcs *tab = NULL;
1504 if (PerlIOValid(f)) {
1506 * This is "reopen" - it is not tested as perl does not use it
1510 layera = PerlIO_list_alloc(aTHX);
1513 if (l->tab && l->tab->Getarg)
1514 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1515 PerlIO_list_push(aTHX_ layera, l->tab,
1516 (arg) ? arg : &PL_sv_undef);
1518 l = *PerlIONext(&l);
1522 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1528 * Start at "top" of layer stack
1530 n = layera->cur - 1;
1532 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1541 * Found that layer 'n' can do opens - call it
1543 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1544 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1546 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1547 tab->name, layers ? layers : "(Null)", mode, fd,
1548 imode, perm, (void*)f, narg, (void*)args) );
1550 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1553 SETERRNO(EINVAL, LIB_INVARG);
1557 if (n + 1 < layera->cur) {
1559 * More layers above the one that we used to open -
1562 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1563 /* If pushing layers fails close the file */
1570 PerlIO_list_free(aTHX_ layera);
1577 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1579 PERL_ARGS_ASSERT_PERLIO_READ;
1581 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1585 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1587 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1589 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1593 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1595 PERL_ARGS_ASSERT_PERLIO_WRITE;
1597 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1601 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1603 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1607 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1609 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1613 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1617 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1619 if (tab && tab->Flush)
1620 return (*tab->Flush) (aTHX_ f);
1622 return 0; /* If no Flush defined, silently succeed. */
1625 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1626 SETERRNO(EBADF, SS_IVCHAN);
1632 * Is it good API design to do flush-all on NULL, a potentially
1633 * erroneous input? Maybe some magical value (PerlIO*
1634 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1635 * things on fflush(NULL), but should we be bound by their design
1638 PerlIOl **table = &PL_perlio;
1641 while ((ff = *table)) {
1643 table = (PerlIOl **) (ff++);
1644 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1645 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1655 PerlIOBase_flush_linebuf(pTHX)
1657 PerlIOl **table = &PL_perlio;
1659 while ((f = *table)) {
1661 table = (PerlIOl **) (f++);
1662 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1664 && (PerlIOBase(&(f->next))->
1665 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1666 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1667 PerlIO_flush(&(f->next));
1674 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1676 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1680 PerlIO_isutf8(PerlIO *f)
1683 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1685 SETERRNO(EBADF, SS_IVCHAN);
1691 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1693 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1697 Perl_PerlIO_error(pTHX_ PerlIO *f)
1699 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1703 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1705 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1709 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1711 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1715 PerlIO_has_base(PerlIO *f)
1717 if (PerlIOValid(f)) {
1718 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1721 return (tab->Get_base != NULL);
1728 PerlIO_fast_gets(PerlIO *f)
1730 if (PerlIOValid(f)) {
1731 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1732 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1735 return (tab->Set_ptrcnt != NULL);
1743 PerlIO_has_cntptr(PerlIO *f)
1745 if (PerlIOValid(f)) {
1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1749 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1756 PerlIO_canset_cnt(PerlIO *f)
1758 if (PerlIOValid(f)) {
1759 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1762 return (tab->Set_ptrcnt != NULL);
1769 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1771 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1775 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1777 /* Note that Get_bufsiz returns a Size_t */
1778 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1782 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1784 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1788 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1790 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1794 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1796 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1800 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1802 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1806 /*--------------------------------------------------------------------------------------*/
1808 * utf8 and raw dummy layers
1812 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1814 PERL_UNUSED_CONTEXT;
1815 PERL_UNUSED_ARG(mode);
1816 PERL_UNUSED_ARG(arg);
1817 if (PerlIOValid(f)) {
1818 if (tab && tab->kind & PERLIO_K_UTF8)
1819 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1821 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1827 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1828 sizeof(PerlIO_funcs),
1831 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1851 NULL, /* get_base */
1852 NULL, /* get_bufsiz */
1855 NULL, /* set_ptrcnt */
1858 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1859 sizeof(PerlIO_funcs),
1862 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1882 NULL, /* get_base */
1883 NULL, /* get_bufsiz */
1886 NULL, /* set_ptrcnt */
1889 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1890 sizeof(PerlIO_funcs),
1913 NULL, /* get_base */
1914 NULL, /* get_bufsiz */
1917 NULL, /* set_ptrcnt */
1919 /*--------------------------------------------------------------------------------------*/
1920 /*--------------------------------------------------------------------------------------*/
1922 * "Methods" of the "base class"
1926 PerlIOBase_fileno(pTHX_ PerlIO *f)
1928 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1932 PerlIO_modestr(PerlIO * f, char *buf)
1935 if (PerlIOValid(f)) {
1936 const IV flags = PerlIOBase(f)->flags;
1937 if (flags & PERLIO_F_APPEND) {
1939 if (flags & PERLIO_F_CANREAD) {
1943 else if (flags & PERLIO_F_CANREAD) {
1945 if (flags & PERLIO_F_CANWRITE)
1948 else if (flags & PERLIO_F_CANWRITE) {
1950 if (flags & PERLIO_F_CANREAD) {
1954 #ifdef PERLIO_USING_CRLF
1955 if (!(flags & PERLIO_F_CRLF))
1965 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1967 PerlIOl * const l = PerlIOBase(f);
1968 PERL_UNUSED_CONTEXT;
1969 PERL_UNUSED_ARG(arg);
1971 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1972 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1973 if (tab && tab->Set_ptrcnt != NULL)
1974 l->flags |= PERLIO_F_FASTGETS;
1976 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1980 l->flags |= PERLIO_F_CANREAD;
1983 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1986 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1989 SETERRNO(EINVAL, LIB_INVARG);
1994 /* The mode variable contains one positional parameter followed by
1995 * optional keyword parameters. The positional parameters must be
1996 * passed as lowercase characters. The keyword parameters can be
1997 * passed in mixed case. They must be separated by commas. Only one
1998 * instance of a keyword can be specified. */
2004 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2008 l->flags &= ~PERLIO_F_CRLF;
2012 l->flags |= PERLIO_F_CRLF;
2026 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2029 l->flags &= ~PERLIO_F_CRLF;
2032 l->flags |= PERLIO_F_CRLF;
2035 SETERRNO(EINVAL, LIB_INVARG);
2043 l->flags |= l->next->flags &
2044 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2050 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2051 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2052 l->flags, PerlIO_modestr(f, temp));
2059 PerlIOBase_popped(pTHX_ PerlIO *f)
2061 PERL_UNUSED_CONTEXT;
2067 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2070 * Save the position as current head considers it
2072 const Off_t old = PerlIO_tell(f);
2073 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2074 PerlIOSelf(f, PerlIOBuf)->posn = old;
2075 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2079 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2081 STDCHAR *buf = (STDCHAR *) vbuf;
2083 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2084 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2085 SETERRNO(EBADF, SS_IVCHAN);
2086 PerlIO_save_errno(f);
2092 SSize_t avail = PerlIO_get_cnt(f);
2095 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2097 STDCHAR *ptr = PerlIO_get_ptr(f);
2098 Copy(ptr, buf, take, STDCHAR);
2099 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2102 if (avail == 0) /* set_ptrcnt could have reset avail */
2105 if (count > 0 && avail <= 0) {
2106 if (PerlIO_fill(f) != 0)
2111 return (buf - (STDCHAR *) vbuf);
2117 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2119 PERL_UNUSED_CONTEXT;
2125 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2127 PERL_UNUSED_CONTEXT;
2133 PerlIOBase_close(pTHX_ PerlIO *f)
2136 if (PerlIOValid(f)) {
2137 PerlIO *n = PerlIONext(f);
2138 code = PerlIO_flush(f);
2139 PerlIOBase(f)->flags &=
2140 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2141 while (PerlIOValid(n)) {
2142 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2143 if (tab && tab->Close) {
2144 if ((*tab->Close)(aTHX_ n) != 0)
2149 PerlIOBase(n)->flags &=
2150 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2156 SETERRNO(EBADF, SS_IVCHAN);
2162 PerlIOBase_eof(pTHX_ PerlIO *f)
2164 PERL_UNUSED_CONTEXT;
2165 if (PerlIOValid(f)) {
2166 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2172 PerlIOBase_error(pTHX_ PerlIO *f)
2174 PERL_UNUSED_CONTEXT;
2175 if (PerlIOValid(f)) {
2176 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2182 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2184 if (PerlIOValid(f)) {
2185 PerlIO * const n = PerlIONext(f);
2186 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2193 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2195 PERL_UNUSED_CONTEXT;
2196 if (PerlIOValid(f)) {
2197 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2202 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2208 arg = sv_dup(arg, param);
2209 SvREFCNT_inc_simple_void_NN(arg);
2213 return newSVsv(arg);
2216 PERL_UNUSED_ARG(param);
2217 return newSVsv(arg);
2222 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2224 PerlIO * const nexto = PerlIONext(o);
2225 if (PerlIOValid(nexto)) {
2226 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2227 if (tab && tab->Dup)
2228 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2230 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2233 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2237 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2239 (void*)f, (void*)o, (void*)param) );
2241 arg = (*self->Getarg)(aTHX_ o, param, flags);
2242 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2243 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2244 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2250 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2252 /* Must be called with PL_perlio_mutex locked. */
2254 S_more_refcounted_fds(pTHX_ const int new_fd)
2255 PERL_TSA_REQUIRES(PL_perlio_mutex)
2258 const int old_max = PL_perlio_fd_refcnt_size;
2259 const int new_max = 16 + (new_fd & ~15);
2262 #ifndef PERL_IMPLICIT_SYS
2263 PERL_UNUSED_CONTEXT;
2266 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2267 old_max, new_fd, new_max) );
2269 if (new_fd < old_max) {
2273 assert (new_max > new_fd);
2275 /* Use plain realloc() since we need this memory to be really
2276 * global and visible to all the interpreters and/or threads. */
2277 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2280 MUTEX_UNLOCK(&PL_perlio_mutex);
2284 PL_perlio_fd_refcnt_size = new_max;
2285 PL_perlio_fd_refcnt = new_array;
2287 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2288 (void*)(new_array + old_max),
2289 new_max - old_max) );
2291 Zero(new_array + old_max, new_max - old_max, int);
2298 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2299 PERL_UNUSED_CONTEXT;
2303 PerlIOUnix_refcnt_inc(int fd)
2309 MUTEX_LOCK(&PL_perlio_mutex);
2310 if (fd >= PL_perlio_fd_refcnt_size)
2311 S_more_refcounted_fds(aTHX_ fd);
2313 PL_perlio_fd_refcnt[fd]++;
2314 if (PL_perlio_fd_refcnt[fd] <= 0) {
2315 /* diag_listed_as: refcnt_inc: fd %d%s */
2316 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2317 fd, PL_perlio_fd_refcnt[fd]);
2319 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2320 fd, PL_perlio_fd_refcnt[fd]) );
2322 MUTEX_UNLOCK(&PL_perlio_mutex);
2324 /* diag_listed_as: refcnt_inc: fd %d%s */
2325 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2330 PerlIOUnix_refcnt_dec(int fd)
2339 MUTEX_LOCK(&PL_perlio_mutex);
2340 if (fd >= PL_perlio_fd_refcnt_size) {
2341 /* diag_listed_as: refcnt_dec: fd %d%s */
2342 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2343 fd, PL_perlio_fd_refcnt_size);
2345 if (PL_perlio_fd_refcnt[fd] <= 0) {
2346 /* diag_listed_as: refcnt_dec: fd %d%s */
2347 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2348 fd, PL_perlio_fd_refcnt[fd]);
2350 cnt = --PL_perlio_fd_refcnt[fd];
2351 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2352 MUTEX_UNLOCK(&PL_perlio_mutex);
2354 /* diag_listed_as: refcnt_dec: fd %d%s */
2355 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2361 PerlIOUnix_refcnt(int fd)
2367 MUTEX_LOCK(&PL_perlio_mutex);
2368 if (fd >= PL_perlio_fd_refcnt_size) {
2369 /* diag_listed_as: refcnt: fd %d%s */
2370 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2371 fd, PL_perlio_fd_refcnt_size);
2373 if (PL_perlio_fd_refcnt[fd] <= 0) {
2374 /* diag_listed_as: refcnt: fd %d%s */
2375 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2376 fd, PL_perlio_fd_refcnt[fd]);
2378 cnt = PL_perlio_fd_refcnt[fd];
2379 MUTEX_UNLOCK(&PL_perlio_mutex);
2381 /* diag_listed_as: refcnt: fd %d%s */
2382 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2388 PerlIO_cleanup(pTHX)
2392 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2394 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2397 /* Raise STDIN..STDERR refcount so we don't close them */
2398 for (i=0; i < 3; i++)
2399 PerlIOUnix_refcnt_inc(i);
2400 PerlIO_cleantable(aTHX_ &PL_perlio);
2401 /* Restore STDIN..STDERR refcount */
2402 for (i=0; i < 3; i++)
2403 PerlIOUnix_refcnt_dec(i);
2405 if (PL_known_layers) {
2406 PerlIO_list_free(aTHX_ PL_known_layers);
2407 PL_known_layers = NULL;
2409 if (PL_def_layerlist) {
2410 PerlIO_list_free(aTHX_ PL_def_layerlist);
2411 PL_def_layerlist = NULL;
2415 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2419 /* XXX we can't rely on an interpreter being present at this late stage,
2420 XXX so we can't use a function like PerlLIO_write that relies on one
2421 being present (at least in win32) :-(.
2426 /* By now all filehandles should have been closed, so any
2427 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2429 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2430 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2431 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2433 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2434 if (PL_perlio_fd_refcnt[i]) {
2436 my_snprintf(buf, sizeof(buf),
2437 "PerlIO_teardown: fd %d refcnt=%d\n",
2438 i, PL_perlio_fd_refcnt[i]);
2439 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2445 /* Not bothering with PL_perlio_mutex since by now
2446 * all the interpreters are gone. */
2447 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2448 && PL_perlio_fd_refcnt) {
2449 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2450 PL_perlio_fd_refcnt = NULL;
2451 PL_perlio_fd_refcnt_size = 0;
2455 /*--------------------------------------------------------------------------------------*/
2457 * Bottom-most level for UNIX-like case
2461 struct _PerlIO base; /* The generic part */
2462 int fd; /* UNIX like file descriptor */
2463 int oflags; /* open/fcntl flags */
2467 S_lockcnt_dec(pTHX_ const void* f)
2469 #ifndef PERL_IMPLICIT_SYS
2470 PERL_UNUSED_CONTEXT;
2472 PerlIO_lockcnt((PerlIO*)f)--;
2476 /* call the signal handler, and if that handler happens to clear
2477 * this handle, free what we can and return true */
2480 S_perlio_async_run(pTHX_ PerlIO* f) {
2482 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2483 PerlIO_lockcnt(f)++;
2485 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2489 /* we've just run some perl-level code that could have done
2490 * anything, including closing the file or clearing this layer.
2491 * If so, free any lower layers that have already been
2492 * cleared, then return an error. */
2493 while (PerlIOValid(f) &&
2494 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2496 const PerlIOl *l = *f;
2505 PerlIOUnix_oflags(const char *mode)
2508 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2513 if (*++mode == '+') {
2520 oflags = O_CREAT | O_TRUNC;
2521 if (*++mode == '+') {
2530 oflags = O_CREAT | O_APPEND;
2531 if (*++mode == '+') {
2540 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2542 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2543 * of them in, and then bit-and-masking the other them away, won't
2544 * have much of an effect. */
2547 #if O_TEXT != O_BINARY
2554 #if O_TEXT != O_BINARY
2556 oflags &= ~O_BINARY;
2562 /* bit-or:ing with zero O_BINARY would be useless. */
2564 * If neither "t" nor "b" was specified, open the file
2567 * Note that if something else than the zero byte was seen
2568 * here (e.g. bogus mode "rx"), just few lines later we will
2569 * set the errno and invalidate the flags.
2575 if (*mode || oflags == -1) {
2576 SETERRNO(EINVAL, LIB_INVARG);
2583 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2585 PERL_UNUSED_CONTEXT;
2586 return PerlIOSelf(f, PerlIOUnix)->fd;
2590 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2592 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2595 if (PerlLIO_fstat(fd, &st) == 0) {
2596 if (!S_ISREG(st.st_mode)) {
2597 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2598 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2601 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2607 PerlIOUnix_refcnt_inc(fd);
2608 PERL_UNUSED_CONTEXT;
2612 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2614 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2615 if (*PerlIONext(f)) {
2616 /* We never call down so do any pending stuff now */
2617 PerlIO_flush(PerlIONext(f));
2619 * XXX could (or should) we retrieve the oflags from the open file
2620 * handle rather than believing the "mode" we are passed in? XXX
2621 * Should the value on NULL mode be 0 or -1?
2623 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2624 mode ? PerlIOUnix_oflags(mode) : -1);
2626 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2632 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2634 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2636 PERL_UNUSED_CONTEXT;
2637 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2639 SETERRNO(ESPIPE, LIB_INVARG);
2641 SETERRNO(EINVAL, LIB_INVARG);
2645 new_loc = PerlLIO_lseek(fd, offset, whence);
2646 if (new_loc == (Off_t) - 1)
2648 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2653 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2654 IV n, const char *mode, int fd, int imode,
2655 int perm, PerlIO *f, int narg, SV **args)
2657 bool known_cloexec = 0;
2658 if (PerlIOValid(f)) {
2659 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2660 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2663 if (*mode == IoTYPE_NUMERIC)
2666 imode = PerlIOUnix_oflags(mode);
2668 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2675 const char *path = SvPV_const(*args, len);
2676 if (!IS_SAFE_PATHNAME(path, len, "open"))
2678 fd = PerlLIO_open3_cloexec(path, imode, perm);
2684 setfd_inhexec_for_sysfd(fd);
2686 setfd_cloexec_or_inhexec_by_sysfdness(fd);
2687 if (*mode == IoTYPE_IMPLICIT)
2690 f = PerlIO_allocate(aTHX);
2692 if (!PerlIOValid(f)) {
2693 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2698 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2699 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2700 if (*mode == IoTYPE_APPEND)
2701 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2708 * FIXME: pop layers ???
2716 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2718 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2720 if (flags & PERLIO_DUP_FD) {
2721 fd = PerlLIO_dup_cloexec(fd);
2723 setfd_inhexec_for_sysfd(fd);
2726 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2728 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2729 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2739 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2742 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2744 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2745 #ifdef PERLIO_STD_SPECIAL
2747 return PERLIO_STD_IN(fd, vbuf, count);
2749 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2750 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2754 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2755 if (len >= 0 || errno != EINTR) {
2757 if (errno != EAGAIN) {
2758 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2759 PerlIO_save_errno(f);
2762 else if (len == 0 && count != 0) {
2763 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2769 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2772 NOT_REACHED; /*NOTREACHED*/
2776 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2779 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2781 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2782 #ifdef PERLIO_STD_SPECIAL
2783 if (fd == 1 || fd == 2)
2784 return PERLIO_STD_OUT(fd, vbuf, count);
2787 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2788 if (len >= 0 || errno != EINTR) {
2790 if (errno != EAGAIN) {
2791 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2792 PerlIO_save_errno(f);
2798 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2801 NOT_REACHED; /*NOTREACHED*/
2805 PerlIOUnix_tell(pTHX_ PerlIO *f)
2807 PERL_UNUSED_CONTEXT;
2809 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2814 PerlIOUnix_close(pTHX_ PerlIO *f)
2816 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2818 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2819 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2820 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2825 SETERRNO(EBADF,SS_IVCHAN);
2828 while (PerlLIO_close(fd) != 0) {
2829 if (errno != EINTR) {
2834 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2838 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2843 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2844 sizeof(PerlIO_funcs),
2851 PerlIOBase_binmode, /* binmode */
2861 PerlIOBase_noop_ok, /* flush */
2862 PerlIOBase_noop_fail, /* fill */
2865 PerlIOBase_clearerr,
2866 PerlIOBase_setlinebuf,
2867 NULL, /* get_base */
2868 NULL, /* get_bufsiz */
2871 NULL, /* set_ptrcnt */
2874 /*--------------------------------------------------------------------------------------*/
2879 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2880 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2881 broken by the last second glibc 2.3 fix
2883 #define STDIO_BUFFER_WRITABLE
2888 struct _PerlIO base;
2889 FILE *stdio; /* The stream */
2893 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2895 PERL_UNUSED_CONTEXT;
2897 if (PerlIOValid(f)) {
2898 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2900 return PerlSIO_fileno(s);
2907 PerlIOStdio_mode(const char *mode, char *tmode)
2909 char * const ret = tmode;
2915 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2923 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2926 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2927 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2928 if (toptab == tab) {
2929 /* Top is already stdio - pop self (duplicate) and use original */
2930 PerlIO_pop(aTHX_ f);
2933 const int fd = PerlIO_fileno(n);
2936 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2937 mode = PerlIOStdio_mode(mode, tmode)))) {
2938 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2939 /* We never call down so do any pending stuff now */
2940 PerlIO_flush(PerlIONext(f));
2941 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2948 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2953 PerlIO_importFILE(FILE *stdio, const char *mode)
2959 char filename[FILENAME_MAX];
2964 int fd0 = fileno(stdio);
2967 rc = fldata(stdio,filename,&fileinfo);
2971 if(fileinfo.__dsorgHFS){
2974 /*This MVS dataset , OK!*/
2979 if (!mode || !*mode) {
2980 /* We need to probe to see how we can open the stream
2981 so start with read/write and then try write and read
2982 we dup() so that we can fclose without loosing the fd.
2984 Note that the errno value set by a failing fdopen
2985 varies between stdio implementations.
2987 const int fd = PerlLIO_dup_cloexec(fd0);
2992 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2994 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2997 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3000 /* Don't seem to be able to open */
3006 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3007 s = PerlIOSelf(f, PerlIOStdio);
3009 fd0 = fileno(stdio);
3011 PerlIOUnix_refcnt_inc(fd0);
3012 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3016 rc = fldata(stdio,filename,&fileinfo);
3018 PerlIOUnix_refcnt_inc(fd0);
3020 if(fileinfo.__dsorgHFS){
3021 PerlIOUnix_refcnt_inc(fd0);
3023 /*This MVS dataset , OK!*/
3032 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3033 IV n, const char *mode, int fd, int imode,
3034 int perm, PerlIO *f, int narg, SV **args)
3037 if (PerlIOValid(f)) {
3039 const char * const path = SvPV_const(*args, len);
3040 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3042 if (!IS_SAFE_PATHNAME(path, len, "open"))
3044 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3045 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3051 PerlIOUnix_refcnt_inc(fd);
3052 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3058 const char * const path = SvPV_const(*args, len);
3059 if (!IS_SAFE_PATHNAME(path, len, "open"))
3061 if (*mode == IoTYPE_NUMERIC) {
3063 fd = PerlLIO_open3_cloexec(path, imode, perm);
3067 bool appended = FALSE;
3069 /* Cygwin wants its 'b' early. */
3071 mode = PerlIOStdio_mode(mode, tmode);
3073 stdio = PerlSIO_fopen(path, mode);
3076 f = PerlIO_allocate(aTHX);
3079 mode = PerlIOStdio_mode(mode, tmode);
3080 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3082 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3084 PerlIOUnix_refcnt_inc(fd);
3085 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3087 PerlSIO_fclose(stdio);
3099 if (*mode == IoTYPE_IMPLICIT) {
3106 stdio = PerlSIO_stdin;
3109 stdio = PerlSIO_stdout;
3112 stdio = PerlSIO_stderr;
3117 stdio = PerlSIO_fdopen(fd, mode =
3118 PerlIOStdio_mode(mode, tmode));
3122 f = PerlIO_allocate(aTHX);
3124 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3125 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3127 PerlIOUnix_refcnt_inc(fd);
3128 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3139 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3141 /* This assumes no layers underneath - which is what
3142 happens, but is not how I remember it. NI-S 2001/10/16
3144 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3145 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3146 const int fd = fileno(stdio);
3148 if (flags & PERLIO_DUP_FD) {
3149 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
3151 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3156 /* FIXME: To avoid messy error recovery if dup fails
3157 re-use the existing stdio as though flag was not set
3161 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3163 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3165 int fd = fileno(stdio);
3166 PerlIOUnix_refcnt_inc(fd);
3167 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3174 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3176 PERL_UNUSED_CONTEXT;
3178 /* XXX this could use PerlIO_canset_fileno() and
3179 * PerlIO_set_fileno() support from Configure
3181 # if defined(HAS_FDCLOSE)
3182 return fdclose(f, NULL) == 0 ? 1 : 0;
3183 # elif defined(__UCLIBC__)
3184 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3187 # elif defined(__GLIBC__)
3188 /* There may be a better way for GLIBC:
3189 - libio.h defines a flag to not close() on cleanup
3193 # elif defined(__sun)
3196 # elif defined(__hpux)
3200 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3201 your platform does not have special entry try this one.
3202 [For OSF only have confirmation for Tru64 (alpha)
3203 but assume other OSFs will be similar.]
3205 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3208 # elif defined(__FreeBSD__)
3209 /* There may be a better way on FreeBSD:
3210 - we could insert a dummy func in the _close function entry
3211 f->_close = (int (*)(void *)) dummy_close;
3215 # elif defined(__OpenBSD__)
3216 /* There may be a better way on OpenBSD:
3217 - we could insert a dummy func in the _close function entry
3218 f->_close = (int (*)(void *)) dummy_close;
3222 # elif defined(__EMX__)
3223 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3226 # elif defined(__CYGWIN__)
3227 /* There may be a better way on CYGWIN:
3228 - we could insert a dummy func in the _close function entry
3229 f->_close = (int (*)(void *)) dummy_close;
3233 # elif defined(WIN32)
3234 # if defined(UNDER_CE)
3235 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3239 PERLIO_FILE_file(f) = -1;
3244 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3245 (which isn't thread safe) instead
3247 # error "Don't know how to set FILE.fileno on your platform"
3255 PerlIOStdio_close(pTHX_ PerlIO *f)
3257 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3263 const int fd = fileno(stdio);
3271 #ifdef SOCKS5_VERSION_NAME
3272 /* Socks lib overrides close() but stdio isn't linked to
3273 that library (though we are) - so we must call close()
3274 on sockets on stdio's behalf.
3277 Sock_size_t optlen = sizeof(int);
3278 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3281 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3282 that a subsequent fileno() on it returns -1. Don't want to croak()
3283 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3284 trying to close an already closed handle which somehow it still has
3285 a reference to. (via.xs, I'm looking at you). */
3286 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3287 /* File descriptor still in use */
3291 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3292 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3294 if (stdio == stdout || stdio == stderr)
3295 return PerlIO_flush(f);
3297 MUTEX_LOCK(&PL_perlio_mutex);
3298 /* Right. We need a mutex here because for a brief while we
3299 will have the situation that fd is actually closed. Hence if
3300 a second thread were to get into this block, its dup() would
3301 likely return our fd as its dupfd. (after all, it is closed)
3302 Then if we get to the dup2() first, we blat the fd back
3303 (messing up its temporary as a side effect) only for it to
3304 then close its dupfd (== our fd) in its close(dupfd) */
3306 /* There is, of course, a race condition, that any other thread
3307 trying to input/output/whatever on this fd will be stuffed
3308 for the duration of this little manoeuvrer. Perhaps we
3309 should hold an IO mutex for the duration of every IO
3310 operation if we know that invalidate doesn't work on this
3311 platform, but that would suck, and could kill performance.
3313 Except that correctness trumps speed.
3314 Advice from klortho #11912. */
3316 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3317 Use Sarathy's trick from maint-5.6 to invalidate the
3318 fileno slot of the FILE *
3320 result = PerlIO_flush(f);
3322 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3324 dupfd = PerlLIO_dup_cloexec(fd);
3327 /* Oh cXap. This isn't going to go well. Not sure if we can
3328 recover from here, or if closing this particular FILE *
3329 is a good idea now. */
3334 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3336 result = PerlSIO_fclose(stdio);
3337 /* We treat error from stdio as success if we invalidated
3338 errno may NOT be expected EBADF
3340 if (invalidate && result != 0) {
3344 #ifdef SOCKS5_VERSION_NAME
3345 /* in SOCKS' case, let close() determine return value */
3349 PerlLIO_dup2_cloexec(dupfd, fd);
3350 setfd_inhexec_for_sysfd(fd);
3351 PerlLIO_close(dupfd);
3353 MUTEX_UNLOCK(&PL_perlio_mutex);
3359 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3363 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3365 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3368 STDCHAR *buf = (STDCHAR *) vbuf;
3370 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3371 * stdio does not do that for fread()
3373 const int ch = PerlSIO_fgetc(s);
3380 got = PerlSIO_fread(vbuf, 1, count, s);
3381 if (got == 0 && PerlSIO_ferror(s))
3383 if (got >= 0 || errno != EINTR)
3385 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3387 SETERRNO(0,0); /* just in case */
3390 /* Under some circumstances IRIX stdio fgetc() and fread()
3391 * set the errno to ENOENT, which makes no sense according
3392 * to either IRIX or POSIX. [rt.perl.org #123977] */
3393 if (errno == ENOENT) SETERRNO(0,0);
3399 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3402 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3404 #ifdef STDIO_BUFFER_WRITABLE
3405 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3406 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3407 STDCHAR *base = PerlIO_get_base(f);
3408 SSize_t cnt = PerlIO_get_cnt(f);
3409 STDCHAR *ptr = PerlIO_get_ptr(f);
3410 SSize_t avail = ptr - base;
3412 if (avail > count) {
3416 Move(buf-avail,ptr,avail,STDCHAR);
3419 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3420 if (PerlSIO_feof(s) && unread >= 0)
3421 PerlSIO_clearerr(s);
3426 if (PerlIO_has_cntptr(f)) {
3427 /* We can get pointer to buffer but not its base
3428 Do ungetc() but check chars are ending up in the
3431 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3432 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3434 const int ch = *--buf & 0xFF;
3435 if (ungetc(ch,s) != ch) {
3436 /* ungetc did not work */
3439 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3440 /* Did not change pointer as expected */
3441 if (fgetc(s) != EOF) /* get char back again */
3451 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3457 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3460 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3463 got = PerlSIO_fwrite(vbuf, 1, count,
3464 PerlIOSelf(f, PerlIOStdio)->stdio);
3465 if (got >= 0 || errno != EINTR)
3467 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3469 SETERRNO(0,0); /* just in case */
3475 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3477 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3478 PERL_UNUSED_CONTEXT;
3480 return PerlSIO_fseek(stdio, offset, whence);
3484 PerlIOStdio_tell(pTHX_ PerlIO *f)
3486 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3487 PERL_UNUSED_CONTEXT;
3489 return PerlSIO_ftell(stdio);
3493 PerlIOStdio_flush(pTHX_ PerlIO *f)
3495 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3496 PERL_UNUSED_CONTEXT;
3498 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3499 return PerlSIO_fflush(stdio);
3505 * FIXME: This discards ungetc() and pre-read stuff which is not
3506 * right if this is just a "sync" from a layer above Suspect right
3507 * design is to do _this_ but not have layer above flush this
3508 * layer read-to-read
3511 * Not writeable - sync by attempting a seek
3514 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3522 PerlIOStdio_eof(pTHX_ PerlIO *f)
3524 PERL_UNUSED_CONTEXT;
3526 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3530 PerlIOStdio_error(pTHX_ PerlIO *f)
3532 PERL_UNUSED_CONTEXT;
3534 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3538 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3540 PERL_UNUSED_CONTEXT;
3542 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3546 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3548 PERL_UNUSED_CONTEXT;
3550 #ifdef HAS_SETLINEBUF
3551 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3553 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3559 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3561 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3562 PERL_UNUSED_CONTEXT;
3563 return (STDCHAR*)PerlSIO_get_base(stdio);
3567 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3569 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3570 PERL_UNUSED_CONTEXT;
3571 return PerlSIO_get_bufsiz(stdio);
3575 #ifdef USE_STDIO_PTR
3577 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3579 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3580 PERL_UNUSED_CONTEXT;
3581 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3585 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3587 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3588 PERL_UNUSED_CONTEXT;
3589 return PerlSIO_get_cnt(stdio);
3593 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3595 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3596 PERL_UNUSED_CONTEXT;
3598 #ifdef STDIO_PTR_LVALUE
3599 /* This is a long-standing infamous mess. The root of the
3600 * problem is that one cannot know the signedness of char, and
3601 * more precisely the signedness of FILE._ptr. The following
3602 * things have been tried, and they have all failed (across
3603 * different compilers (remember that core needs to to build
3604 * also with c++) and compiler options:
3606 * - casting the RHS to (void*) -- works in *some* places
3607 * - casting the LHS to (void*) -- totally unportable
3609 * So let's try silencing the warning at least for gcc. */
3610 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
3611 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3612 GCC_DIAG_RESTORE_STMT;
3613 #ifdef STDIO_PTR_LVAL_SETS_CNT
3614 assert(PerlSIO_get_cnt(stdio) == (cnt));
3616 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3618 * Setting ptr _does_ change cnt - we are done
3622 #else /* STDIO_PTR_LVALUE */
3624 #endif /* STDIO_PTR_LVALUE */
3627 * Now (or only) set cnt
3629 #ifdef STDIO_CNT_LVALUE
3630 PerlSIO_set_cnt(stdio, cnt);
3631 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3632 PerlSIO_set_ptr(stdio,
3633 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3635 #else /* STDIO_PTR_LVAL_SETS_CNT */
3637 #endif /* STDIO_CNT_LVALUE */
3644 PerlIOStdio_fill(pTHX_ PerlIO *f)
3648 PERL_UNUSED_CONTEXT;
3649 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3651 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3654 * fflush()ing read-only streams can cause trouble on some stdio-s
3656 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3657 if (PerlSIO_fflush(stdio) != 0)
3661 c = PerlSIO_fgetc(stdio);
3664 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3666 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3671 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3673 #ifdef STDIO_BUFFER_WRITABLE
3674 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3675 /* Fake ungetc() to the real buffer in case system's ungetc
3678 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3679 SSize_t cnt = PerlSIO_get_cnt(stdio);
3680 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3681 if (ptr == base+1) {
3682 *--ptr = (STDCHAR) c;
3683 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3684 if (PerlSIO_feof(stdio))
3685 PerlSIO_clearerr(stdio);
3691 if (PerlIO_has_cntptr(f)) {
3693 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3699 /* If buffer snoop scheme above fails fall back to
3702 if (PerlSIO_ungetc(c, stdio) != c)
3710 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3711 sizeof(PerlIO_funcs),
3713 sizeof(PerlIOStdio),
3714 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3718 PerlIOBase_binmode, /* binmode */
3732 PerlIOStdio_clearerr,
3733 PerlIOStdio_setlinebuf,
3735 PerlIOStdio_get_base,
3736 PerlIOStdio_get_bufsiz,
3741 #ifdef USE_STDIO_PTR
3742 PerlIOStdio_get_ptr,
3743 PerlIOStdio_get_cnt,
3744 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3745 PerlIOStdio_set_ptrcnt,
3748 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3753 #endif /* USE_STDIO_PTR */
3756 /* Note that calls to PerlIO_exportFILE() are reversed using
3757 * PerlIO_releaseFILE(), not importFILE. */
3759 PerlIO_exportFILE(PerlIO * f, const char *mode)
3763 if (PerlIOValid(f)) {
3765 int fd = PerlIO_fileno(f);
3770 if (!mode || !*mode) {
3771 mode = PerlIO_modestr(f, buf);
3773 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3777 /* De-link any lower layers so new :stdio sticks */
3779 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3780 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3782 PerlIOUnix_refcnt_inc(fileno(stdio));
3783 /* Link previous lower layers under new one */
3787 /* restore layers list */
3797 PerlIO_findFILE(PerlIO *f)
3802 if (l->tab == &PerlIO_stdio) {
3803 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3806 l = *PerlIONext(&l);
3808 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3809 /* However, we're not really exporting a FILE * to someone else (who
3810 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3811 So we need to undo its reference count increase on the underlying file
3812 descriptor. We have to do this, because if the loop above returns you
3813 the FILE *, then *it* didn't increase any reference count. So there's
3814 only one way to be consistent. */
3815 stdio = PerlIO_exportFILE(f, NULL);
3817 const int fd = fileno(stdio);
3819 PerlIOUnix_refcnt_dec(fd);
3824 /* Use this to reverse PerlIO_exportFILE calls. */
3826 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3830 if (l->tab == &PerlIO_stdio) {
3831 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3832 if (s->stdio == f) { /* not in a loop */
3833 const int fd = fileno(f);
3835 PerlIOUnix_refcnt_dec(fd);
3838 PerlIO_pop(aTHX_ p);
3848 /*--------------------------------------------------------------------------------------*/
3850 * perlio buffer layer
3854 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3856 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3857 const int fd = PerlIO_fileno(f);
3858 if (fd >= 0 && PerlLIO_isatty(fd)) {
3859 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3861 if (*PerlIONext(f)) {
3862 const Off_t posn = PerlIO_tell(PerlIONext(f));
3863 if (posn != (Off_t) - 1) {
3867 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3871 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3872 IV n, const char *mode, int fd, int imode, int perm,
3873 PerlIO *f, int narg, SV **args)
3875 if (PerlIOValid(f)) {
3876 PerlIO *next = PerlIONext(f);
3878 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3879 if (tab && tab->Open)
3881 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3883 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3888 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3890 if (*mode == IoTYPE_IMPLICIT) {
3896 if (tab && tab->Open)
3897 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3900 SETERRNO(EINVAL, LIB_INVARG);
3902 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3904 * if push fails during open, open fails. close will pop us.
3909 fd = PerlIO_fileno(f);
3910 if (init && fd == 2) {
3912 * Initial stderr is unbuffered
3914 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3916 #ifdef PERLIO_USING_CRLF
3917 # ifdef PERLIO_IS_BINMODE_FD
3918 if (PERLIO_IS_BINMODE_FD(fd))
3919 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3923 * do something about failing setmode()? --jhi
3925 PerlLIO_setmode(fd, O_BINARY);
3928 /* Enable line buffering with record-oriented regular files
3929 * so we don't introduce an extraneous record boundary when
3930 * the buffer fills up.
3932 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3934 if (PerlLIO_fstat(fd, &st) == 0
3935 && S_ISREG(st.st_mode)
3936 && (st.st_fab_rfm == FAB$C_VAR
3937 || st.st_fab_rfm == FAB$C_VFC)) {
3938 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3949 * This "flush" is akin to sfio's sync in that it handles files in either
3950 * read or write state. For write state, we put the postponed data through
3951 * the next layers. For read state, we seek() the next layers to the
3952 * offset given by current position in the buffer, and discard the buffer
3953 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3954 * in any case?). Then the pass the stick further in chain.
3957 PerlIOBuf_flush(pTHX_ PerlIO *f)
3959 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3961 PerlIO *n = PerlIONext(f);
3962 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3964 * write() the buffer
3966 const STDCHAR *buf = b->buf;
3967 const STDCHAR *p = buf;
3968 while (p < b->ptr) {
3969 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3973 else if (count < 0 || PerlIO_error(n)) {
3974 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3975 PerlIO_save_errno(f);
3980 b->posn += (p - buf);
3982 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3983 STDCHAR *buf = PerlIO_get_base(f);
3985 * Note position change
3987 b->posn += (b->ptr - buf);
3988 if (b->ptr < b->end) {
3989 /* We did not consume all of it - try and seek downstream to
3990 our logical position
3992 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3993 /* Reload n as some layers may pop themselves on seek */
3994 b->posn = PerlIO_tell(n = PerlIONext(f));
3997 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3998 data is lost for good - so return saying "ok" having undone
4001 b->posn -= (b->ptr - buf);
4006 b->ptr = b->end = b->buf;
4007 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4008 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4009 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4014 /* This discards the content of the buffer after b->ptr, and rereads
4015 * the buffer from the position off in the layer downstream; here off
4016 * is at offset corresponding to b->ptr - b->buf.
4019 PerlIOBuf_fill(pTHX_ PerlIO *f)
4021 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4022 PerlIO *n = PerlIONext(f);
4025 * Down-stream flush is defined not to loose read data so is harmless.
4026 * we would not normally be fill'ing if there was data left in anycase.
4028 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4030 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4031 PerlIOBase_flush_linebuf(aTHX);
4034 PerlIO_get_base(f); /* allocate via vtable */
4036 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4038 b->ptr = b->end = b->buf;
4040 if (!PerlIOValid(n)) {
4041 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4045 if (PerlIO_fast_gets(n)) {
4047 * Layer below is also buffered. We do _NOT_ want to call its
4048 * ->Read() because that will loop till it gets what we asked for
4049 * which may hang on a pipe etc. Instead take anything it has to
4050 * hand, or ask it to fill _once_.
4052 avail = PerlIO_get_cnt(n);
4054 avail = PerlIO_fill(n);
4056 avail = PerlIO_get_cnt(n);
4058 if (!PerlIO_error(n) && PerlIO_eof(n))
4063 STDCHAR *ptr = PerlIO_get_ptr(n);
4064 const SSize_t cnt = avail;
4065 if (avail > (SSize_t)b->bufsiz)
4067 Copy(ptr, b->buf, avail, STDCHAR);
4068 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4072 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4076 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4079 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4080 PerlIO_save_errno(f);
4084 b->end = b->buf + avail;
4085 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4090 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4092 if (PerlIOValid(f)) {
4093 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4096 return PerlIOBase_read(aTHX_ f, vbuf, count);
4102 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4104 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4105 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4108 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4113 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4115 * Buffer is already a read buffer, we can overwrite any chars
4116 * which have been read back to buffer start
4118 avail = (b->ptr - b->buf);
4122 * Buffer is idle, set it up so whole buffer is available for
4126 b->end = b->buf + avail;
4128 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4130 * Buffer extends _back_ from where we are now
4132 b->posn -= b->bufsiz;
4134 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4136 * If we have space for more than count, just move count
4144 * In simple stdio-like ungetc() case chars will be already
4147 if (buf != b->ptr) {
4148 Copy(buf, b->ptr, avail, STDCHAR);
4152 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4156 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4162 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4164 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4165 const STDCHAR *buf = (const STDCHAR *) vbuf;
4166 const STDCHAR *flushptr = buf;
4170 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4172 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4173 if (PerlIO_flush(f) != 0) {
4177 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4178 flushptr = buf + count;
4179 while (flushptr > buf && *(flushptr - 1) != '\n')
4183 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4184 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4186 if (flushptr > buf && flushptr <= buf + avail)
4187 avail = flushptr - buf;
4188 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4190 Copy(buf, b->ptr, avail, STDCHAR);
4195 if (buf == flushptr)
4198 if (b->ptr >= (b->buf + b->bufsiz))
4199 if (PerlIO_flush(f) == -1)
4202 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4208 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4211 if ((code = PerlIO_flush(f)) == 0) {
4212 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4213 code = PerlIO_seek(PerlIONext(f), offset, whence);
4215 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4216 b->posn = PerlIO_tell(PerlIONext(f));
4223 PerlIOBuf_tell(pTHX_ PerlIO *f)
4225 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4227 * b->posn is file position where b->buf was read, or will be written
4229 Off_t posn = b->posn;
4230 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4231 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4233 /* As O_APPEND files are normally shared in some sense it is better
4238 /* when file is NOT shared then this is sufficient */
4239 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4241 posn = b->posn = PerlIO_tell(PerlIONext(f));
4245 * If buffer is valid adjust position by amount in buffer
4247 posn += (b->ptr - b->buf);
4253 PerlIOBuf_popped(pTHX_ PerlIO *f)
4255 const IV code = PerlIOBase_popped(aTHX_ f);
4256 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4257 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4260 b->ptr = b->end = b->buf = NULL;
4261 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4266 PerlIOBuf_close(pTHX_ PerlIO *f)
4268 const IV code = PerlIOBase_close(aTHX_ f);
4269 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4270 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4273 b->ptr = b->end = b->buf = NULL;
4274 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4279 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4281 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4288 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4290 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4293 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4294 return (b->end - b->ptr);
4299 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4301 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4302 PERL_UNUSED_CONTEXT;
4306 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4307 Newx(b->buf,b->bufsiz, STDCHAR);
4309 b->buf = (STDCHAR *) & b->oneword;
4310 b->bufsiz = sizeof(b->oneword);
4312 b->end = b->ptr = b->buf;
4318 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4320 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4323 return (b->end - b->buf);
4327 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4329 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4331 PERL_UNUSED_ARG(cnt);
4336 assert(PerlIO_get_cnt(f) == cnt);
4337 assert(b->ptr >= b->buf);
4338 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4342 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4344 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4349 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4350 sizeof(PerlIO_funcs),
4353 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4357 PerlIOBase_binmode, /* binmode */
4371 PerlIOBase_clearerr,
4372 PerlIOBase_setlinebuf,
4377 PerlIOBuf_set_ptrcnt,
4380 /*--------------------------------------------------------------------------------------*/
4382 * Temp layer to hold unread chars when cannot do it any other way
4386 PerlIOPending_fill(pTHX_ PerlIO *f)
4389 * Should never happen
4396 PerlIOPending_close(pTHX_ PerlIO *f)
4399 * A tad tricky - flush pops us, then we close new top
4402 return PerlIO_close(f);
4406 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4409 * A tad tricky - flush pops us, then we seek new top
4412 return PerlIO_seek(f, offset, whence);
4417 PerlIOPending_flush(pTHX_ PerlIO *f)
4419 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4420 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4424 PerlIO_pop(aTHX_ f);
4429 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4435 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4440 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4442 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4443 PerlIOl * const l = PerlIOBase(f);
4445 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4446 * etc. get muddled when it changes mid-string when we auto-pop.
4448 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4449 (PerlIOBase(PerlIONext(f))->
4450 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4455 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4457 SSize_t avail = PerlIO_get_cnt(f);
4459 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4462 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4463 if (got >= 0 && got < (SSize_t)count) {
4464 const SSize_t more =
4465 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4466 if (more >= 0 || got == 0)
4472 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4473 sizeof(PerlIO_funcs),
4476 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4477 PerlIOPending_pushed,
4480 PerlIOBase_binmode, /* binmode */
4489 PerlIOPending_close,
4490 PerlIOPending_flush,
4494 PerlIOBase_clearerr,
4495 PerlIOBase_setlinebuf,
4500 PerlIOPending_set_ptrcnt,
4505 /*--------------------------------------------------------------------------------------*/
4507 * crlf - translation On read translate CR,LF to "\n" we do this by
4508 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4509 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4511 * c->nl points on the first byte of CR LF pair when it is temporarily
4512 * replaced by LF, or to the last CR of the buffer. In the former case
4513 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4514 * that it ends at c->nl; these two cases can be distinguished by
4515 * *c->nl. c->nl is set during _getcnt() call, and unset during
4516 * _unread() and _flush() calls.
4517 * It only matters for read operations.
4521 PerlIOBuf base; /* PerlIOBuf stuff */
4522 STDCHAR *nl; /* Position of crlf we "lied" about in the
4526 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4527 * Otherwise the :crlf layer would always revert back to
4531 S_inherit_utf8_flag(PerlIO *f)
4533 PerlIO *g = PerlIONext(f);
4534 if (PerlIOValid(g)) {
4535 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4536 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4542 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4545 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4546 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4549 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4550 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4551 PerlIOBase(f)->flags);
4555 /* If the old top layer is a CRLF layer, reactivate it (if
4556 * necessary) and remove this new layer from the stack */
4557 PerlIO *g = PerlIONext(f);
4558 if (PerlIOValid(g)) {
4559 PerlIOl *b = PerlIOBase(g);
4560 if (b && b->tab == &PerlIO_crlf) {
4561 if (!(b->flags & PERLIO_F_CRLF))
4562 b->flags |= PERLIO_F_CRLF;
4563 S_inherit_utf8_flag(g);
4564 PerlIO_pop(aTHX_ f);
4569 S_inherit_utf8_flag(f);
4575 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4577 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4578 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4579 *(c->nl) = NATIVE_0xd;
4582 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4583 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4585 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4586 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4588 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4593 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4594 b->end = b->ptr = b->buf + b->bufsiz;
4595 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4596 b->posn -= b->bufsiz;
4598 while (count > 0 && b->ptr > b->buf) {
4599 const int ch = *--buf;
4601 if (b->ptr - 2 >= b->buf) {
4602 *--(b->ptr) = NATIVE_0xa;
4603 *--(b->ptr) = NATIVE_0xd;
4608 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4609 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4623 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4628 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4630 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4632 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4635 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4636 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4637 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4638 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4640 while (nl < b->end && *nl != NATIVE_0xd)
4642 if (nl < b->end && *nl == NATIVE_0xd) {
4644 if (nl + 1 < b->end) {
4645 if (nl[1] == NATIVE_0xa) {
4651 * Not CR,LF but just CR
4659 * Blast - found CR as last char in buffer
4664 * They may not care, defer work as long as
4668 return (nl - b->ptr);
4672 b->ptr++; /* say we have read it as far as
4673 * flush() is concerned */
4674 b->buf++; /* Leave space in front of buffer */
4675 /* Note as we have moved buf up flush's
4677 will naturally make posn point at CR
4679 b->bufsiz--; /* Buffer is thus smaller */
4680 code = PerlIO_fill(f); /* Fetch some more */
4681 b->bufsiz++; /* Restore size for next time */
4682 b->buf--; /* Point at space */
4683 b->ptr = nl = b->buf; /* Which is what we hand
4685 *nl = NATIVE_0xd; /* Fill in the CR */
4687 goto test; /* fill() call worked */
4689 * CR at EOF - just fall through
4691 /* Should we clear EOF though ??? */
4696 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4702 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4704 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4705 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4711 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4712 /* Deferred CR at end of buffer case - we lied about count */
4725 * Test code - delete when it works ...
4727 IV flags = PerlIOBase(f)->flags;
4728 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4729 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4730 /* Deferred CR at end of buffer case - we lied about count */
4736 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4737 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4738 flags, c->nl, b->end, cnt);
4745 * They have taken what we lied about
4747 *(c->nl) = NATIVE_0xd;
4753 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4757 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4759 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4760 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4762 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4763 const STDCHAR *buf = (const STDCHAR *) vbuf;
4764 const STDCHAR * const ebuf = buf + count;
4767 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4769 while (buf < ebuf) {
4770 const STDCHAR * const eptr = b->buf + b->bufsiz;
4771 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4772 while (buf < ebuf && b->ptr < eptr) {
4774 if ((b->ptr + 2) > eptr) {
4782 *(b->ptr)++ = NATIVE_0xd; /* CR */
4783 *(b->ptr)++ = NATIVE_0xa; /* LF */
4785 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4792 *(b->ptr)++ = *buf++;
4794 if (b->ptr >= eptr) {
4800 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4802 return (buf - (STDCHAR *) vbuf);
4807 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4809 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4811 *(c->nl) = NATIVE_0xd;
4814 return PerlIOBuf_flush(aTHX_ f);
4818 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4820 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4821 /* In text mode - flush any pending stuff and flip it */
4822 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4823 #ifndef PERLIO_USING_CRLF
4824 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4825 PerlIO_pop(aTHX_ f);
4831 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4832 sizeof(PerlIO_funcs),
4835 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4837 PerlIOBuf_popped, /* popped */
4839 PerlIOCrlf_binmode, /* binmode */
4843 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4844 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4845 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4853 PerlIOBase_clearerr,
4854 PerlIOBase_setlinebuf,
4859 PerlIOCrlf_set_ptrcnt,
4863 Perl_PerlIO_stdin(pTHX)
4866 PerlIO_stdstreams(aTHX);
4868 return (PerlIO*)&PL_perlio[1];
4872 Perl_PerlIO_stdout(pTHX)
4875 PerlIO_stdstreams(aTHX);
4877 return (PerlIO*)&PL_perlio[2];
4881 Perl_PerlIO_stderr(pTHX)
4884 PerlIO_stdstreams(aTHX);
4886 return (PerlIO*)&PL_perlio[3];
4889 /*--------------------------------------------------------------------------------------*/
4892 PerlIO_getname(PerlIO *f, char *buf)
4897 bool exported = FALSE;
4898 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4900 stdio = PerlIO_exportFILE(f,0);
4904 name = fgetname(stdio, buf);
4905 if (exported) PerlIO_releaseFILE(f,stdio);
4910 PERL_UNUSED_ARG(buf);
4911 Perl_croak_nocontext("Don't know how to get file name");
4917 /*--------------------------------------------------------------------------------------*/
4919 * Functions which can be called on any kind of PerlIO implemented in
4923 #undef PerlIO_fdopen
4925 PerlIO_fdopen(int fd, const char *mode)
4928 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4933 PerlIO_open(const char *path, const char *mode)
4936 SV *name = sv_2mortal(newSVpv(path, 0));
4937 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4940 #undef Perlio_reopen
4942 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4945 SV *name = sv_2mortal(newSVpv(path,0));
4946 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4951 PerlIO_getc(PerlIO *f)
4955 if ( 1 == PerlIO_read(f, buf, 1) ) {
4956 return (unsigned char) buf[0];
4961 #undef PerlIO_ungetc
4963 PerlIO_ungetc(PerlIO *f, int ch)
4968 if (PerlIO_unread(f, &buf, 1) == 1)
4976 PerlIO_putc(PerlIO *f, int ch)
4980 return PerlIO_write(f, &buf, 1);
4985 PerlIO_puts(PerlIO *f, const char *s)
4988 return PerlIO_write(f, s, strlen(s));
4991 #undef PerlIO_rewind
4993 PerlIO_rewind(PerlIO *f)
4996 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5000 #undef PerlIO_vprintf
5002 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5011 Perl_va_copy(ap, apc);
5012 sv = vnewSVpvf(fmt, &apc);
5015 sv = vnewSVpvf(fmt, &ap);
5017 s = SvPV_const(sv, len);
5018 wrote = PerlIO_write(f, s, len);
5023 #undef PerlIO_printf
5025 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5030 result = PerlIO_vprintf(f, fmt, ap);
5035 #undef PerlIO_stdoutf
5037 PerlIO_stdoutf(const char *fmt, ...)
5043 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5048 #undef PerlIO_tmpfile
5050 PerlIO_tmpfile(void)
5057 const int fd = win32_tmpfd();
5059 f = PerlIO_fdopen(fd, "w+b");
5060 #elif ! defined(VMS) && ! defined(OS2)
5062 char tempname[] = "/tmp/PerlIO_XXXXXX";
5063 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5065 int old_umask = umask(0177);
5066 if (tmpdir && *tmpdir) {
5067 /* if TMPDIR is set and not empty, we try that first */
5068 sv = newSVpv(tmpdir, 0);
5069 sv_catpv(sv, tempname + 4);
5070 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
5075 /* else we try /tmp */
5076 fd = Perl_my_mkstemp_cloexec(tempname);
5081 sv_catpv(sv, tempname + 4);
5082 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
5086 f = PerlIO_fdopen(fd, "w+");
5088 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5089 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5092 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5093 FILE * const stdio = PerlSIO_tmpfile();
5096 f = PerlIO_fdopen(fileno(stdio), "w+");
5098 #endif /* else WIN32 */
5103 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5105 PERL_UNUSED_CONTEXT;
5106 if (!PerlIOValid(f))
5108 PerlIOBase(f)->err = errno;
5110 PerlIOBase(f)->os_err = vaxc$errno;
5112 PerlIOBase(f)->os_err = Perl_rc;
5113 #elif defined(WIN32)
5114 PerlIOBase(f)->os_err = GetLastError();
5119 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5121 PERL_UNUSED_CONTEXT;
5122 if (!PerlIOValid(f))
5124 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5126 Perl_rc = PerlIOBase(f)->os_err);
5127 #elif defined(WIN32)
5128 SetLastError(PerlIOBase(f)->os_err);
5136 /*======================================================================================*/
5138 * Now some functions in terms of above which may be needed even if we are
5139 * not in true PerlIO mode
5142 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5144 const char *direction = NULL;
5147 * Need to supply default layer info from open.pm
5153 if (mode && mode[0] != 'r') {
5154 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5155 direction = "open>";
5157 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5158 direction = "open<";
5163 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5166 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5171 #undef PerlIO_setpos
5173 PerlIO_setpos(PerlIO *f, SV *pos)
5179 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5180 if(len == sizeof(Off_t))
5181 return PerlIO_seek(f, *posn, SEEK_SET);
5184 SETERRNO(EINVAL, SS_IVCHAN);
5188 #undef PerlIO_setpos
5190 PerlIO_setpos(PerlIO *f, SV *pos)
5196 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5197 if(len == sizeof(Fpos_t))
5198 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5199 return fsetpos64(f, fpos);
5201 return fsetpos(f, fpos);
5205 SETERRNO(EINVAL, SS_IVCHAN);
5211 #undef PerlIO_getpos
5213 PerlIO_getpos(PerlIO *f, SV *pos)
5216 Off_t posn = PerlIO_tell(f);
5217 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5218 return (posn == (Off_t) - 1) ? -1 : 0;
5221 #undef PerlIO_getpos
5223 PerlIO_getpos(PerlIO *f, SV *pos)
5228 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5229 code = fgetpos64(f, &fpos);
5231 code = fgetpos(f, &fpos);
5233 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5238 /* print a failure format string message to stderr and fail exit the process
5239 using only libc without depending on any perl data structures being
5244 Perl_noperl_die(const char* pat, ...)
5247 PERL_ARGS_ASSERT_NOPERL_DIE;
5248 va_start(arglist, pat);
5249 vfprintf(stderr, pat, arglist);
5255 * ex: set ts=8 sts=4 sw=4 et: