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 imode = PerlIOUnix_oflags(mode);
1495 if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
1496 if (!layers || !*layers)
1497 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1498 if (layers && *layers)
1499 PerlIO_apply_layers(aTHX_ f, mode, layers);
1503 PerlIO_list_t *layera;
1505 PerlIO_funcs *tab = NULL;
1506 if (PerlIOValid(f)) {
1508 * This is "reopen" - it is not tested as perl does not use it
1512 layera = PerlIO_list_alloc(aTHX);
1515 if (l->tab && l->tab->Getarg)
1516 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1517 PerlIO_list_push(aTHX_ layera, l->tab,
1518 (arg) ? arg : &PL_sv_undef);
1520 l = *PerlIONext(&l);
1524 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1530 * Start at "top" of layer stack
1532 n = layera->cur - 1;
1534 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1543 * Found that layer 'n' can do opens - call it
1545 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1546 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1548 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1549 tab->name, layers ? layers : "(Null)", mode, fd,
1550 imode, perm, (void*)f, narg, (void*)args) );
1552 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1555 SETERRNO(EINVAL, LIB_INVARG);
1559 if (n + 1 < layera->cur) {
1561 * More layers above the one that we used to open -
1564 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1565 /* If pushing layers fails close the file */
1572 PerlIO_list_free(aTHX_ layera);
1579 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1581 PERL_ARGS_ASSERT_PERLIO_READ;
1583 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1587 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1589 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1591 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1595 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1597 PERL_ARGS_ASSERT_PERLIO_WRITE;
1599 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1603 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1605 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1609 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1611 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1615 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1619 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1621 if (tab && tab->Flush)
1622 return (*tab->Flush) (aTHX_ f);
1624 return 0; /* If no Flush defined, silently succeed. */
1627 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1628 SETERRNO(EBADF, SS_IVCHAN);
1634 * Is it good API design to do flush-all on NULL, a potentially
1635 * erroneous input? Maybe some magical value (PerlIO*
1636 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1637 * things on fflush(NULL), but should we be bound by their design
1640 PerlIOl **table = &PL_perlio;
1643 while ((ff = *table)) {
1645 table = (PerlIOl **) (ff++);
1646 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1647 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1657 PerlIOBase_flush_linebuf(pTHX)
1659 PerlIOl **table = &PL_perlio;
1661 while ((f = *table)) {
1663 table = (PerlIOl **) (f++);
1664 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1666 && (PerlIOBase(&(f->next))->
1667 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1668 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1669 PerlIO_flush(&(f->next));
1676 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1678 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1682 PerlIO_isutf8(PerlIO *f)
1685 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1687 SETERRNO(EBADF, SS_IVCHAN);
1693 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1695 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1699 Perl_PerlIO_error(pTHX_ PerlIO *f)
1701 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1705 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1707 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1711 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1713 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1717 PerlIO_has_base(PerlIO *f)
1719 if (PerlIOValid(f)) {
1720 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1723 return (tab->Get_base != NULL);
1730 PerlIO_fast_gets(PerlIO *f)
1732 if (PerlIOValid(f)) {
1733 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1734 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1737 return (tab->Set_ptrcnt != NULL);
1745 PerlIO_has_cntptr(PerlIO *f)
1747 if (PerlIOValid(f)) {
1748 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1751 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1758 PerlIO_canset_cnt(PerlIO *f)
1760 if (PerlIOValid(f)) {
1761 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1764 return (tab->Set_ptrcnt != NULL);
1771 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1773 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1777 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1779 /* Note that Get_bufsiz returns a Size_t */
1780 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1784 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1786 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1790 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1792 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1796 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1798 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1802 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1804 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1808 /*--------------------------------------------------------------------------------------*/
1810 * utf8 and raw dummy layers
1814 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1816 PERL_UNUSED_CONTEXT;
1817 PERL_UNUSED_ARG(mode);
1818 PERL_UNUSED_ARG(arg);
1819 if (PerlIOValid(f)) {
1820 if (tab && tab->kind & PERLIO_K_UTF8)
1821 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1823 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1829 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1830 sizeof(PerlIO_funcs),
1833 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1853 NULL, /* get_base */
1854 NULL, /* get_bufsiz */
1857 NULL, /* set_ptrcnt */
1860 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1861 sizeof(PerlIO_funcs),
1864 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1884 NULL, /* get_base */
1885 NULL, /* get_bufsiz */
1888 NULL, /* set_ptrcnt */
1891 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1892 sizeof(PerlIO_funcs),
1915 NULL, /* get_base */
1916 NULL, /* get_bufsiz */
1919 NULL, /* set_ptrcnt */
1921 /*--------------------------------------------------------------------------------------*/
1922 /*--------------------------------------------------------------------------------------*/
1924 * "Methods" of the "base class"
1928 PerlIOBase_fileno(pTHX_ PerlIO *f)
1930 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1934 PerlIO_modestr(PerlIO * f, char *buf)
1937 if (PerlIOValid(f)) {
1938 const IV flags = PerlIOBase(f)->flags;
1939 if (flags & PERLIO_F_APPEND) {
1941 if (flags & PERLIO_F_CANREAD) {
1945 else if (flags & PERLIO_F_CANREAD) {
1947 if (flags & PERLIO_F_CANWRITE)
1950 else if (flags & PERLIO_F_CANWRITE) {
1952 if (flags & PERLIO_F_CANREAD) {
1956 #ifdef PERLIO_USING_CRLF
1957 if (!(flags & PERLIO_F_CRLF))
1967 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1969 PerlIOl * const l = PerlIOBase(f);
1970 PERL_UNUSED_CONTEXT;
1971 PERL_UNUSED_ARG(arg);
1973 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1974 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1975 if (tab && tab->Set_ptrcnt != NULL)
1976 l->flags |= PERLIO_F_FASTGETS;
1978 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1982 l->flags |= PERLIO_F_CANREAD;
1985 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1988 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1991 SETERRNO(EINVAL, LIB_INVARG);
1996 /* The mode variable contains one positional parameter followed by
1997 * optional keyword parameters. The positional parameters must be
1998 * passed as lowercase characters. The keyword parameters can be
1999 * passed in mixed case. They must be separated by commas. Only one
2000 * instance of a keyword can be specified. */
2006 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2010 l->flags &= ~PERLIO_F_CRLF;
2014 l->flags |= PERLIO_F_CRLF;
2028 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2031 l->flags &= ~PERLIO_F_CRLF;
2034 l->flags |= PERLIO_F_CRLF;
2037 SETERRNO(EINVAL, LIB_INVARG);
2045 l->flags |= l->next->flags &
2046 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2052 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2053 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2054 l->flags, PerlIO_modestr(f, temp));
2061 PerlIOBase_popped(pTHX_ PerlIO *f)
2063 PERL_UNUSED_CONTEXT;
2069 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2072 * Save the position as current head considers it
2074 const Off_t old = PerlIO_tell(f);
2075 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2076 PerlIOSelf(f, PerlIOBuf)->posn = old;
2077 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2081 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2083 STDCHAR *buf = (STDCHAR *) vbuf;
2085 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2086 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2087 SETERRNO(EBADF, SS_IVCHAN);
2088 PerlIO_save_errno(f);
2094 SSize_t avail = PerlIO_get_cnt(f);
2097 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2099 STDCHAR *ptr = PerlIO_get_ptr(f);
2100 Copy(ptr, buf, take, STDCHAR);
2101 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2104 if (avail == 0) /* set_ptrcnt could have reset avail */
2107 if (count > 0 && avail <= 0) {
2108 if (PerlIO_fill(f) != 0)
2113 return (buf - (STDCHAR *) vbuf);
2119 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2121 PERL_UNUSED_CONTEXT;
2127 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2129 PERL_UNUSED_CONTEXT;
2135 PerlIOBase_close(pTHX_ PerlIO *f)
2138 if (PerlIOValid(f)) {
2139 PerlIO *n = PerlIONext(f);
2140 code = PerlIO_flush(f);
2141 PerlIOBase(f)->flags &=
2142 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2143 while (PerlIOValid(n)) {
2144 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2145 if (tab && tab->Close) {
2146 if ((*tab->Close)(aTHX_ n) != 0)
2151 PerlIOBase(n)->flags &=
2152 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2158 SETERRNO(EBADF, SS_IVCHAN);
2164 PerlIOBase_eof(pTHX_ PerlIO *f)
2166 PERL_UNUSED_CONTEXT;
2167 if (PerlIOValid(f)) {
2168 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2174 PerlIOBase_error(pTHX_ PerlIO *f)
2176 PERL_UNUSED_CONTEXT;
2177 if (PerlIOValid(f)) {
2178 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2184 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2186 if (PerlIOValid(f)) {
2187 PerlIO * const n = PerlIONext(f);
2188 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2195 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2197 PERL_UNUSED_CONTEXT;
2198 if (PerlIOValid(f)) {
2199 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2204 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2210 arg = sv_dup(arg, param);
2211 SvREFCNT_inc_simple_void_NN(arg);
2215 return newSVsv(arg);
2218 PERL_UNUSED_ARG(param);
2219 return newSVsv(arg);
2224 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2226 PerlIO * const nexto = PerlIONext(o);
2227 if (PerlIOValid(nexto)) {
2228 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2229 if (tab && tab->Dup)
2230 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2232 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2235 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2239 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2241 (void*)f, (void*)o, (void*)param) );
2243 arg = (*self->Getarg)(aTHX_ o, param, flags);
2244 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2245 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2246 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2252 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2254 /* Must be called with PL_perlio_mutex locked. */
2256 S_more_refcounted_fds(pTHX_ const int new_fd)
2257 PERL_TSA_REQUIRES(PL_perlio_mutex)
2260 const int old_max = PL_perlio_fd_refcnt_size;
2261 const int new_max = 16 + (new_fd & ~15);
2264 #ifndef PERL_IMPLICIT_SYS
2265 PERL_UNUSED_CONTEXT;
2268 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2269 old_max, new_fd, new_max) );
2271 if (new_fd < old_max) {
2275 assert (new_max > new_fd);
2277 /* Use plain realloc() since we need this memory to be really
2278 * global and visible to all the interpreters and/or threads. */
2279 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2282 MUTEX_UNLOCK(&PL_perlio_mutex);
2286 PL_perlio_fd_refcnt_size = new_max;
2287 PL_perlio_fd_refcnt = new_array;
2289 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2290 (void*)(new_array + old_max),
2291 new_max - old_max) );
2293 Zero(new_array + old_max, new_max - old_max, int);
2300 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2301 PERL_UNUSED_CONTEXT;
2305 PerlIOUnix_refcnt_inc(int fd)
2311 MUTEX_LOCK(&PL_perlio_mutex);
2312 if (fd >= PL_perlio_fd_refcnt_size)
2313 S_more_refcounted_fds(aTHX_ fd);
2315 PL_perlio_fd_refcnt[fd]++;
2316 if (PL_perlio_fd_refcnt[fd] <= 0) {
2317 /* diag_listed_as: refcnt_inc: fd %d%s */
2318 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2319 fd, PL_perlio_fd_refcnt[fd]);
2321 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2322 fd, PL_perlio_fd_refcnt[fd]) );
2324 MUTEX_UNLOCK(&PL_perlio_mutex);
2326 /* diag_listed_as: refcnt_inc: fd %d%s */
2327 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2332 PerlIOUnix_refcnt_dec(int fd)
2341 MUTEX_LOCK(&PL_perlio_mutex);
2342 if (fd >= PL_perlio_fd_refcnt_size) {
2343 /* diag_listed_as: refcnt_dec: fd %d%s */
2344 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2345 fd, PL_perlio_fd_refcnt_size);
2347 if (PL_perlio_fd_refcnt[fd] <= 0) {
2348 /* diag_listed_as: refcnt_dec: fd %d%s */
2349 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2350 fd, PL_perlio_fd_refcnt[fd]);
2352 cnt = --PL_perlio_fd_refcnt[fd];
2353 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2354 MUTEX_UNLOCK(&PL_perlio_mutex);
2356 /* diag_listed_as: refcnt_dec: fd %d%s */
2357 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2363 PerlIOUnix_refcnt(int fd)
2369 MUTEX_LOCK(&PL_perlio_mutex);
2370 if (fd >= PL_perlio_fd_refcnt_size) {
2371 /* diag_listed_as: refcnt: fd %d%s */
2372 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2373 fd, PL_perlio_fd_refcnt_size);
2375 if (PL_perlio_fd_refcnt[fd] <= 0) {
2376 /* diag_listed_as: refcnt: fd %d%s */
2377 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2378 fd, PL_perlio_fd_refcnt[fd]);
2380 cnt = PL_perlio_fd_refcnt[fd];
2381 MUTEX_UNLOCK(&PL_perlio_mutex);
2383 /* diag_listed_as: refcnt: fd %d%s */
2384 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2390 PerlIO_cleanup(pTHX)
2394 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2396 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2399 /* Raise STDIN..STDERR refcount so we don't close them */
2400 for (i=0; i < 3; i++)
2401 PerlIOUnix_refcnt_inc(i);
2402 PerlIO_cleantable(aTHX_ &PL_perlio);
2403 /* Restore STDIN..STDERR refcount */
2404 for (i=0; i < 3; i++)
2405 PerlIOUnix_refcnt_dec(i);
2407 if (PL_known_layers) {
2408 PerlIO_list_free(aTHX_ PL_known_layers);
2409 PL_known_layers = NULL;
2411 if (PL_def_layerlist) {
2412 PerlIO_list_free(aTHX_ PL_def_layerlist);
2413 PL_def_layerlist = NULL;
2417 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2421 /* XXX we can't rely on an interpreter being present at this late stage,
2422 XXX so we can't use a function like PerlLIO_write that relies on one
2423 being present (at least in win32) :-(.
2428 /* By now all filehandles should have been closed, so any
2429 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2431 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2432 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2433 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2435 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2436 if (PL_perlio_fd_refcnt[i]) {
2438 my_snprintf(buf, sizeof(buf),
2439 "PerlIO_teardown: fd %d refcnt=%d\n",
2440 i, PL_perlio_fd_refcnt[i]);
2441 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2447 /* Not bothering with PL_perlio_mutex since by now
2448 * all the interpreters are gone. */
2449 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2450 && PL_perlio_fd_refcnt) {
2451 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2452 PL_perlio_fd_refcnt = NULL;
2453 PL_perlio_fd_refcnt_size = 0;
2457 /*--------------------------------------------------------------------------------------*/
2459 * Bottom-most level for UNIX-like case
2463 struct _PerlIO base; /* The generic part */
2464 int fd; /* UNIX like file descriptor */
2465 int oflags; /* open/fcntl flags */
2469 S_lockcnt_dec(pTHX_ const void* f)
2471 #ifndef PERL_IMPLICIT_SYS
2472 PERL_UNUSED_CONTEXT;
2474 PerlIO_lockcnt((PerlIO*)f)--;
2478 /* call the signal handler, and if that handler happens to clear
2479 * this handle, free what we can and return true */
2482 S_perlio_async_run(pTHX_ PerlIO* f) {
2484 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2485 PerlIO_lockcnt(f)++;
2487 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2491 /* we've just run some perl-level code that could have done
2492 * anything, including closing the file or clearing this layer.
2493 * If so, free any lower layers that have already been
2494 * cleared, then return an error. */
2495 while (PerlIOValid(f) &&
2496 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2498 const PerlIOl *l = *f;
2507 PerlIOUnix_oflags(const char *mode)
2510 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2515 if (*++mode == '+') {
2522 oflags = O_CREAT | O_TRUNC;
2523 if (*++mode == '+') {
2532 oflags = O_CREAT | O_APPEND;
2533 if (*++mode == '+') {
2542 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2544 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2545 * of them in, and then bit-and-masking the other them away, won't
2546 * have much of an effect. */
2549 #if O_TEXT != O_BINARY
2556 #if O_TEXT != O_BINARY
2558 oflags &= ~O_BINARY;
2564 /* bit-or:ing with zero O_BINARY would be useless. */
2566 * If neither "t" nor "b" was specified, open the file
2569 * Note that if something else than the zero byte was seen
2570 * here (e.g. bogus mode "rx"), just few lines later we will
2571 * set the errno and invalidate the flags.
2577 if (*mode || oflags == -1) {
2578 SETERRNO(EINVAL, LIB_INVARG);
2585 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2587 PERL_UNUSED_CONTEXT;
2588 return PerlIOSelf(f, PerlIOUnix)->fd;
2592 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2594 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2597 if (PerlLIO_fstat(fd, &st) == 0) {
2598 if (!S_ISREG(st.st_mode)) {
2599 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2600 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2603 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2609 PerlIOUnix_refcnt_inc(fd);
2610 PERL_UNUSED_CONTEXT;
2614 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2616 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2617 if (*PerlIONext(f)) {
2618 /* We never call down so do any pending stuff now */
2619 PerlIO_flush(PerlIONext(f));
2621 * XXX could (or should) we retrieve the oflags from the open file
2622 * handle rather than believing the "mode" we are passed in? XXX
2623 * Should the value on NULL mode be 0 or -1?
2625 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2626 mode ? PerlIOUnix_oflags(mode) : -1);
2628 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2634 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2636 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2638 PERL_UNUSED_CONTEXT;
2639 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2641 SETERRNO(ESPIPE, LIB_INVARG);
2643 SETERRNO(EINVAL, LIB_INVARG);
2647 new_loc = PerlLIO_lseek(fd, offset, whence);
2648 if (new_loc == (Off_t) - 1)
2650 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2655 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2656 IV n, const char *mode, int fd, int imode,
2657 int perm, PerlIO *f, int narg, SV **args)
2659 bool known_cloexec = 0;
2660 if (PerlIOValid(f)) {
2661 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2662 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2665 if (*mode == IoTYPE_NUMERIC)
2668 imode = PerlIOUnix_oflags(mode);
2670 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2677 const char *path = SvPV_const(*args, len);
2678 if (!IS_SAFE_PATHNAME(path, len, "open"))
2680 fd = PerlLIO_open3_cloexec(path, imode, perm);
2686 setfd_inhexec_for_sysfd(fd);
2688 setfd_cloexec_or_inhexec_by_sysfdness(fd);
2689 if (*mode == IoTYPE_IMPLICIT)
2692 f = PerlIO_allocate(aTHX);
2694 if (!PerlIOValid(f)) {
2695 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2700 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2701 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2702 if (*mode == IoTYPE_APPEND)
2703 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2710 * FIXME: pop layers ???
2718 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2720 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2722 if (flags & PERLIO_DUP_FD) {
2723 fd = PerlLIO_dup_cloexec(fd);
2725 setfd_inhexec_for_sysfd(fd);
2728 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2730 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2731 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2741 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2744 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2746 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2747 #ifdef PERLIO_STD_SPECIAL
2749 return PERLIO_STD_IN(fd, vbuf, count);
2751 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2752 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2756 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2757 if (len >= 0 || errno != EINTR) {
2759 if (errno != EAGAIN) {
2760 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2761 PerlIO_save_errno(f);
2764 else if (len == 0 && count != 0) {
2765 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2771 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2774 NOT_REACHED; /*NOTREACHED*/
2778 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2781 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2783 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2784 #ifdef PERLIO_STD_SPECIAL
2785 if (fd == 1 || fd == 2)
2786 return PERLIO_STD_OUT(fd, vbuf, count);
2789 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2790 if (len >= 0 || errno != EINTR) {
2792 if (errno != EAGAIN) {
2793 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2794 PerlIO_save_errno(f);
2800 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2803 NOT_REACHED; /*NOTREACHED*/
2807 PerlIOUnix_tell(pTHX_ PerlIO *f)
2809 PERL_UNUSED_CONTEXT;
2811 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2816 PerlIOUnix_close(pTHX_ PerlIO *f)
2818 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2820 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2821 code = PerlIOBase_close(aTHX_ f);
2822 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2823 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2828 SETERRNO(EBADF,SS_IVCHAN);
2831 while (PerlLIO_close(fd) != 0) {
2832 if (errno != EINTR) {
2837 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2841 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2846 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2847 sizeof(PerlIO_funcs),
2854 PerlIOBase_binmode, /* binmode */
2864 PerlIOBase_noop_ok, /* flush */
2865 PerlIOBase_noop_fail, /* fill */
2868 PerlIOBase_clearerr,
2869 PerlIOBase_setlinebuf,
2870 NULL, /* get_base */
2871 NULL, /* get_bufsiz */
2874 NULL, /* set_ptrcnt */
2877 /*--------------------------------------------------------------------------------------*/
2882 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2883 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2884 broken by the last second glibc 2.3 fix
2886 #define STDIO_BUFFER_WRITABLE
2891 struct _PerlIO base;
2892 FILE *stdio; /* The stream */
2896 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2898 PERL_UNUSED_CONTEXT;
2900 if (PerlIOValid(f)) {
2901 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2903 return PerlSIO_fileno(s);
2910 PerlIOStdio_mode(const char *mode, char *tmode)
2912 char * const ret = tmode;
2918 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2926 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2929 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2930 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2931 if (toptab == tab) {
2932 /* Top is already stdio - pop self (duplicate) and use original */
2933 PerlIO_pop(aTHX_ f);
2936 const int fd = PerlIO_fileno(n);
2939 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2940 mode = PerlIOStdio_mode(mode, tmode)))) {
2941 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2942 /* We never call down so do any pending stuff now */
2943 PerlIO_flush(PerlIONext(f));
2944 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2951 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2956 PerlIO_importFILE(FILE *stdio, const char *mode)
2962 char filename[FILENAME_MAX];
2967 int fd0 = fileno(stdio);
2970 rc = fldata(stdio,filename,&fileinfo);
2974 if(fileinfo.__dsorgHFS){
2977 /*This MVS dataset , OK!*/
2982 if (!mode || !*mode) {
2983 /* We need to probe to see how we can open the stream
2984 so start with read/write and then try write and read
2985 we dup() so that we can fclose without loosing the fd.
2987 Note that the errno value set by a failing fdopen
2988 varies between stdio implementations.
2990 const int fd = PerlLIO_dup_cloexec(fd0);
2995 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2997 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3000 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3003 /* Don't seem to be able to open */
3009 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3010 s = PerlIOSelf(f, PerlIOStdio);
3012 fd0 = fileno(stdio);
3014 PerlIOUnix_refcnt_inc(fd0);
3015 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3019 rc = fldata(stdio,filename,&fileinfo);
3021 PerlIOUnix_refcnt_inc(fd0);
3023 if(fileinfo.__dsorgHFS){
3024 PerlIOUnix_refcnt_inc(fd0);
3026 /*This MVS dataset , OK!*/
3035 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3036 IV n, const char *mode, int fd, int imode,
3037 int perm, PerlIO *f, int narg, SV **args)
3040 if (PerlIOValid(f)) {
3042 const char * const path = SvPV_const(*args, len);
3043 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3045 if (!IS_SAFE_PATHNAME(path, len, "open"))
3047 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3048 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3054 PerlIOUnix_refcnt_inc(fd);
3055 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3061 const char * const path = SvPV_const(*args, len);
3062 if (!IS_SAFE_PATHNAME(path, len, "open"))
3064 if (*mode == IoTYPE_NUMERIC) {
3066 fd = PerlLIO_open3_cloexec(path, imode, perm);
3070 bool appended = FALSE;
3072 /* Cygwin wants its 'b' early. */
3074 mode = PerlIOStdio_mode(mode, tmode);
3076 stdio = PerlSIO_fopen(path, mode);
3079 f = PerlIO_allocate(aTHX);
3082 mode = PerlIOStdio_mode(mode, tmode);
3083 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3085 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3087 PerlIOUnix_refcnt_inc(fd);
3088 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3090 PerlSIO_fclose(stdio);
3102 if (*mode == IoTYPE_IMPLICIT) {
3109 stdio = PerlSIO_stdin;
3112 stdio = PerlSIO_stdout;
3115 stdio = PerlSIO_stderr;
3120 stdio = PerlSIO_fdopen(fd, mode =
3121 PerlIOStdio_mode(mode, tmode));
3125 f = PerlIO_allocate(aTHX);
3127 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3128 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3130 PerlIOUnix_refcnt_inc(fd);
3131 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3142 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3144 /* This assumes no layers underneath - which is what
3145 happens, but is not how I remember it. NI-S 2001/10/16
3147 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3148 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3149 const int fd = fileno(stdio);
3151 if (flags & PERLIO_DUP_FD) {
3152 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
3154 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3159 /* FIXME: To avoid messy error recovery if dup fails
3160 re-use the existing stdio as though flag was not set
3164 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3166 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3168 int fd = fileno(stdio);
3169 PerlIOUnix_refcnt_inc(fd);
3170 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3177 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3179 PERL_UNUSED_CONTEXT;
3181 /* XXX this could use PerlIO_canset_fileno() and
3182 * PerlIO_set_fileno() support from Configure
3184 # if defined(HAS_FDCLOSE)
3185 return fdclose(f, NULL) == 0 ? 1 : 0;
3186 # elif defined(__UCLIBC__)
3187 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3190 # elif defined(__GLIBC__)
3191 /* There may be a better way for GLIBC:
3192 - libio.h defines a flag to not close() on cleanup
3196 # elif defined(__sun)
3199 # elif defined(__hpux)
3203 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3204 your platform does not have special entry try this one.
3205 [For OSF only have confirmation for Tru64 (alpha)
3206 but assume other OSFs will be similar.]
3208 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3211 # elif defined(__FreeBSD__)
3212 /* There may be a better way on FreeBSD:
3213 - we could insert a dummy func in the _close function entry
3214 f->_close = (int (*)(void *)) dummy_close;
3218 # elif defined(__OpenBSD__)
3219 /* There may be a better way on OpenBSD:
3220 - we could insert a dummy func in the _close function entry
3221 f->_close = (int (*)(void *)) dummy_close;
3225 # elif defined(__EMX__)
3226 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3229 # elif defined(__CYGWIN__)
3230 /* There may be a better way on CYGWIN:
3231 - we could insert a dummy func in the _close function entry
3232 f->_close = (int (*)(void *)) dummy_close;
3236 # elif defined(WIN32)
3237 PERLIO_FILE_file(f) = -1;
3241 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3242 (which isn't thread safe) instead
3244 # error "Don't know how to set FILE.fileno on your platform"
3252 PerlIOStdio_close(pTHX_ PerlIO *f)
3254 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3260 const int fd = fileno(stdio);
3268 #ifdef SOCKS5_VERSION_NAME
3269 /* Socks lib overrides close() but stdio isn't linked to
3270 that library (though we are) - so we must call close()
3271 on sockets on stdio's behalf.
3274 Sock_size_t optlen = sizeof(int);
3275 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3278 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3279 that a subsequent fileno() on it returns -1. Don't want to croak()
3280 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3281 trying to close an already closed handle which somehow it still has
3282 a reference to. (via.xs, I'm looking at you). */
3283 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3284 /* File descriptor still in use */
3288 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3289 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3291 if (stdio == stdout || stdio == stderr)
3292 return PerlIO_flush(f);
3294 MUTEX_LOCK(&PL_perlio_mutex);
3295 /* Right. We need a mutex here because for a brief while we
3296 will have the situation that fd is actually closed. Hence if
3297 a second thread were to get into this block, its dup() would
3298 likely return our fd as its dupfd. (after all, it is closed)
3299 Then if we get to the dup2() first, we blat the fd back
3300 (messing up its temporary as a side effect) only for it to
3301 then close its dupfd (== our fd) in its close(dupfd) */
3303 /* There is, of course, a race condition, that any other thread
3304 trying to input/output/whatever on this fd will be stuffed
3305 for the duration of this little manoeuvrer. Perhaps we
3306 should hold an IO mutex for the duration of every IO
3307 operation if we know that invalidate doesn't work on this
3308 platform, but that would suck, and could kill performance.
3310 Except that correctness trumps speed.
3311 Advice from klortho #11912. */
3313 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3314 Use Sarathy's trick from maint-5.6 to invalidate the
3315 fileno slot of the FILE *
3317 result = PerlIO_flush(f);
3319 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3321 dupfd = PerlLIO_dup_cloexec(fd);
3324 /* Oh cXap. This isn't going to go well. Not sure if we can
3325 recover from here, or if closing this particular FILE *
3326 is a good idea now. */
3331 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3333 result = PerlSIO_fclose(stdio);
3334 /* We treat error from stdio as success if we invalidated
3335 errno may NOT be expected EBADF
3337 if (invalidate && result != 0) {
3341 #ifdef SOCKS5_VERSION_NAME
3342 /* in SOCKS' case, let close() determine return value */
3346 PerlLIO_dup2_cloexec(dupfd, fd);
3347 setfd_inhexec_for_sysfd(fd);
3348 PerlLIO_close(dupfd);
3350 MUTEX_UNLOCK(&PL_perlio_mutex);
3356 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3360 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3362 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3365 STDCHAR *buf = (STDCHAR *) vbuf;
3367 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3368 * stdio does not do that for fread()
3370 const int ch = PerlSIO_fgetc(s);
3377 got = PerlSIO_fread(vbuf, 1, count, s);
3378 if (got == 0 && PerlSIO_ferror(s))
3380 if (got >= 0 || errno != EINTR)
3382 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3384 SETERRNO(0,0); /* just in case */
3387 /* Under some circumstances IRIX stdio fgetc() and fread()
3388 * set the errno to ENOENT, which makes no sense according
3389 * to either IRIX or POSIX. [rt.perl.org #123977] */
3390 if (errno == ENOENT) SETERRNO(0,0);
3396 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3399 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3401 #ifdef STDIO_BUFFER_WRITABLE
3402 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3403 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3404 STDCHAR *base = PerlIO_get_base(f);
3405 SSize_t cnt = PerlIO_get_cnt(f);
3406 STDCHAR *ptr = PerlIO_get_ptr(f);
3407 SSize_t avail = ptr - base;
3409 if (avail > count) {
3413 Move(buf-avail,ptr,avail,STDCHAR);
3416 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3417 if (PerlSIO_feof(s) && unread >= 0)
3418 PerlSIO_clearerr(s);
3423 if (PerlIO_has_cntptr(f)) {
3424 /* We can get pointer to buffer but not its base
3425 Do ungetc() but check chars are ending up in the
3428 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3429 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3431 const int ch = *--buf & 0xFF;
3432 if (ungetc(ch,s) != ch) {
3433 /* ungetc did not work */
3436 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3437 /* Did not change pointer as expected */
3438 if (fgetc(s) != EOF) /* get char back again */
3448 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3454 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3457 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3460 got = PerlSIO_fwrite(vbuf, 1, count,
3461 PerlIOSelf(f, PerlIOStdio)->stdio);
3462 if (got >= 0 || errno != EINTR)
3464 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3466 SETERRNO(0,0); /* just in case */
3472 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3474 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3475 PERL_UNUSED_CONTEXT;
3477 return PerlSIO_fseek(stdio, offset, whence);
3481 PerlIOStdio_tell(pTHX_ PerlIO *f)
3483 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3484 PERL_UNUSED_CONTEXT;
3486 return PerlSIO_ftell(stdio);
3490 PerlIOStdio_flush(pTHX_ PerlIO *f)
3492 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3493 PERL_UNUSED_CONTEXT;
3495 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3496 return PerlSIO_fflush(stdio);
3502 * FIXME: This discards ungetc() and pre-read stuff which is not
3503 * right if this is just a "sync" from a layer above Suspect right
3504 * design is to do _this_ but not have layer above flush this
3505 * layer read-to-read
3508 * Not writeable - sync by attempting a seek
3511 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3519 PerlIOStdio_eof(pTHX_ PerlIO *f)
3521 PERL_UNUSED_CONTEXT;
3523 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3527 PerlIOStdio_error(pTHX_ PerlIO *f)
3529 PERL_UNUSED_CONTEXT;
3531 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3535 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3537 PERL_UNUSED_CONTEXT;
3539 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3543 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3545 PERL_UNUSED_CONTEXT;
3547 #ifdef HAS_SETLINEBUF
3548 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3550 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3556 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3558 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3559 PERL_UNUSED_CONTEXT;
3560 return (STDCHAR*)PerlSIO_get_base(stdio);
3564 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3566 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3567 PERL_UNUSED_CONTEXT;
3568 return PerlSIO_get_bufsiz(stdio);
3572 #ifdef USE_STDIO_PTR
3574 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3576 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3577 PERL_UNUSED_CONTEXT;
3578 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3582 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3584 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3585 PERL_UNUSED_CONTEXT;
3586 return PerlSIO_get_cnt(stdio);
3590 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3592 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3593 PERL_UNUSED_CONTEXT;
3595 #ifdef STDIO_PTR_LVALUE
3596 /* This is a long-standing infamous mess. The root of the
3597 * problem is that one cannot know the signedness of char, and
3598 * more precisely the signedness of FILE._ptr. The following
3599 * things have been tried, and they have all failed (across
3600 * different compilers (remember that core needs to to build
3601 * also with c++) and compiler options:
3603 * - casting the RHS to (void*) -- works in *some* places
3604 * - casting the LHS to (void*) -- totally unportable
3606 * So let's try silencing the warning at least for gcc. */
3607 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
3608 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3609 GCC_DIAG_RESTORE_STMT;
3610 #ifdef STDIO_PTR_LVAL_SETS_CNT
3611 assert(PerlSIO_get_cnt(stdio) == (cnt));
3613 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3615 * Setting ptr _does_ change cnt - we are done
3619 #else /* STDIO_PTR_LVALUE */
3621 #endif /* STDIO_PTR_LVALUE */
3624 * Now (or only) set cnt
3626 #ifdef STDIO_CNT_LVALUE
3627 PerlSIO_set_cnt(stdio, cnt);
3628 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3629 PerlSIO_set_ptr(stdio,
3630 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3632 #else /* STDIO_PTR_LVAL_SETS_CNT */
3634 #endif /* STDIO_CNT_LVALUE */
3641 PerlIOStdio_fill(pTHX_ PerlIO *f)
3645 PERL_UNUSED_CONTEXT;
3646 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3648 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3651 * fflush()ing read-only streams can cause trouble on some stdio-s
3653 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3654 if (PerlSIO_fflush(stdio) != 0)
3658 c = PerlSIO_fgetc(stdio);
3661 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3663 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3668 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3670 #ifdef STDIO_BUFFER_WRITABLE
3671 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3672 /* Fake ungetc() to the real buffer in case system's ungetc
3675 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3676 SSize_t cnt = PerlSIO_get_cnt(stdio);
3677 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3678 if (ptr == base+1) {
3679 *--ptr = (STDCHAR) c;
3680 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3681 if (PerlSIO_feof(stdio))
3682 PerlSIO_clearerr(stdio);
3688 if (PerlIO_has_cntptr(f)) {
3690 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3696 /* If buffer snoop scheme above fails fall back to
3699 if (PerlSIO_ungetc(c, stdio) != c)
3707 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3708 sizeof(PerlIO_funcs),
3710 sizeof(PerlIOStdio),
3711 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3715 PerlIOBase_binmode, /* binmode */
3729 PerlIOStdio_clearerr,
3730 PerlIOStdio_setlinebuf,
3732 PerlIOStdio_get_base,
3733 PerlIOStdio_get_bufsiz,
3738 #ifdef USE_STDIO_PTR
3739 PerlIOStdio_get_ptr,
3740 PerlIOStdio_get_cnt,
3741 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3742 PerlIOStdio_set_ptrcnt,
3745 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3750 #endif /* USE_STDIO_PTR */
3753 /* Note that calls to PerlIO_exportFILE() are reversed using
3754 * PerlIO_releaseFILE(), not importFILE. */
3756 PerlIO_exportFILE(PerlIO * f, const char *mode)
3760 if (PerlIOValid(f)) {
3762 int fd = PerlIO_fileno(f);
3767 if (!mode || !*mode) {
3768 mode = PerlIO_modestr(f, buf);
3770 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3774 /* De-link any lower layers so new :stdio sticks */
3776 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3777 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3779 PerlIOUnix_refcnt_inc(fileno(stdio));
3780 /* Link previous lower layers under new one */
3784 /* restore layers list */
3794 PerlIO_findFILE(PerlIO *f)
3799 if (l->tab == &PerlIO_stdio) {
3800 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3803 l = *PerlIONext(&l);
3805 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3806 /* However, we're not really exporting a FILE * to someone else (who
3807 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3808 So we need to undo its reference count increase on the underlying file
3809 descriptor. We have to do this, because if the loop above returns you
3810 the FILE *, then *it* didn't increase any reference count. So there's
3811 only one way to be consistent. */
3812 stdio = PerlIO_exportFILE(f, NULL);
3814 const int fd = fileno(stdio);
3816 PerlIOUnix_refcnt_dec(fd);
3821 /* Use this to reverse PerlIO_exportFILE calls. */
3823 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3827 if (l->tab == &PerlIO_stdio) {
3828 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3829 if (s->stdio == f) { /* not in a loop */
3830 const int fd = fileno(f);
3832 PerlIOUnix_refcnt_dec(fd);
3835 PerlIO_pop(aTHX_ p);
3845 /*--------------------------------------------------------------------------------------*/
3847 * perlio buffer layer
3851 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3853 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3854 const int fd = PerlIO_fileno(f);
3855 if (fd >= 0 && PerlLIO_isatty(fd)) {
3856 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3858 if (*PerlIONext(f)) {
3859 const Off_t posn = PerlIO_tell(PerlIONext(f));
3860 if (posn != (Off_t) - 1) {
3864 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3868 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3869 IV n, const char *mode, int fd, int imode, int perm,
3870 PerlIO *f, int narg, SV **args)
3872 if (PerlIOValid(f)) {
3873 PerlIO *next = PerlIONext(f);
3875 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3876 if (tab && tab->Open)
3878 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3880 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3885 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3887 if (*mode == IoTYPE_IMPLICIT) {
3893 if (tab && tab->Open)
3894 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3897 SETERRNO(EINVAL, LIB_INVARG);
3899 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3901 * if push fails during open, open fails. close will pop us.
3906 fd = PerlIO_fileno(f);
3907 if (init && fd == 2) {
3909 * Initial stderr is unbuffered
3911 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3913 #ifdef PERLIO_USING_CRLF
3914 # ifdef PERLIO_IS_BINMODE_FD
3915 if (PERLIO_IS_BINMODE_FD(fd))
3916 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3920 * do something about failing setmode()? --jhi
3922 PerlLIO_setmode(fd, O_BINARY);
3925 /* Enable line buffering with record-oriented regular files
3926 * so we don't introduce an extraneous record boundary when
3927 * the buffer fills up.
3929 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3931 if (PerlLIO_fstat(fd, &st) == 0
3932 && S_ISREG(st.st_mode)
3933 && (st.st_fab_rfm == FAB$C_VAR
3934 || st.st_fab_rfm == FAB$C_VFC)) {
3935 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3946 * This "flush" is akin to sfio's sync in that it handles files in either
3947 * read or write state. For write state, we put the postponed data through
3948 * the next layers. For read state, we seek() the next layers to the
3949 * offset given by current position in the buffer, and discard the buffer
3950 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3951 * in any case?). Then the pass the stick further in chain.
3954 PerlIOBuf_flush(pTHX_ PerlIO *f)
3956 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3958 PerlIO *n = PerlIONext(f);
3959 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3961 * write() the buffer
3963 const STDCHAR *buf = b->buf;
3964 const STDCHAR *p = buf;
3965 while (p < b->ptr) {
3966 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3970 else if (count < 0 || PerlIO_error(n)) {
3971 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3972 PerlIO_save_errno(f);
3977 b->posn += (p - buf);
3979 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3980 STDCHAR *buf = PerlIO_get_base(f);
3982 * Note position change
3984 b->posn += (b->ptr - buf);
3985 if (b->ptr < b->end) {
3986 /* We did not consume all of it - try and seek downstream to
3987 our logical position
3989 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3990 /* Reload n as some layers may pop themselves on seek */
3991 b->posn = PerlIO_tell(n = PerlIONext(f));
3994 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3995 data is lost for good - so return saying "ok" having undone
3998 b->posn -= (b->ptr - buf);
4003 b->ptr = b->end = b->buf;
4004 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4005 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4006 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4011 /* This discards the content of the buffer after b->ptr, and rereads
4012 * the buffer from the position off in the layer downstream; here off
4013 * is at offset corresponding to b->ptr - b->buf.
4016 PerlIOBuf_fill(pTHX_ PerlIO *f)
4018 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4019 PerlIO *n = PerlIONext(f);
4022 * Down-stream flush is defined not to loose read data so is harmless.
4023 * we would not normally be fill'ing if there was data left in anycase.
4025 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4027 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4028 PerlIOBase_flush_linebuf(aTHX);
4031 PerlIO_get_base(f); /* allocate via vtable */
4033 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4035 b->ptr = b->end = b->buf;
4037 if (!PerlIOValid(n)) {
4038 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4042 if (PerlIO_fast_gets(n)) {
4044 * Layer below is also buffered. We do _NOT_ want to call its
4045 * ->Read() because that will loop till it gets what we asked for
4046 * which may hang on a pipe etc. Instead take anything it has to
4047 * hand, or ask it to fill _once_.
4049 avail = PerlIO_get_cnt(n);
4051 avail = PerlIO_fill(n);
4053 avail = PerlIO_get_cnt(n);
4055 if (!PerlIO_error(n) && PerlIO_eof(n))
4060 STDCHAR *ptr = PerlIO_get_ptr(n);
4061 const SSize_t cnt = avail;
4062 if (avail > (SSize_t)b->bufsiz)
4064 Copy(ptr, b->buf, avail, STDCHAR);
4065 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4069 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4073 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4076 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4077 PerlIO_save_errno(f);
4081 b->end = b->buf + avail;
4082 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4087 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4089 if (PerlIOValid(f)) {
4090 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4093 return PerlIOBase_read(aTHX_ f, vbuf, count);
4099 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4101 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4102 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4105 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4110 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4112 * Buffer is already a read buffer, we can overwrite any chars
4113 * which have been read back to buffer start
4115 avail = (b->ptr - b->buf);
4119 * Buffer is idle, set it up so whole buffer is available for
4123 b->end = b->buf + avail;
4125 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4127 * Buffer extends _back_ from where we are now
4129 b->posn -= b->bufsiz;
4131 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4133 * If we have space for more than count, just move count
4141 * In simple stdio-like ungetc() case chars will be already
4144 if (buf != b->ptr) {
4145 Copy(buf, b->ptr, avail, STDCHAR);
4149 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4153 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4159 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4161 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4162 const STDCHAR *buf = (const STDCHAR *) vbuf;
4163 const STDCHAR *flushptr = buf;
4167 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4169 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4170 if (PerlIO_flush(f) != 0) {
4174 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4175 flushptr = buf + count;
4176 while (flushptr > buf && *(flushptr - 1) != '\n')
4180 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4181 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4183 if (flushptr > buf && flushptr <= buf + avail)
4184 avail = flushptr - buf;
4185 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4187 Copy(buf, b->ptr, avail, STDCHAR);
4192 if (buf == flushptr)
4195 if (b->ptr >= (b->buf + b->bufsiz))
4196 if (PerlIO_flush(f) == -1)
4199 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4205 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4208 if ((code = PerlIO_flush(f)) == 0) {
4209 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4210 code = PerlIO_seek(PerlIONext(f), offset, whence);
4212 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4213 b->posn = PerlIO_tell(PerlIONext(f));
4220 PerlIOBuf_tell(pTHX_ PerlIO *f)
4222 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4224 * b->posn is file position where b->buf was read, or will be written
4226 Off_t posn = b->posn;
4227 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4228 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4230 /* As O_APPEND files are normally shared in some sense it is better
4235 /* when file is NOT shared then this is sufficient */
4236 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4238 posn = b->posn = PerlIO_tell(PerlIONext(f));
4242 * If buffer is valid adjust position by amount in buffer
4244 posn += (b->ptr - b->buf);
4250 PerlIOBuf_popped(pTHX_ PerlIO *f)
4252 const IV code = PerlIOBase_popped(aTHX_ f);
4253 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4254 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4257 b->ptr = b->end = b->buf = NULL;
4258 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4263 PerlIOBuf_close(pTHX_ PerlIO *f)
4265 const IV code = PerlIOBase_close(aTHX_ f);
4266 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4267 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4270 b->ptr = b->end = b->buf = NULL;
4271 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4276 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4278 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4285 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4287 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4290 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4291 return (b->end - b->ptr);
4296 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4298 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4299 PERL_UNUSED_CONTEXT;
4303 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4304 Newx(b->buf,b->bufsiz, STDCHAR);
4306 b->buf = (STDCHAR *) & b->oneword;
4307 b->bufsiz = sizeof(b->oneword);
4309 b->end = b->ptr = b->buf;
4315 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4317 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4320 return (b->end - b->buf);
4324 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4326 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4328 PERL_UNUSED_ARG(cnt);
4333 assert(PerlIO_get_cnt(f) == cnt);
4334 assert(b->ptr >= b->buf);
4335 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4339 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4341 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4346 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4347 sizeof(PerlIO_funcs),
4350 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4354 PerlIOBase_binmode, /* binmode */
4368 PerlIOBase_clearerr,
4369 PerlIOBase_setlinebuf,
4374 PerlIOBuf_set_ptrcnt,
4377 /*--------------------------------------------------------------------------------------*/
4379 * Temp layer to hold unread chars when cannot do it any other way
4383 PerlIOPending_fill(pTHX_ PerlIO *f)
4386 * Should never happen
4393 PerlIOPending_close(pTHX_ PerlIO *f)
4396 * A tad tricky - flush pops us, then we close new top
4399 return PerlIO_close(f);
4403 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4406 * A tad tricky - flush pops us, then we seek new top
4409 return PerlIO_seek(f, offset, whence);
4414 PerlIOPending_flush(pTHX_ PerlIO *f)
4416 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4417 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4421 PerlIO_pop(aTHX_ f);
4426 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4432 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4437 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4439 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4440 PerlIOl * const l = PerlIOBase(f);
4442 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4443 * etc. get muddled when it changes mid-string when we auto-pop.
4445 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4446 (PerlIOBase(PerlIONext(f))->
4447 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4452 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4454 SSize_t avail = PerlIO_get_cnt(f);
4456 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4459 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4460 if (got >= 0 && got < (SSize_t)count) {
4461 const SSize_t more =
4462 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4463 if (more >= 0 || got == 0)
4469 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4470 sizeof(PerlIO_funcs),
4473 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4474 PerlIOPending_pushed,
4477 PerlIOBase_binmode, /* binmode */
4486 PerlIOPending_close,
4487 PerlIOPending_flush,
4491 PerlIOBase_clearerr,
4492 PerlIOBase_setlinebuf,
4497 PerlIOPending_set_ptrcnt,
4502 /*--------------------------------------------------------------------------------------*/
4504 * crlf - translation On read translate CR,LF to "\n" we do this by
4505 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4506 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4508 * c->nl points on the first byte of CR LF pair when it is temporarily
4509 * replaced by LF, or to the last CR of the buffer. In the former case
4510 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4511 * that it ends at c->nl; these two cases can be distinguished by
4512 * *c->nl. c->nl is set during _getcnt() call, and unset during
4513 * _unread() and _flush() calls.
4514 * It only matters for read operations.
4518 PerlIOBuf base; /* PerlIOBuf stuff */
4519 STDCHAR *nl; /* Position of crlf we "lied" about in the
4523 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4524 * Otherwise the :crlf layer would always revert back to
4528 S_inherit_utf8_flag(PerlIO *f)
4530 PerlIO *g = PerlIONext(f);
4531 if (PerlIOValid(g)) {
4532 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4533 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4539 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4542 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4543 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4546 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4547 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4548 PerlIOBase(f)->flags);
4552 /* If the old top layer is a CRLF layer, reactivate it (if
4553 * necessary) and remove this new layer from the stack */
4554 PerlIO *g = PerlIONext(f);
4555 if (PerlIOValid(g)) {
4556 PerlIOl *b = PerlIOBase(g);
4557 if (b && b->tab == &PerlIO_crlf) {
4558 if (!(b->flags & PERLIO_F_CRLF))
4559 b->flags |= PERLIO_F_CRLF;
4560 S_inherit_utf8_flag(g);
4561 PerlIO_pop(aTHX_ f);
4566 S_inherit_utf8_flag(f);
4572 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4574 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4575 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4576 *(c->nl) = NATIVE_0xd;
4579 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4580 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4582 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4583 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4585 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4590 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4591 b->end = b->ptr = b->buf + b->bufsiz;
4592 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4593 b->posn -= b->bufsiz;
4595 while (count > 0 && b->ptr > b->buf) {
4596 const int ch = *--buf;
4598 if (b->ptr - 2 >= b->buf) {
4599 *--(b->ptr) = NATIVE_0xa;
4600 *--(b->ptr) = NATIVE_0xd;
4605 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4606 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4620 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4625 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4627 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4629 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4632 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4633 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4634 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4635 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4637 while (nl < b->end && *nl != NATIVE_0xd)
4639 if (nl < b->end && *nl == NATIVE_0xd) {
4641 if (nl + 1 < b->end) {
4642 if (nl[1] == NATIVE_0xa) {
4648 * Not CR,LF but just CR
4656 * Blast - found CR as last char in buffer
4661 * They may not care, defer work as long as
4665 return (nl - b->ptr);
4669 b->ptr++; /* say we have read it as far as
4670 * flush() is concerned */
4671 b->buf++; /* Leave space in front of buffer */
4672 /* Note as we have moved buf up flush's
4674 will naturally make posn point at CR
4676 b->bufsiz--; /* Buffer is thus smaller */
4677 code = PerlIO_fill(f); /* Fetch some more */
4678 b->bufsiz++; /* Restore size for next time */
4679 b->buf--; /* Point at space */
4680 b->ptr = nl = b->buf; /* Which is what we hand
4682 *nl = NATIVE_0xd; /* Fill in the CR */
4684 goto test; /* fill() call worked */
4686 * CR at EOF - just fall through
4688 /* Should we clear EOF though ??? */
4693 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4699 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4701 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4702 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4708 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4709 /* Deferred CR at end of buffer case - we lied about count */
4722 * Test code - delete when it works ...
4724 IV flags = PerlIOBase(f)->flags;
4725 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4726 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4727 /* Deferred CR at end of buffer case - we lied about count */
4733 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4734 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4735 flags, c->nl, b->end, cnt);
4742 * They have taken what we lied about
4744 *(c->nl) = NATIVE_0xd;
4750 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4754 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4756 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4757 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4759 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4760 const STDCHAR *buf = (const STDCHAR *) vbuf;
4761 const STDCHAR * const ebuf = buf + count;
4764 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4766 while (buf < ebuf) {
4767 const STDCHAR * const eptr = b->buf + b->bufsiz;
4768 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4769 while (buf < ebuf && b->ptr < eptr) {
4771 if ((b->ptr + 2) > eptr) {
4779 *(b->ptr)++ = NATIVE_0xd; /* CR */
4780 *(b->ptr)++ = NATIVE_0xa; /* LF */
4782 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4789 *(b->ptr)++ = *buf++;
4791 if (b->ptr >= eptr) {
4797 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4799 return (buf - (STDCHAR *) vbuf);
4804 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4806 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4808 *(c->nl) = NATIVE_0xd;
4811 return PerlIOBuf_flush(aTHX_ f);
4815 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4817 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4818 /* In text mode - flush any pending stuff and flip it */
4819 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4820 #ifndef PERLIO_USING_CRLF
4821 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4822 PerlIO_pop(aTHX_ f);
4825 return PerlIOBase_binmode(aTHX_ f);
4828 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4829 sizeof(PerlIO_funcs),
4832 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4834 PerlIOBuf_popped, /* popped */
4836 PerlIOCrlf_binmode, /* binmode */
4840 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4841 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4842 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4850 PerlIOBase_clearerr,
4851 PerlIOBase_setlinebuf,
4856 PerlIOCrlf_set_ptrcnt,
4860 Perl_PerlIO_stdin(pTHX)
4863 PerlIO_stdstreams(aTHX);
4865 return (PerlIO*)&PL_perlio[1];
4869 Perl_PerlIO_stdout(pTHX)
4872 PerlIO_stdstreams(aTHX);
4874 return (PerlIO*)&PL_perlio[2];
4878 Perl_PerlIO_stderr(pTHX)
4881 PerlIO_stdstreams(aTHX);
4883 return (PerlIO*)&PL_perlio[3];
4886 /*--------------------------------------------------------------------------------------*/
4889 PerlIO_getname(PerlIO *f, char *buf)
4894 bool exported = FALSE;
4895 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4897 stdio = PerlIO_exportFILE(f,0);
4901 name = fgetname(stdio, buf);
4902 if (exported) PerlIO_releaseFILE(f,stdio);
4907 PERL_UNUSED_ARG(buf);
4908 Perl_croak_nocontext("Don't know how to get file name");
4914 /*--------------------------------------------------------------------------------------*/
4916 * Functions which can be called on any kind of PerlIO implemented in
4920 #undef PerlIO_fdopen
4922 PerlIO_fdopen(int fd, const char *mode)
4925 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4930 PerlIO_open(const char *path, const char *mode)
4933 SV *name = sv_2mortal(newSVpv(path, 0));
4934 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4937 #undef Perlio_reopen
4939 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4942 SV *name = sv_2mortal(newSVpv(path,0));
4943 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4948 PerlIO_getc(PerlIO *f)
4952 if ( 1 == PerlIO_read(f, buf, 1) ) {
4953 return (unsigned char) buf[0];
4958 #undef PerlIO_ungetc
4960 PerlIO_ungetc(PerlIO *f, int ch)
4965 if (PerlIO_unread(f, &buf, 1) == 1)
4973 PerlIO_putc(PerlIO *f, int ch)
4977 return PerlIO_write(f, &buf, 1);
4982 PerlIO_puts(PerlIO *f, const char *s)
4985 return PerlIO_write(f, s, strlen(s));
4988 #undef PerlIO_rewind
4990 PerlIO_rewind(PerlIO *f)
4993 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4997 #undef PerlIO_vprintf
4999 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5008 Perl_va_copy(ap, apc);
5009 sv = vnewSVpvf(fmt, &apc);
5012 sv = vnewSVpvf(fmt, &ap);
5014 s = SvPV_const(sv, len);
5015 wrote = PerlIO_write(f, s, len);
5020 #undef PerlIO_printf
5022 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5027 result = PerlIO_vprintf(f, fmt, ap);
5032 #undef PerlIO_stdoutf
5034 PerlIO_stdoutf(const char *fmt, ...)
5040 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5045 #undef PerlIO_tmpfile
5047 PerlIO_tmpfile(void)
5049 return PerlIO_tmpfile_flags(0);
5052 #define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
5053 #define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
5056 PerlIO_tmpfile_flags(int imode)
5063 const int fd = win32_tmpfd_mode(imode);
5065 f = PerlIO_fdopen(fd, "w+b");
5066 #elif ! defined(OS2)
5068 char tempname[] = "/tmp/PerlIO_XXXXXX";
5069 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5071 int old_umask = umask(0177);
5072 imode &= ~MKOSTEMP_MODE_MASK;
5073 if (tmpdir && *tmpdir) {
5074 /* if TMPDIR is set and not empty, we try that first */
5075 sv = newSVpv(tmpdir, 0);
5076 sv_catpv(sv, tempname + 4);
5077 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
5082 /* else we try /tmp */
5083 fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
5088 sv_catpv(sv, tempname + 4);
5089 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
5093 /* fdopen() with a numeric mode */
5096 (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
5097 f = PerlIO_fdopen(fd, mode);
5099 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5101 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5105 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5106 FILE * const stdio = PerlSIO_tmpfile();
5109 f = PerlIO_fdopen(fileno(stdio), "w+");
5111 #endif /* else WIN32 */
5116 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5118 PERL_UNUSED_CONTEXT;
5119 if (!PerlIOValid(f))
5121 PerlIOBase(f)->err = errno;
5123 PerlIOBase(f)->os_err = vaxc$errno;
5125 PerlIOBase(f)->os_err = Perl_rc;
5126 #elif defined(WIN32)
5127 PerlIOBase(f)->os_err = GetLastError();
5132 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5134 PERL_UNUSED_CONTEXT;
5135 if (!PerlIOValid(f))
5137 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5139 Perl_rc = PerlIOBase(f)->os_err);
5140 #elif defined(WIN32)
5141 SetLastError(PerlIOBase(f)->os_err);
5149 /*======================================================================================*/
5151 * Now some functions in terms of above which may be needed even if we are
5152 * not in true PerlIO mode
5155 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5157 const char *direction = NULL;
5160 * Need to supply default layer info from open.pm
5166 if (mode && mode[0] != 'r') {
5167 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5168 direction = "open>";
5170 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5171 direction = "open<";
5176 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5179 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5184 #undef PerlIO_setpos
5186 PerlIO_setpos(PerlIO *f, SV *pos)
5192 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5193 if(len == sizeof(Off_t))
5194 return PerlIO_seek(f, *posn, SEEK_SET);
5197 SETERRNO(EINVAL, SS_IVCHAN);
5201 #undef PerlIO_setpos
5203 PerlIO_setpos(PerlIO *f, SV *pos)
5209 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5210 if(len == sizeof(Fpos_t))
5211 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5212 return fsetpos64(f, fpos);
5214 return fsetpos(f, fpos);
5218 SETERRNO(EINVAL, SS_IVCHAN);
5224 #undef PerlIO_getpos
5226 PerlIO_getpos(PerlIO *f, SV *pos)
5229 Off_t posn = PerlIO_tell(f);
5230 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5231 return (posn == (Off_t) - 1) ? -1 : 0;
5234 #undef PerlIO_getpos
5236 PerlIO_getpos(PerlIO *f, SV *pos)
5241 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5242 code = fgetpos64(f, &fpos);
5244 code = fgetpos(f, &fpos);
5246 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5251 /* print a failure format string message to stderr and fail exit the process
5252 using only libc without depending on any perl data structures being
5257 Perl_noperl_die(const char* pat, ...)
5260 PERL_ARGS_ASSERT_NOPERL_DIE;
5261 va_start(arglist, pat);
5262 vfprintf(stderr, pat, arglist);
5268 * ex: set ts=8 sts=4 sw=4 et: