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));
374 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
375 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
377 const char *s = CopFILE(PL_curcop);
379 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
380 (IV) CopLINE(PL_curcop));
381 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
383 s = SvPV_const(sv, len);
384 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
391 /*--------------------------------------------------------------------------------------*/
394 * Inner level routines
397 /* check that the head field of each layer points back to the head */
400 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
402 PerlIO_verify_head(pTHX_ PerlIO *f)
406 #ifndef PERL_IMPLICIT_SYS
411 p = head = PerlIOBase(f)->head;
414 assert(p->head == head);
415 if (p == (PerlIOl*)f)
422 # define VERIFY_HEAD(f)
427 * Table of pointers to the PerlIO structs (malloc'ed)
429 #define PERLIO_TABLE_SIZE 64
432 PerlIO_init_table(pTHX)
436 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
442 PerlIO_allocate(pTHX)
445 * Find a free slot in the table, allocating new table as necessary
450 while ((f = *last)) {
452 last = (PerlIOl **) (f);
453 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
454 if (!((++f)->next)) {
459 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
463 *last = (PerlIOl*) f++;
466 f->flags = 0; /* lockcnt */
472 #undef PerlIO_fdupopen
474 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
476 if (PerlIOValid(f)) {
477 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
478 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
480 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
482 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
486 SETERRNO(EBADF, SS_IVCHAN);
492 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
494 PerlIOl * const table = *tablep;
497 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
498 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
499 PerlIOl * const f = table + i;
501 PerlIO_close(&(f->next));
511 PerlIO_list_alloc(pTHX)
515 Newxz(list, 1, PerlIO_list_t);
521 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
524 if (--list->refcnt == 0) {
527 for (i = 0; i < list->cur; i++)
528 SvREFCNT_dec(list->array[i].arg);
529 Safefree(list->array);
537 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
542 if (list->cur >= list->len) {
543 const IV new_len = list->len + 8;
545 Renew(list->array, new_len, PerlIO_pair_t);
547 Newx(list->array, new_len, PerlIO_pair_t);
550 p = &(list->array[list->cur++]);
552 if ((p->arg = arg)) {
553 SvREFCNT_inc_simple_void_NN(arg);
558 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
560 PerlIO_list_t *list = NULL;
563 list = PerlIO_list_alloc(aTHX);
564 for (i=0; i < proto->cur; i++) {
565 SV *arg = proto->array[i].arg;
568 arg = sv_dup(arg, param);
570 PERL_UNUSED_ARG(param);
572 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
579 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
582 PerlIOl **table = &proto->Iperlio;
585 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
586 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
587 PerlIO_init_table(aTHX);
588 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
589 while ((f = *table)) {
591 table = (PerlIOl **) (f++);
592 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
594 (void) fp_dup(&(f->next), 0, param);
601 PERL_UNUSED_ARG(proto);
602 PERL_UNUSED_ARG(param);
607 PerlIO_destruct(pTHX)
609 PerlIOl **table = &PL_perlio;
612 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
614 while ((f = *table)) {
616 table = (PerlIOl **) (f++);
617 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
618 PerlIO *x = &(f->next);
621 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
622 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
636 PerlIO_pop(pTHX_ PerlIO *f)
638 const PerlIOl *l = *f;
641 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
642 l->tab ? l->tab->name : "(Null)") );
643 if (l->tab && l->tab->Popped) {
645 * If popped returns non-zero do not free its layer structure
646 * it has either done so itself, or it is shared and still in
649 if ((*l->tab->Popped) (aTHX_ f) != 0)
652 if (PerlIO_lockcnt(f)) {
653 /* we're in use; defer freeing the structure */
654 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
655 PerlIOBase(f)->tab = NULL;
665 /* Return as an array the stack of layers on a filehandle. Note that
666 * the stack is returned top-first in the array, and there are three
667 * times as many array elements as there are layers in the stack: the
668 * first element of a layer triplet is the name, the second one is the
669 * arguments, and the third one is the flags. */
672 PerlIO_get_layers(pTHX_ PerlIO *f)
674 AV * const av = newAV();
676 if (PerlIOValid(f)) {
677 PerlIOl *l = PerlIOBase(f);
680 /* There is some collusion in the implementation of
681 XS_PerlIO_get_layers - it knows that name and flags are
682 generated as fresh SVs here, and takes advantage of that to
683 "copy" them by taking a reference. If it changes here, it needs
684 to change there too. */
685 SV * const name = l->tab && l->tab->name ?
686 newSVpv(l->tab->name, 0) : &PL_sv_undef;
687 SV * const arg = l->tab && l->tab->Getarg ?
688 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
691 av_push(av, newSViv((IV)l->flags));
699 /*--------------------------------------------------------------------------------------*/
701 * XS Interface for perl code
705 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
709 if ((SSize_t) len <= 0)
711 for (i = 0; i < PL_known_layers->cur; i++) {
712 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
713 const STRLEN this_len = strlen(f->name);
714 if (this_len == len && memEQ(f->name, name, len)) {
715 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
719 if (load && PL_subname && PL_def_layerlist
720 && PL_def_layerlist->cur >= 2) {
721 if (PL_in_load_module) {
722 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
725 SV * const pkgsv = newSVpvs("PerlIO");
726 SV * const layer = newSVpvn(name, len);
727 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
729 SAVEBOOL(PL_in_load_module);
731 SAVEGENERICSV(PL_warnhook);
732 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
734 PL_in_load_module = TRUE;
736 * The two SVs are magically freed by load_module
738 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
740 return PerlIO_find_layer(aTHX_ name, len, 0);
743 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
747 #ifdef USE_ATTRIBUTES_FOR_PERLIO
750 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
753 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
754 PerlIO * const ifp = IoIFP(io);
755 PerlIO * const ofp = IoOFP(io);
756 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
757 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
763 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
766 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
767 PerlIO * const ifp = IoIFP(io);
768 PerlIO * const ofp = IoOFP(io);
769 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
770 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
776 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
778 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
783 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
785 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
789 MGVTBL perlio_vtab = {
797 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
798 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
801 SV * const sv = SvRV(ST(1));
802 AV * const av = newAV();
806 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
808 mg = mg_find(sv, PERL_MAGIC_ext);
809 mg->mg_virtual = &perlio_vtab;
811 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
812 for (i = 2; i < items; i++) {
814 const char * const name = SvPV_const(ST(i), len);
815 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
817 av_push(av, SvREFCNT_inc_simple_NN(layer));
828 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
831 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
833 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
834 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
838 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
839 XS(XS_PerlIO__Layer__NoWarnings)
841 /* This is used as a %SIG{__WARN__} handler to suppress warnings
842 during loading of layers.
845 PERL_UNUSED_VAR(items);
848 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
852 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
853 XS(XS_PerlIO__Layer__find)
857 Perl_croak(aTHX_ "Usage class->find(name[,load])");
860 const char * const name = SvPV_const(ST(1), len);
861 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
862 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
864 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
871 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
873 if (!PL_known_layers)
874 PL_known_layers = PerlIO_list_alloc(aTHX);
875 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
876 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
880 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
883 const char *s = names;
885 while (isSPACE(*s) || *s == ':')
890 const char *as = NULL;
892 if (!isIDFIRST(*s)) {
894 * Message is consistent with how attribute lists are
895 * passed. Even though this means "foo : : bar" is
896 * seen as an invalid separator character.
898 const char q = ((*s == '\'') ? '"' : '\'');
899 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
900 "Invalid separator character %c%c%c in PerlIO layer specification %s",
902 SETERRNO(EINVAL, LIB_INVARG);
907 } while (isWORDCHAR(*e));
923 * It's a nul terminated string, not allowed
924 * to \ the terminating null. Anything other
925 * character is passed over.
933 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
934 "Argument list not closed for PerlIO layer \"%.*s\"",
946 PerlIO_funcs * const layer =
947 PerlIO_find_layer(aTHX_ s, llen, 1);
951 arg = newSVpvn(as, alen);
952 PerlIO_list_push(aTHX_ av, layer,
953 (arg) ? arg : &PL_sv_undef);
957 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
970 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
972 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
973 #ifdef PERLIO_USING_CRLF
976 if (PerlIO_stdio.Set_ptrcnt)
979 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
980 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
984 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
986 return av->array[n].arg;
990 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
992 if (n >= 0 && n < av->cur) {
993 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
994 av->array[n].funcs->name) );
995 return av->array[n].funcs;
998 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1003 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1005 PERL_UNUSED_ARG(mode);
1006 PERL_UNUSED_ARG(arg);
1007 PERL_UNUSED_ARG(tab);
1008 if (PerlIOValid(f)) {
1010 PerlIO_pop(aTHX_ f);
1016 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1017 sizeof(PerlIO_funcs),
1020 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1040 NULL, /* get_base */
1041 NULL, /* get_bufsiz */
1044 NULL, /* set_ptrcnt */
1048 PerlIO_default_layers(pTHX)
1050 if (!PL_def_layerlist) {
1051 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1052 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1053 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1054 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1056 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1058 osLayer = &PerlIO_win32;
1061 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1062 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1063 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1064 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1065 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1067 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1068 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1071 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1074 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1077 if (PL_def_layerlist->cur < 2) {
1078 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1080 return PL_def_layerlist;
1084 Perl_boot_core_PerlIO(pTHX)
1086 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1087 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1090 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1091 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1095 PerlIO_default_layer(pTHX_ I32 n)
1097 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1100 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1103 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1104 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1107 PerlIO_stdstreams(pTHX)
1110 PerlIO_init_table(aTHX);
1111 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1112 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1113 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1118 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1121 if (tab->fsize != sizeof(PerlIO_funcs)) {
1123 "%s (%" UVuf ") does not match %s (%" UVuf ")",
1124 "PerlIO layer function table size", (UV)tab->fsize,
1125 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1129 if (tab->size < sizeof(PerlIOl)) {
1131 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1132 "PerlIO layer instance size", (UV)tab->size,
1133 "size expected by this perl", (UV)sizeof(PerlIOl) );
1135 /* Real layer with a data area */
1138 Newxz(temp, tab->size, char);
1142 l->tab = (PerlIO_funcs*) tab;
1143 l->head = ((PerlIOl*)f)->head;
1145 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1146 (void*)f, tab->name,
1147 (mode) ? mode : "(Null)", (void*)arg) );
1148 if (*l->tab->Pushed &&
1150 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1151 PerlIO_pop(aTHX_ f);
1160 /* Pseudo-layer where push does its own stack adjust */
1161 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1162 (mode) ? mode : "(Null)", (void*)arg) );
1164 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1172 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1173 IV n, const char *mode, int fd, int imode, int perm,
1174 PerlIO *old, int narg, SV **args)
1176 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1177 if (tab && tab->Open) {
1178 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1179 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1185 SETERRNO(EINVAL, LIB_INVARG);
1190 PerlIOBase_binmode(pTHX_ PerlIO *f)
1192 if (PerlIOValid(f)) {
1193 /* Is layer suitable for raw stream ? */
1194 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1195 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1196 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1199 /* Not suitable - pop it */
1200 PerlIO_pop(aTHX_ f);
1208 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1210 PERL_UNUSED_ARG(mode);
1211 PERL_UNUSED_ARG(arg);
1212 PERL_UNUSED_ARG(tab);
1214 if (PerlIOValid(f)) {
1219 * Strip all layers that are not suitable for a raw stream
1222 while (t && (l = *t)) {
1223 if (l->tab && l->tab->Binmode) {
1224 /* Has a handler - normal case */
1225 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1227 /* Layer still there - move down a layer */
1236 /* No handler - pop it */
1237 PerlIO_pop(aTHX_ t);
1240 if (PerlIOValid(f)) {
1241 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1242 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1250 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1251 PerlIO_list_t *layers, IV n, IV max)
1255 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1257 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1268 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1272 save_scalar(PL_errgv);
1274 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1275 code = PerlIO_parse_layers(aTHX_ layers, names);
1277 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1279 PerlIO_list_free(aTHX_ layers);
1286 /*--------------------------------------------------------------------------------------*/
1288 * Given the abstraction above the public API functions
1292 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1294 PERL_UNUSED_ARG(iotype);
1295 PERL_UNUSED_ARG(mode);
1298 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1299 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1300 PerlIOBase(f)->tab->name : "(Null)",
1301 iotype, mode, (names) ? names : "(Null)") );
1304 /* Do not flush etc. if (e.g.) switching encodings.
1305 if a pushed layer knows it needs to flush lower layers
1306 (for example :unix which is never going to call them)
1307 it can do the flush when it is pushed.
1309 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1312 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1313 #ifdef PERLIO_USING_CRLF
1314 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1315 O_BINARY so we can look for it in mode.
1317 if (!(mode & O_BINARY)) {
1319 /* FIXME?: Looking down the layer stack seems wrong,
1320 but is a way of reaching past (say) an encoding layer
1321 to flip CRLF-ness of the layer(s) below
1324 /* Perhaps we should turn on bottom-most aware layer
1325 e.g. Ilya's idea that UNIX TTY could serve
1327 if (PerlIOBase(f)->tab &&
1328 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1330 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1331 /* Not in text mode - flush any pending stuff and flip it */
1333 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1335 /* Only need to turn it on in one layer so we are done */
1340 /* Not finding a CRLF aware layer presumably means we are binary
1341 which is not what was requested - so we failed
1342 We _could_ push :crlf layer but so could caller
1347 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1348 So code that used to be here is now in PerlIORaw_pushed().
1350 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1355 PerlIO__close(pTHX_ PerlIO *f)
1357 if (PerlIOValid(f)) {
1358 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1359 if (tab && tab->Close)
1360 return (*tab->Close)(aTHX_ f);
1362 return PerlIOBase_close(aTHX_ f);
1365 SETERRNO(EBADF, SS_IVCHAN);
1371 Perl_PerlIO_close(pTHX_ PerlIO *f)
1373 const int code = PerlIO__close(aTHX_ f);
1374 while (PerlIOValid(f)) {
1375 PerlIO_pop(aTHX_ f);
1376 if (PerlIO_lockcnt(f))
1377 /* we're in use; the 'pop' deferred freeing the structure */
1384 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1386 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1390 static PerlIO_funcs *
1391 PerlIO_layer_from_ref(pTHX_ SV *sv)
1394 * For any scalar type load the handler which is bundled with perl
1396 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1397 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1398 /* This isn't supposed to happen, since PerlIO::scalar is core,
1399 * but could happen anyway in smaller installs or with PAR */
1401 /* diag_listed_as: Unknown PerlIO layer "%s" */
1402 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1407 * For other types allow if layer is known but don't try and load it
1409 switch (SvTYPE(sv)) {
1411 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1413 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1415 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1417 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1424 PerlIO_resolve_layers(pTHX_ const char *layers,
1425 const char *mode, int narg, SV **args)
1427 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1430 PerlIO_stdstreams(aTHX);
1432 SV * const arg = *args;
1434 * If it is a reference but not an object see if we have a handler
1437 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1438 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1440 def = PerlIO_list_alloc(aTHX);
1441 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1445 * Don't fail if handler cannot be found :via(...) etc. may do
1446 * something sensible else we will just stringfy and open
1451 if (!layers || !*layers)
1452 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1453 if (layers && *layers) {
1456 av = PerlIO_clone_list(aTHX_ def, NULL);
1461 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1465 PerlIO_list_free(aTHX_ av);
1477 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1478 int imode, int perm, PerlIO *f, int narg, SV **args)
1480 if (!f && narg == 1 && *args == &PL_sv_undef) {
1481 if ((f = PerlIO_tmpfile())) {
1482 if (!layers || !*layers)
1483 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1484 if (layers && *layers)
1485 PerlIO_apply_layers(aTHX_ f, mode, layers);
1489 PerlIO_list_t *layera;
1491 PerlIO_funcs *tab = NULL;
1492 if (PerlIOValid(f)) {
1494 * This is "reopen" - it is not tested as perl does not use it
1498 layera = PerlIO_list_alloc(aTHX);
1501 if (l->tab && l->tab->Getarg)
1502 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1503 PerlIO_list_push(aTHX_ layera, l->tab,
1504 (arg) ? arg : &PL_sv_undef);
1506 l = *PerlIONext(&l);
1510 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1516 * Start at "top" of layer stack
1518 n = layera->cur - 1;
1520 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1529 * Found that layer 'n' can do opens - call it
1531 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1532 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1534 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1535 tab->name, layers ? layers : "(Null)", mode, fd,
1536 imode, perm, (void*)f, narg, (void*)args) );
1538 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1541 SETERRNO(EINVAL, LIB_INVARG);
1545 if (n + 1 < layera->cur) {
1547 * More layers above the one that we used to open -
1550 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1551 /* If pushing layers fails close the file */
1558 PerlIO_list_free(aTHX_ layera);
1565 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1567 PERL_ARGS_ASSERT_PERLIO_READ;
1569 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1573 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1575 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1577 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1581 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1583 PERL_ARGS_ASSERT_PERLIO_WRITE;
1585 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1589 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1591 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1595 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1597 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1601 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1605 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1607 if (tab && tab->Flush)
1608 return (*tab->Flush) (aTHX_ f);
1610 return 0; /* If no Flush defined, silently succeed. */
1613 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1614 SETERRNO(EBADF, SS_IVCHAN);
1620 * Is it good API design to do flush-all on NULL, a potentially
1621 * erroneous input? Maybe some magical value (PerlIO*
1622 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1623 * things on fflush(NULL), but should we be bound by their design
1626 PerlIOl **table = &PL_perlio;
1629 while ((ff = *table)) {
1631 table = (PerlIOl **) (ff++);
1632 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1633 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1643 PerlIOBase_flush_linebuf(pTHX)
1645 PerlIOl **table = &PL_perlio;
1647 while ((f = *table)) {
1649 table = (PerlIOl **) (f++);
1650 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1652 && (PerlIOBase(&(f->next))->
1653 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1654 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1655 PerlIO_flush(&(f->next));
1662 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1664 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1668 PerlIO_isutf8(PerlIO *f)
1671 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1673 SETERRNO(EBADF, SS_IVCHAN);
1679 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1681 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1685 Perl_PerlIO_error(pTHX_ PerlIO *f)
1687 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1691 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1693 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1697 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1699 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1703 PerlIO_has_base(PerlIO *f)
1705 if (PerlIOValid(f)) {
1706 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1709 return (tab->Get_base != NULL);
1716 PerlIO_fast_gets(PerlIO *f)
1718 if (PerlIOValid(f)) {
1719 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1720 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1723 return (tab->Set_ptrcnt != NULL);
1731 PerlIO_has_cntptr(PerlIO *f)
1733 if (PerlIOValid(f)) {
1734 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1737 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1744 PerlIO_canset_cnt(PerlIO *f)
1746 if (PerlIOValid(f)) {
1747 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1750 return (tab->Set_ptrcnt != NULL);
1757 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1759 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1763 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1765 /* Note that Get_bufsiz returns a Size_t */
1766 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1770 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1772 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1776 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1778 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1782 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1784 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1788 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1790 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1794 /*--------------------------------------------------------------------------------------*/
1796 * utf8 and raw dummy layers
1800 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1802 PERL_UNUSED_CONTEXT;
1803 PERL_UNUSED_ARG(mode);
1804 PERL_UNUSED_ARG(arg);
1805 if (PerlIOValid(f)) {
1806 if (tab && tab->kind & PERLIO_K_UTF8)
1807 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1809 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1815 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1816 sizeof(PerlIO_funcs),
1819 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1839 NULL, /* get_base */
1840 NULL, /* get_bufsiz */
1843 NULL, /* set_ptrcnt */
1846 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1847 sizeof(PerlIO_funcs),
1850 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1870 NULL, /* get_base */
1871 NULL, /* get_bufsiz */
1874 NULL, /* set_ptrcnt */
1877 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1878 sizeof(PerlIO_funcs),
1901 NULL, /* get_base */
1902 NULL, /* get_bufsiz */
1905 NULL, /* set_ptrcnt */
1907 /*--------------------------------------------------------------------------------------*/
1908 /*--------------------------------------------------------------------------------------*/
1910 * "Methods" of the "base class"
1914 PerlIOBase_fileno(pTHX_ PerlIO *f)
1916 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1920 PerlIO_modestr(PerlIO * f, char *buf)
1923 if (PerlIOValid(f)) {
1924 const IV flags = PerlIOBase(f)->flags;
1925 if (flags & PERLIO_F_APPEND) {
1927 if (flags & PERLIO_F_CANREAD) {
1931 else if (flags & PERLIO_F_CANREAD) {
1933 if (flags & PERLIO_F_CANWRITE)
1936 else if (flags & PERLIO_F_CANWRITE) {
1938 if (flags & PERLIO_F_CANREAD) {
1942 #ifdef PERLIO_USING_CRLF
1943 if (!(flags & PERLIO_F_CRLF))
1953 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1955 PerlIOl * const l = PerlIOBase(f);
1956 PERL_UNUSED_CONTEXT;
1957 PERL_UNUSED_ARG(arg);
1959 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1960 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1961 if (tab && tab->Set_ptrcnt != NULL)
1962 l->flags |= PERLIO_F_FASTGETS;
1964 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1968 l->flags |= PERLIO_F_CANREAD;
1971 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1974 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1977 SETERRNO(EINVAL, LIB_INVARG);
1982 /* The mode variable contains one positional parameter followed by
1983 * optional keyword parameters. The positional parameters must be
1984 * passed as lowercase characters. The keyword parameters can be
1985 * passed in mixed case. They must be separated by commas. Only one
1986 * instance of a keyword can be specified. */
1992 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1996 l->flags &= ~PERLIO_F_CRLF;
2000 l->flags |= PERLIO_F_CRLF;
2014 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2017 l->flags &= ~PERLIO_F_CRLF;
2020 l->flags |= PERLIO_F_CRLF;
2023 SETERRNO(EINVAL, LIB_INVARG);
2031 l->flags |= l->next->flags &
2032 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2038 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2039 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2040 l->flags, PerlIO_modestr(f, temp));
2047 PerlIOBase_popped(pTHX_ PerlIO *f)
2049 PERL_UNUSED_CONTEXT;
2055 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2058 * Save the position as current head considers it
2060 const Off_t old = PerlIO_tell(f);
2061 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2062 PerlIOSelf(f, PerlIOBuf)->posn = old;
2063 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2067 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2069 STDCHAR *buf = (STDCHAR *) vbuf;
2071 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2072 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2073 SETERRNO(EBADF, SS_IVCHAN);
2074 PerlIO_save_errno(f);
2080 SSize_t avail = PerlIO_get_cnt(f);
2083 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2085 STDCHAR *ptr = PerlIO_get_ptr(f);
2086 Copy(ptr, buf, take, STDCHAR);
2087 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2090 if (avail == 0) /* set_ptrcnt could have reset avail */
2093 if (count > 0 && avail <= 0) {
2094 if (PerlIO_fill(f) != 0)
2099 return (buf - (STDCHAR *) vbuf);
2105 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2107 PERL_UNUSED_CONTEXT;
2113 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2115 PERL_UNUSED_CONTEXT;
2121 PerlIOBase_close(pTHX_ PerlIO *f)
2124 if (PerlIOValid(f)) {
2125 PerlIO *n = PerlIONext(f);
2126 code = PerlIO_flush(f);
2127 PerlIOBase(f)->flags &=
2128 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2129 while (PerlIOValid(n)) {
2130 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2131 if (tab && tab->Close) {
2132 if ((*tab->Close)(aTHX_ n) != 0)
2137 PerlIOBase(n)->flags &=
2138 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2144 SETERRNO(EBADF, SS_IVCHAN);
2150 PerlIOBase_eof(pTHX_ PerlIO *f)
2152 PERL_UNUSED_CONTEXT;
2153 if (PerlIOValid(f)) {
2154 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2160 PerlIOBase_error(pTHX_ PerlIO *f)
2162 PERL_UNUSED_CONTEXT;
2163 if (PerlIOValid(f)) {
2164 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2170 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2172 if (PerlIOValid(f)) {
2173 PerlIO * const n = PerlIONext(f);
2174 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2181 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2183 PERL_UNUSED_CONTEXT;
2184 if (PerlIOValid(f)) {
2185 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2190 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2196 arg = sv_dup(arg, param);
2197 SvREFCNT_inc_simple_void_NN(arg);
2201 return newSVsv(arg);
2204 PERL_UNUSED_ARG(param);
2205 return newSVsv(arg);
2210 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2212 PerlIO * const nexto = PerlIONext(o);
2213 if (PerlIOValid(nexto)) {
2214 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2215 if (tab && tab->Dup)
2216 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2218 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2221 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2225 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2227 (void*)f, (void*)o, (void*)param) );
2229 arg = (*self->Getarg)(aTHX_ o, param, flags);
2230 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2231 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2232 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2238 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2240 /* Must be called with PL_perlio_mutex locked. */
2242 S_more_refcounted_fds(pTHX_ const int new_fd)
2243 PERL_TSA_REQUIRES(PL_perlio_mutex)
2246 const int old_max = PL_perlio_fd_refcnt_size;
2247 const int new_max = 16 + (new_fd & ~15);
2250 #ifndef PERL_IMPLICIT_SYS
2251 PERL_UNUSED_CONTEXT;
2254 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2255 old_max, new_fd, new_max) );
2257 if (new_fd < old_max) {
2261 assert (new_max > new_fd);
2263 /* Use plain realloc() since we need this memory to be really
2264 * global and visible to all the interpreters and/or threads. */
2265 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2268 MUTEX_UNLOCK(&PL_perlio_mutex);
2272 PL_perlio_fd_refcnt_size = new_max;
2273 PL_perlio_fd_refcnt = new_array;
2275 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2276 (void*)(new_array + old_max),
2277 new_max - old_max) );
2279 Zero(new_array + old_max, new_max - old_max, int);
2286 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2287 PERL_UNUSED_CONTEXT;
2291 PerlIOUnix_refcnt_inc(int fd)
2297 MUTEX_LOCK(&PL_perlio_mutex);
2298 if (fd >= PL_perlio_fd_refcnt_size)
2299 S_more_refcounted_fds(aTHX_ fd);
2301 PL_perlio_fd_refcnt[fd]++;
2302 if (PL_perlio_fd_refcnt[fd] <= 0) {
2303 /* diag_listed_as: refcnt_inc: fd %d%s */
2304 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2305 fd, PL_perlio_fd_refcnt[fd]);
2307 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2308 fd, PL_perlio_fd_refcnt[fd]) );
2310 MUTEX_UNLOCK(&PL_perlio_mutex);
2312 /* diag_listed_as: refcnt_inc: fd %d%s */
2313 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2318 PerlIOUnix_refcnt_dec(int fd)
2327 MUTEX_LOCK(&PL_perlio_mutex);
2328 if (fd >= PL_perlio_fd_refcnt_size) {
2329 /* diag_listed_as: refcnt_dec: fd %d%s */
2330 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2331 fd, PL_perlio_fd_refcnt_size);
2333 if (PL_perlio_fd_refcnt[fd] <= 0) {
2334 /* diag_listed_as: refcnt_dec: fd %d%s */
2335 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2336 fd, PL_perlio_fd_refcnt[fd]);
2338 cnt = --PL_perlio_fd_refcnt[fd];
2339 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2340 MUTEX_UNLOCK(&PL_perlio_mutex);
2342 /* diag_listed_as: refcnt_dec: fd %d%s */
2343 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2349 PerlIOUnix_refcnt(int fd)
2355 MUTEX_LOCK(&PL_perlio_mutex);
2356 if (fd >= PL_perlio_fd_refcnt_size) {
2357 /* diag_listed_as: refcnt: fd %d%s */
2358 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2359 fd, PL_perlio_fd_refcnt_size);
2361 if (PL_perlio_fd_refcnt[fd] <= 0) {
2362 /* diag_listed_as: refcnt: fd %d%s */
2363 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2364 fd, PL_perlio_fd_refcnt[fd]);
2366 cnt = PL_perlio_fd_refcnt[fd];
2367 MUTEX_UNLOCK(&PL_perlio_mutex);
2369 /* diag_listed_as: refcnt: fd %d%s */
2370 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2376 PerlIO_cleanup(pTHX)
2380 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2382 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2385 /* Raise STDIN..STDERR refcount so we don't close them */
2386 for (i=0; i < 3; i++)
2387 PerlIOUnix_refcnt_inc(i);
2388 PerlIO_cleantable(aTHX_ &PL_perlio);
2389 /* Restore STDIN..STDERR refcount */
2390 for (i=0; i < 3; i++)
2391 PerlIOUnix_refcnt_dec(i);
2393 if (PL_known_layers) {
2394 PerlIO_list_free(aTHX_ PL_known_layers);
2395 PL_known_layers = NULL;
2397 if (PL_def_layerlist) {
2398 PerlIO_list_free(aTHX_ PL_def_layerlist);
2399 PL_def_layerlist = NULL;
2403 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2407 /* XXX we can't rely on an interpreter being present at this late stage,
2408 XXX so we can't use a function like PerlLIO_write that relies on one
2409 being present (at least in win32) :-(.
2414 /* By now all filehandles should have been closed, so any
2415 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2417 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2418 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2419 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2421 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2422 if (PL_perlio_fd_refcnt[i]) {
2424 my_snprintf(buf, sizeof(buf),
2425 "PerlIO_teardown: fd %d refcnt=%d\n",
2426 i, PL_perlio_fd_refcnt[i]);
2427 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2433 /* Not bothering with PL_perlio_mutex since by now
2434 * all the interpreters are gone. */
2435 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2436 && PL_perlio_fd_refcnt) {
2437 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2438 PL_perlio_fd_refcnt = NULL;
2439 PL_perlio_fd_refcnt_size = 0;
2443 /*--------------------------------------------------------------------------------------*/
2445 * Bottom-most level for UNIX-like case
2449 struct _PerlIO base; /* The generic part */
2450 int fd; /* UNIX like file descriptor */
2451 int oflags; /* open/fcntl flags */
2455 S_lockcnt_dec(pTHX_ const void* f)
2457 #ifndef PERL_IMPLICIT_SYS
2458 PERL_UNUSED_CONTEXT;
2460 PerlIO_lockcnt((PerlIO*)f)--;
2464 /* call the signal handler, and if that handler happens to clear
2465 * this handle, free what we can and return true */
2468 S_perlio_async_run(pTHX_ PerlIO* f) {
2470 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2471 PerlIO_lockcnt(f)++;
2473 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2477 /* we've just run some perl-level code that could have done
2478 * anything, including closing the file or clearing this layer.
2479 * If so, free any lower layers that have already been
2480 * cleared, then return an error. */
2481 while (PerlIOValid(f) &&
2482 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2484 const PerlIOl *l = *f;
2493 PerlIOUnix_oflags(const char *mode)
2496 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2501 if (*++mode == '+') {
2508 oflags = O_CREAT | O_TRUNC;
2509 if (*++mode == '+') {
2518 oflags = O_CREAT | O_APPEND;
2519 if (*++mode == '+') {
2528 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2530 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2531 * of them in, and then bit-and-masking the other them away, won't
2532 * have much of an effect. */
2535 #if O_TEXT != O_BINARY
2542 #if O_TEXT != O_BINARY
2544 oflags &= ~O_BINARY;
2550 /* bit-or:ing with zero O_BINARY would be useless. */
2552 * If neither "t" nor "b" was specified, open the file
2555 * Note that if something else than the zero byte was seen
2556 * here (e.g. bogus mode "rx"), just few lines later we will
2557 * set the errno and invalidate the flags.
2563 if (*mode || oflags == -1) {
2564 SETERRNO(EINVAL, LIB_INVARG);
2571 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2573 PERL_UNUSED_CONTEXT;
2574 return PerlIOSelf(f, PerlIOUnix)->fd;
2578 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2580 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2583 if (PerlLIO_fstat(fd, &st) == 0) {
2584 if (!S_ISREG(st.st_mode)) {
2585 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2586 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2589 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2595 PerlIOUnix_refcnt_inc(fd);
2596 PERL_UNUSED_CONTEXT;
2600 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2602 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2603 if (*PerlIONext(f)) {
2604 /* We never call down so do any pending stuff now */
2605 PerlIO_flush(PerlIONext(f));
2607 * XXX could (or should) we retrieve the oflags from the open file
2608 * handle rather than believing the "mode" we are passed in? XXX
2609 * Should the value on NULL mode be 0 or -1?
2611 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2612 mode ? PerlIOUnix_oflags(mode) : -1);
2614 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2620 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2622 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2624 PERL_UNUSED_CONTEXT;
2625 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2627 SETERRNO(ESPIPE, LIB_INVARG);
2629 SETERRNO(EINVAL, LIB_INVARG);
2633 new_loc = PerlLIO_lseek(fd, offset, whence);
2634 if (new_loc == (Off_t) - 1)
2636 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2641 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2642 IV n, const char *mode, int fd, int imode,
2643 int perm, PerlIO *f, int narg, SV **args)
2645 bool known_cloexec = 0;
2646 if (PerlIOValid(f)) {
2647 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2648 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2651 if (*mode == IoTYPE_NUMERIC)
2654 imode = PerlIOUnix_oflags(mode);
2656 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2663 const char *path = SvPV_const(*args, len);
2664 if (!IS_SAFE_PATHNAME(path, len, "open"))
2666 fd = PerlLIO_open3_cloexec(path, imode, perm);
2672 setfd_inhexec_for_sysfd(fd);
2674 setfd_cloexec_or_inhexec_by_sysfdness(fd);
2675 if (*mode == IoTYPE_IMPLICIT)
2678 f = PerlIO_allocate(aTHX);
2680 if (!PerlIOValid(f)) {
2681 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2686 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2687 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2688 if (*mode == IoTYPE_APPEND)
2689 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2696 * FIXME: pop layers ???
2704 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2706 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2708 if (flags & PERLIO_DUP_FD) {
2709 fd = PerlLIO_dup_cloexec(fd);
2711 setfd_inhexec_for_sysfd(fd);
2714 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2716 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2717 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2727 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2730 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2732 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2733 #ifdef PERLIO_STD_SPECIAL
2735 return PERLIO_STD_IN(fd, vbuf, count);
2737 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2738 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2742 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2743 if (len >= 0 || errno != EINTR) {
2745 if (errno != EAGAIN) {
2746 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2747 PerlIO_save_errno(f);
2750 else if (len == 0 && count != 0) {
2751 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2757 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2760 NOT_REACHED; /*NOTREACHED*/
2764 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2767 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2769 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2770 #ifdef PERLIO_STD_SPECIAL
2771 if (fd == 1 || fd == 2)
2772 return PERLIO_STD_OUT(fd, vbuf, count);
2775 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2776 if (len >= 0 || errno != EINTR) {
2778 if (errno != EAGAIN) {
2779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2780 PerlIO_save_errno(f);
2786 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2789 NOT_REACHED; /*NOTREACHED*/
2793 PerlIOUnix_tell(pTHX_ PerlIO *f)
2795 PERL_UNUSED_CONTEXT;
2797 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2802 PerlIOUnix_close(pTHX_ PerlIO *f)
2804 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2806 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2807 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2808 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2813 SETERRNO(EBADF,SS_IVCHAN);
2816 while (PerlLIO_close(fd) != 0) {
2817 if (errno != EINTR) {
2822 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2826 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2831 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2832 sizeof(PerlIO_funcs),
2839 PerlIOBase_binmode, /* binmode */
2849 PerlIOBase_noop_ok, /* flush */
2850 PerlIOBase_noop_fail, /* fill */
2853 PerlIOBase_clearerr,
2854 PerlIOBase_setlinebuf,
2855 NULL, /* get_base */
2856 NULL, /* get_bufsiz */
2859 NULL, /* set_ptrcnt */
2862 /*--------------------------------------------------------------------------------------*/
2867 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2868 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2869 broken by the last second glibc 2.3 fix
2871 #define STDIO_BUFFER_WRITABLE
2876 struct _PerlIO base;
2877 FILE *stdio; /* The stream */
2881 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2883 PERL_UNUSED_CONTEXT;
2885 if (PerlIOValid(f)) {
2886 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2888 return PerlSIO_fileno(s);
2895 PerlIOStdio_mode(const char *mode, char *tmode)
2897 char * const ret = tmode;
2903 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2911 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2914 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2915 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2916 if (toptab == tab) {
2917 /* Top is already stdio - pop self (duplicate) and use original */
2918 PerlIO_pop(aTHX_ f);
2921 const int fd = PerlIO_fileno(n);
2924 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2925 mode = PerlIOStdio_mode(mode, tmode)))) {
2926 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2927 /* We never call down so do any pending stuff now */
2928 PerlIO_flush(PerlIONext(f));
2929 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2936 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2941 PerlIO_importFILE(FILE *stdio, const char *mode)
2947 char filename[FILENAME_MAX];
2952 int fd0 = fileno(stdio);
2955 rc = fldata(stdio,filename,&fileinfo);
2959 if(fileinfo.__dsorgHFS){
2962 /*This MVS dataset , OK!*/
2967 if (!mode || !*mode) {
2968 /* We need to probe to see how we can open the stream
2969 so start with read/write and then try write and read
2970 we dup() so that we can fclose without loosing the fd.
2972 Note that the errno value set by a failing fdopen
2973 varies between stdio implementations.
2975 const int fd = PerlLIO_dup_cloexec(fd0);
2980 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2982 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2985 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2988 /* Don't seem to be able to open */
2994 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2995 s = PerlIOSelf(f, PerlIOStdio);
2997 fd0 = fileno(stdio);
2999 PerlIOUnix_refcnt_inc(fd0);
3000 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3004 rc = fldata(stdio,filename,&fileinfo);
3006 PerlIOUnix_refcnt_inc(fd0);
3008 if(fileinfo.__dsorgHFS){
3009 PerlIOUnix_refcnt_inc(fd0);
3011 /*This MVS dataset , OK!*/
3020 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3021 IV n, const char *mode, int fd, int imode,
3022 int perm, PerlIO *f, int narg, SV **args)
3025 if (PerlIOValid(f)) {
3027 const char * const path = SvPV_const(*args, len);
3028 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3030 if (!IS_SAFE_PATHNAME(path, len, "open"))
3032 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3033 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3039 PerlIOUnix_refcnt_inc(fd);
3040 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3046 const char * const path = SvPV_const(*args, len);
3047 if (!IS_SAFE_PATHNAME(path, len, "open"))
3049 if (*mode == IoTYPE_NUMERIC) {
3051 fd = PerlLIO_open3_cloexec(path, imode, perm);
3055 bool appended = FALSE;
3057 /* Cygwin wants its 'b' early. */
3059 mode = PerlIOStdio_mode(mode, tmode);
3061 stdio = PerlSIO_fopen(path, mode);
3064 f = PerlIO_allocate(aTHX);
3067 mode = PerlIOStdio_mode(mode, tmode);
3068 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3070 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3072 PerlIOUnix_refcnt_inc(fd);
3073 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3075 PerlSIO_fclose(stdio);
3087 if (*mode == IoTYPE_IMPLICIT) {
3094 stdio = PerlSIO_stdin;
3097 stdio = PerlSIO_stdout;
3100 stdio = PerlSIO_stderr;
3105 stdio = PerlSIO_fdopen(fd, mode =
3106 PerlIOStdio_mode(mode, tmode));
3110 f = PerlIO_allocate(aTHX);
3112 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3113 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3115 PerlIOUnix_refcnt_inc(fd);
3116 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3127 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3129 /* This assumes no layers underneath - which is what
3130 happens, but is not how I remember it. NI-S 2001/10/16
3132 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3133 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3134 const int fd = fileno(stdio);
3136 if (flags & PERLIO_DUP_FD) {
3137 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
3139 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3144 /* FIXME: To avoid messy error recovery if dup fails
3145 re-use the existing stdio as though flag was not set
3149 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3151 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3153 int fd = fileno(stdio);
3154 PerlIOUnix_refcnt_inc(fd);
3155 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3162 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3164 PERL_UNUSED_CONTEXT;
3166 /* XXX this could use PerlIO_canset_fileno() and
3167 * PerlIO_set_fileno() support from Configure
3169 # if defined(HAS_FDCLOSE)
3170 return fdclose(f, NULL) == 0 ? 1 : 0;
3171 # elif defined(__UCLIBC__)
3172 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3175 # elif defined(__GLIBC__)
3176 /* There may be a better way for GLIBC:
3177 - libio.h defines a flag to not close() on cleanup
3181 # elif defined(__sun)
3184 # elif defined(__hpux)
3188 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3189 your platform does not have special entry try this one.
3190 [For OSF only have confirmation for Tru64 (alpha)
3191 but assume other OSFs will be similar.]
3193 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3196 # elif defined(__FreeBSD__)
3197 /* There may be a better way on FreeBSD:
3198 - we could insert a dummy func in the _close function entry
3199 f->_close = (int (*)(void *)) dummy_close;
3203 # elif defined(__OpenBSD__)
3204 /* There may be a better way on OpenBSD:
3205 - we could insert a dummy func in the _close function entry
3206 f->_close = (int (*)(void *)) dummy_close;
3210 # elif defined(__EMX__)
3211 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3214 # elif defined(__CYGWIN__)
3215 /* There may be a better way on CYGWIN:
3216 - we could insert a dummy func in the _close function entry
3217 f->_close = (int (*)(void *)) dummy_close;
3221 # elif defined(WIN32)
3222 # if defined(UNDER_CE)
3223 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3227 PERLIO_FILE_file(f) = -1;
3232 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3233 (which isn't thread safe) instead
3235 # error "Don't know how to set FILE.fileno on your platform"
3243 PerlIOStdio_close(pTHX_ PerlIO *f)
3245 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3251 const int fd = fileno(stdio);
3259 #ifdef SOCKS5_VERSION_NAME
3260 /* Socks lib overrides close() but stdio isn't linked to
3261 that library (though we are) - so we must call close()
3262 on sockets on stdio's behalf.
3265 Sock_size_t optlen = sizeof(int);
3266 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3269 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3270 that a subsequent fileno() on it returns -1. Don't want to croak()
3271 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3272 trying to close an already closed handle which somehow it still has
3273 a reference to. (via.xs, I'm looking at you). */
3274 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3275 /* File descriptor still in use */
3279 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3280 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3282 if (stdio == stdout || stdio == stderr)
3283 return PerlIO_flush(f);
3285 MUTEX_LOCK(&PL_perlio_mutex);
3286 /* Right. We need a mutex here because for a brief while we
3287 will have the situation that fd is actually closed. Hence if
3288 a second thread were to get into this block, its dup() would
3289 likely return our fd as its dupfd. (after all, it is closed)
3290 Then if we get to the dup2() first, we blat the fd back
3291 (messing up its temporary as a side effect) only for it to
3292 then close its dupfd (== our fd) in its close(dupfd) */
3294 /* There is, of course, a race condition, that any other thread
3295 trying to input/output/whatever on this fd will be stuffed
3296 for the duration of this little manoeuvrer. Perhaps we
3297 should hold an IO mutex for the duration of every IO
3298 operation if we know that invalidate doesn't work on this
3299 platform, but that would suck, and could kill performance.
3301 Except that correctness trumps speed.
3302 Advice from klortho #11912. */
3304 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3305 Use Sarathy's trick from maint-5.6 to invalidate the
3306 fileno slot of the FILE *
3308 result = PerlIO_flush(f);
3310 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3312 dupfd = PerlLIO_dup_cloexec(fd);
3315 /* Oh cXap. This isn't going to go well. Not sure if we can
3316 recover from here, or if closing this particular FILE *
3317 is a good idea now. */
3322 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3324 result = PerlSIO_fclose(stdio);
3325 /* We treat error from stdio as success if we invalidated
3326 errno may NOT be expected EBADF
3328 if (invalidate && result != 0) {
3332 #ifdef SOCKS5_VERSION_NAME
3333 /* in SOCKS' case, let close() determine return value */
3337 PerlLIO_dup2_cloexec(dupfd, fd);
3338 setfd_inhexec_for_sysfd(fd);
3339 PerlLIO_close(dupfd);
3341 MUTEX_UNLOCK(&PL_perlio_mutex);
3347 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3351 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3353 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3356 STDCHAR *buf = (STDCHAR *) vbuf;
3358 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3359 * stdio does not do that for fread()
3361 const int ch = PerlSIO_fgetc(s);
3368 got = PerlSIO_fread(vbuf, 1, count, s);
3369 if (got == 0 && PerlSIO_ferror(s))
3371 if (got >= 0 || errno != EINTR)
3373 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3375 SETERRNO(0,0); /* just in case */
3378 /* Under some circumstances IRIX stdio fgetc() and fread()
3379 * set the errno to ENOENT, which makes no sense according
3380 * to either IRIX or POSIX. [rt.perl.org #123977] */
3381 if (errno == ENOENT) SETERRNO(0,0);
3387 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3390 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3392 #ifdef STDIO_BUFFER_WRITABLE
3393 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3394 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3395 STDCHAR *base = PerlIO_get_base(f);
3396 SSize_t cnt = PerlIO_get_cnt(f);
3397 STDCHAR *ptr = PerlIO_get_ptr(f);
3398 SSize_t avail = ptr - base;
3400 if (avail > count) {
3404 Move(buf-avail,ptr,avail,STDCHAR);
3407 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3408 if (PerlSIO_feof(s) && unread >= 0)
3409 PerlSIO_clearerr(s);
3414 if (PerlIO_has_cntptr(f)) {
3415 /* We can get pointer to buffer but not its base
3416 Do ungetc() but check chars are ending up in the
3419 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3420 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3422 const int ch = *--buf & 0xFF;
3423 if (ungetc(ch,s) != ch) {
3424 /* ungetc did not work */
3427 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3428 /* Did not change pointer as expected */
3429 if (fgetc(s) != EOF) /* get char back again */
3439 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3445 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3448 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3451 got = PerlSIO_fwrite(vbuf, 1, count,
3452 PerlIOSelf(f, PerlIOStdio)->stdio);
3453 if (got >= 0 || errno != EINTR)
3455 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3457 SETERRNO(0,0); /* just in case */
3463 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3465 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3466 PERL_UNUSED_CONTEXT;
3468 return PerlSIO_fseek(stdio, offset, whence);
3472 PerlIOStdio_tell(pTHX_ PerlIO *f)
3474 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3475 PERL_UNUSED_CONTEXT;
3477 return PerlSIO_ftell(stdio);
3481 PerlIOStdio_flush(pTHX_ PerlIO *f)
3483 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3484 PERL_UNUSED_CONTEXT;
3486 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3487 return PerlSIO_fflush(stdio);
3493 * FIXME: This discards ungetc() and pre-read stuff which is not
3494 * right if this is just a "sync" from a layer above Suspect right
3495 * design is to do _this_ but not have layer above flush this
3496 * layer read-to-read
3499 * Not writeable - sync by attempting a seek
3502 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3510 PerlIOStdio_eof(pTHX_ PerlIO *f)
3512 PERL_UNUSED_CONTEXT;
3514 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3518 PerlIOStdio_error(pTHX_ PerlIO *f)
3520 PERL_UNUSED_CONTEXT;
3522 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3526 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3528 PERL_UNUSED_CONTEXT;
3530 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3534 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3536 PERL_UNUSED_CONTEXT;
3538 #ifdef HAS_SETLINEBUF
3539 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3541 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3547 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3549 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3550 PERL_UNUSED_CONTEXT;
3551 return (STDCHAR*)PerlSIO_get_base(stdio);
3555 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3557 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3558 PERL_UNUSED_CONTEXT;
3559 return PerlSIO_get_bufsiz(stdio);
3563 #ifdef USE_STDIO_PTR
3565 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3567 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3568 PERL_UNUSED_CONTEXT;
3569 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3573 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3575 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3576 PERL_UNUSED_CONTEXT;
3577 return PerlSIO_get_cnt(stdio);
3581 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3583 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3584 PERL_UNUSED_CONTEXT;
3586 #ifdef STDIO_PTR_LVALUE
3587 /* This is a long-standing infamous mess. The root of the
3588 * problem is that one cannot know the signedness of char, and
3589 * more precisely the signedness of FILE._ptr. The following
3590 * things have been tried, and they have all failed (across
3591 * different compilers (remember that core needs to to build
3592 * also with c++) and compiler options:
3594 * - casting the RHS to (void*) -- works in *some* places
3595 * - casting the LHS to (void*) -- totally unportable
3597 * So let's try silencing the warning at least for gcc. */
3598 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
3599 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3600 GCC_DIAG_RESTORE_STMT;
3601 #ifdef STDIO_PTR_LVAL_SETS_CNT
3602 assert(PerlSIO_get_cnt(stdio) == (cnt));
3604 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3606 * Setting ptr _does_ change cnt - we are done
3610 #else /* STDIO_PTR_LVALUE */
3612 #endif /* STDIO_PTR_LVALUE */
3615 * Now (or only) set cnt
3617 #ifdef STDIO_CNT_LVALUE
3618 PerlSIO_set_cnt(stdio, cnt);
3619 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3620 PerlSIO_set_ptr(stdio,
3621 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3623 #else /* STDIO_PTR_LVAL_SETS_CNT */
3625 #endif /* STDIO_CNT_LVALUE */
3632 PerlIOStdio_fill(pTHX_ PerlIO *f)
3636 PERL_UNUSED_CONTEXT;
3637 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3639 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3642 * fflush()ing read-only streams can cause trouble on some stdio-s
3644 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3645 if (PerlSIO_fflush(stdio) != 0)
3649 c = PerlSIO_fgetc(stdio);
3652 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3654 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3659 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3661 #ifdef STDIO_BUFFER_WRITABLE
3662 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3663 /* Fake ungetc() to the real buffer in case system's ungetc
3666 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3667 SSize_t cnt = PerlSIO_get_cnt(stdio);
3668 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3669 if (ptr == base+1) {
3670 *--ptr = (STDCHAR) c;
3671 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3672 if (PerlSIO_feof(stdio))
3673 PerlSIO_clearerr(stdio);
3679 if (PerlIO_has_cntptr(f)) {
3681 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3687 /* If buffer snoop scheme above fails fall back to
3690 if (PerlSIO_ungetc(c, stdio) != c)
3698 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3699 sizeof(PerlIO_funcs),
3701 sizeof(PerlIOStdio),
3702 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3706 PerlIOBase_binmode, /* binmode */
3720 PerlIOStdio_clearerr,
3721 PerlIOStdio_setlinebuf,
3723 PerlIOStdio_get_base,
3724 PerlIOStdio_get_bufsiz,
3729 #ifdef USE_STDIO_PTR
3730 PerlIOStdio_get_ptr,
3731 PerlIOStdio_get_cnt,
3732 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3733 PerlIOStdio_set_ptrcnt,
3736 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3741 #endif /* USE_STDIO_PTR */
3744 /* Note that calls to PerlIO_exportFILE() are reversed using
3745 * PerlIO_releaseFILE(), not importFILE. */
3747 PerlIO_exportFILE(PerlIO * f, const char *mode)
3751 if (PerlIOValid(f)) {
3753 int fd = PerlIO_fileno(f);
3758 if (!mode || !*mode) {
3759 mode = PerlIO_modestr(f, buf);
3761 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3765 /* De-link any lower layers so new :stdio sticks */
3767 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3768 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3770 PerlIOUnix_refcnt_inc(fileno(stdio));
3771 /* Link previous lower layers under new one */
3775 /* restore layers list */
3785 PerlIO_findFILE(PerlIO *f)
3790 if (l->tab == &PerlIO_stdio) {
3791 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3794 l = *PerlIONext(&l);
3796 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3797 /* However, we're not really exporting a FILE * to someone else (who
3798 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3799 So we need to undo its reference count increase on the underlying file
3800 descriptor. We have to do this, because if the loop above returns you
3801 the FILE *, then *it* didn't increase any reference count. So there's
3802 only one way to be consistent. */
3803 stdio = PerlIO_exportFILE(f, NULL);
3805 const int fd = fileno(stdio);
3807 PerlIOUnix_refcnt_dec(fd);
3812 /* Use this to reverse PerlIO_exportFILE calls. */
3814 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3818 if (l->tab == &PerlIO_stdio) {
3819 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3820 if (s->stdio == f) { /* not in a loop */
3821 const int fd = fileno(f);
3823 PerlIOUnix_refcnt_dec(fd);
3826 PerlIO_pop(aTHX_ p);
3836 /*--------------------------------------------------------------------------------------*/
3838 * perlio buffer layer
3842 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3844 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3845 const int fd = PerlIO_fileno(f);
3846 if (fd >= 0 && PerlLIO_isatty(fd)) {
3847 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3849 if (*PerlIONext(f)) {
3850 const Off_t posn = PerlIO_tell(PerlIONext(f));
3851 if (posn != (Off_t) - 1) {
3855 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3859 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3860 IV n, const char *mode, int fd, int imode, int perm,
3861 PerlIO *f, int narg, SV **args)
3863 if (PerlIOValid(f)) {
3864 PerlIO *next = PerlIONext(f);
3866 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3867 if (tab && tab->Open)
3869 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3871 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3876 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3878 if (*mode == IoTYPE_IMPLICIT) {
3884 if (tab && tab->Open)
3885 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3888 SETERRNO(EINVAL, LIB_INVARG);
3890 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3892 * if push fails during open, open fails. close will pop us.
3897 fd = PerlIO_fileno(f);
3898 if (init && fd == 2) {
3900 * Initial stderr is unbuffered
3902 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3904 #ifdef PERLIO_USING_CRLF
3905 # ifdef PERLIO_IS_BINMODE_FD
3906 if (PERLIO_IS_BINMODE_FD(fd))
3907 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3911 * do something about failing setmode()? --jhi
3913 PerlLIO_setmode(fd, O_BINARY);
3916 /* Enable line buffering with record-oriented regular files
3917 * so we don't introduce an extraneous record boundary when
3918 * the buffer fills up.
3920 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3922 if (PerlLIO_fstat(fd, &st) == 0
3923 && S_ISREG(st.st_mode)
3924 && (st.st_fab_rfm == FAB$C_VAR
3925 || st.st_fab_rfm == FAB$C_VFC)) {
3926 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3937 * This "flush" is akin to sfio's sync in that it handles files in either
3938 * read or write state. For write state, we put the postponed data through
3939 * the next layers. For read state, we seek() the next layers to the
3940 * offset given by current position in the buffer, and discard the buffer
3941 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3942 * in any case?). Then the pass the stick further in chain.
3945 PerlIOBuf_flush(pTHX_ PerlIO *f)
3947 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3949 PerlIO *n = PerlIONext(f);
3950 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3952 * write() the buffer
3954 const STDCHAR *buf = b->buf;
3955 const STDCHAR *p = buf;
3956 while (p < b->ptr) {
3957 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3961 else if (count < 0 || PerlIO_error(n)) {
3962 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3963 PerlIO_save_errno(f);
3968 b->posn += (p - buf);
3970 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3971 STDCHAR *buf = PerlIO_get_base(f);
3973 * Note position change
3975 b->posn += (b->ptr - buf);
3976 if (b->ptr < b->end) {
3977 /* We did not consume all of it - try and seek downstream to
3978 our logical position
3980 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3981 /* Reload n as some layers may pop themselves on seek */
3982 b->posn = PerlIO_tell(n = PerlIONext(f));
3985 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3986 data is lost for good - so return saying "ok" having undone
3989 b->posn -= (b->ptr - buf);
3994 b->ptr = b->end = b->buf;
3995 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3996 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3997 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4002 /* This discards the content of the buffer after b->ptr, and rereads
4003 * the buffer from the position off in the layer downstream; here off
4004 * is at offset corresponding to b->ptr - b->buf.
4007 PerlIOBuf_fill(pTHX_ PerlIO *f)
4009 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4010 PerlIO *n = PerlIONext(f);
4013 * Down-stream flush is defined not to loose read data so is harmless.
4014 * we would not normally be fill'ing if there was data left in anycase.
4016 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4018 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4019 PerlIOBase_flush_linebuf(aTHX);
4022 PerlIO_get_base(f); /* allocate via vtable */
4024 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4026 b->ptr = b->end = b->buf;
4028 if (!PerlIOValid(n)) {
4029 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4033 if (PerlIO_fast_gets(n)) {
4035 * Layer below is also buffered. We do _NOT_ want to call its
4036 * ->Read() because that will loop till it gets what we asked for
4037 * which may hang on a pipe etc. Instead take anything it has to
4038 * hand, or ask it to fill _once_.
4040 avail = PerlIO_get_cnt(n);
4042 avail = PerlIO_fill(n);
4044 avail = PerlIO_get_cnt(n);
4046 if (!PerlIO_error(n) && PerlIO_eof(n))
4051 STDCHAR *ptr = PerlIO_get_ptr(n);
4052 const SSize_t cnt = avail;
4053 if (avail > (SSize_t)b->bufsiz)
4055 Copy(ptr, b->buf, avail, STDCHAR);
4056 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4060 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4064 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4067 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4068 PerlIO_save_errno(f);
4072 b->end = b->buf + avail;
4073 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4078 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4080 if (PerlIOValid(f)) {
4081 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4084 return PerlIOBase_read(aTHX_ f, vbuf, count);
4090 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4092 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4093 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4096 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4101 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4103 * Buffer is already a read buffer, we can overwrite any chars
4104 * which have been read back to buffer start
4106 avail = (b->ptr - b->buf);
4110 * Buffer is idle, set it up so whole buffer is available for
4114 b->end = b->buf + avail;
4116 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4118 * Buffer extends _back_ from where we are now
4120 b->posn -= b->bufsiz;
4122 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4124 * If we have space for more than count, just move count
4132 * In simple stdio-like ungetc() case chars will be already
4135 if (buf != b->ptr) {
4136 Copy(buf, b->ptr, avail, STDCHAR);
4140 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4144 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4150 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4152 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4153 const STDCHAR *buf = (const STDCHAR *) vbuf;
4154 const STDCHAR *flushptr = buf;
4158 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4160 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4161 if (PerlIO_flush(f) != 0) {
4165 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4166 flushptr = buf + count;
4167 while (flushptr > buf && *(flushptr - 1) != '\n')
4171 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4172 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4174 if (flushptr > buf && flushptr <= buf + avail)
4175 avail = flushptr - buf;
4176 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4178 Copy(buf, b->ptr, avail, STDCHAR);
4183 if (buf == flushptr)
4186 if (b->ptr >= (b->buf + b->bufsiz))
4187 if (PerlIO_flush(f) == -1)
4190 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4196 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4199 if ((code = PerlIO_flush(f)) == 0) {
4200 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4201 code = PerlIO_seek(PerlIONext(f), offset, whence);
4203 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4204 b->posn = PerlIO_tell(PerlIONext(f));
4211 PerlIOBuf_tell(pTHX_ PerlIO *f)
4213 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4215 * b->posn is file position where b->buf was read, or will be written
4217 Off_t posn = b->posn;
4218 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4219 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4221 /* As O_APPEND files are normally shared in some sense it is better
4226 /* when file is NOT shared then this is sufficient */
4227 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4229 posn = b->posn = PerlIO_tell(PerlIONext(f));
4233 * If buffer is valid adjust position by amount in buffer
4235 posn += (b->ptr - b->buf);
4241 PerlIOBuf_popped(pTHX_ PerlIO *f)
4243 const IV code = PerlIOBase_popped(aTHX_ f);
4244 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4245 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4248 b->ptr = b->end = b->buf = NULL;
4249 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4254 PerlIOBuf_close(pTHX_ PerlIO *f)
4256 const IV code = PerlIOBase_close(aTHX_ f);
4257 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4258 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4261 b->ptr = b->end = b->buf = NULL;
4262 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4267 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4269 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4276 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4278 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4281 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4282 return (b->end - b->ptr);
4287 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4289 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4290 PERL_UNUSED_CONTEXT;
4294 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4295 Newx(b->buf,b->bufsiz, STDCHAR);
4297 b->buf = (STDCHAR *) & b->oneword;
4298 b->bufsiz = sizeof(b->oneword);
4300 b->end = b->ptr = b->buf;
4306 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4308 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4311 return (b->end - b->buf);
4315 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4317 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4319 PERL_UNUSED_ARG(cnt);
4324 assert(PerlIO_get_cnt(f) == cnt);
4325 assert(b->ptr >= b->buf);
4326 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4330 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4332 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4337 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4338 sizeof(PerlIO_funcs),
4341 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4345 PerlIOBase_binmode, /* binmode */
4359 PerlIOBase_clearerr,
4360 PerlIOBase_setlinebuf,
4365 PerlIOBuf_set_ptrcnt,
4368 /*--------------------------------------------------------------------------------------*/
4370 * Temp layer to hold unread chars when cannot do it any other way
4374 PerlIOPending_fill(pTHX_ PerlIO *f)
4377 * Should never happen
4384 PerlIOPending_close(pTHX_ PerlIO *f)
4387 * A tad tricky - flush pops us, then we close new top
4390 return PerlIO_close(f);
4394 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4397 * A tad tricky - flush pops us, then we seek new top
4400 return PerlIO_seek(f, offset, whence);
4405 PerlIOPending_flush(pTHX_ PerlIO *f)
4407 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4408 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4412 PerlIO_pop(aTHX_ f);
4417 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4423 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4428 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4430 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4431 PerlIOl * const l = PerlIOBase(f);
4433 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4434 * etc. get muddled when it changes mid-string when we auto-pop.
4436 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4437 (PerlIOBase(PerlIONext(f))->
4438 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4443 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4445 SSize_t avail = PerlIO_get_cnt(f);
4447 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4450 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4451 if (got >= 0 && got < (SSize_t)count) {
4452 const SSize_t more =
4453 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4454 if (more >= 0 || got == 0)
4460 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4461 sizeof(PerlIO_funcs),
4464 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4465 PerlIOPending_pushed,
4468 PerlIOBase_binmode, /* binmode */
4477 PerlIOPending_close,
4478 PerlIOPending_flush,
4482 PerlIOBase_clearerr,
4483 PerlIOBase_setlinebuf,
4488 PerlIOPending_set_ptrcnt,
4493 /*--------------------------------------------------------------------------------------*/
4495 * crlf - translation On read translate CR,LF to "\n" we do this by
4496 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4497 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4499 * c->nl points on the first byte of CR LF pair when it is temporarily
4500 * replaced by LF, or to the last CR of the buffer. In the former case
4501 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4502 * that it ends at c->nl; these two cases can be distinguished by
4503 * *c->nl. c->nl is set during _getcnt() call, and unset during
4504 * _unread() and _flush() calls.
4505 * It only matters for read operations.
4509 PerlIOBuf base; /* PerlIOBuf stuff */
4510 STDCHAR *nl; /* Position of crlf we "lied" about in the
4514 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4515 * Otherwise the :crlf layer would always revert back to
4519 S_inherit_utf8_flag(PerlIO *f)
4521 PerlIO *g = PerlIONext(f);
4522 if (PerlIOValid(g)) {
4523 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4524 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4530 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4533 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4534 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4537 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4538 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4539 PerlIOBase(f)->flags);
4543 /* If the old top layer is a CRLF layer, reactivate it (if
4544 * necessary) and remove this new layer from the stack */
4545 PerlIO *g = PerlIONext(f);
4546 if (PerlIOValid(g)) {
4547 PerlIOl *b = PerlIOBase(g);
4548 if (b && b->tab == &PerlIO_crlf) {
4549 if (!(b->flags & PERLIO_F_CRLF))
4550 b->flags |= PERLIO_F_CRLF;
4551 S_inherit_utf8_flag(g);
4552 PerlIO_pop(aTHX_ f);
4557 S_inherit_utf8_flag(f);
4563 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4565 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4566 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4567 *(c->nl) = NATIVE_0xd;
4570 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4571 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4573 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4574 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4576 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4581 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4582 b->end = b->ptr = b->buf + b->bufsiz;
4583 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4584 b->posn -= b->bufsiz;
4586 while (count > 0 && b->ptr > b->buf) {
4587 const int ch = *--buf;
4589 if (b->ptr - 2 >= b->buf) {
4590 *--(b->ptr) = NATIVE_0xa;
4591 *--(b->ptr) = NATIVE_0xd;
4596 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4597 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4611 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4616 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4618 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4620 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4623 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4624 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4625 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4626 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4628 while (nl < b->end && *nl != NATIVE_0xd)
4630 if (nl < b->end && *nl == NATIVE_0xd) {
4632 if (nl + 1 < b->end) {
4633 if (nl[1] == NATIVE_0xa) {
4639 * Not CR,LF but just CR
4647 * Blast - found CR as last char in buffer
4652 * They may not care, defer work as long as
4656 return (nl - b->ptr);
4660 b->ptr++; /* say we have read it as far as
4661 * flush() is concerned */
4662 b->buf++; /* Leave space in front of buffer */
4663 /* Note as we have moved buf up flush's
4665 will naturally make posn point at CR
4667 b->bufsiz--; /* Buffer is thus smaller */
4668 code = PerlIO_fill(f); /* Fetch some more */
4669 b->bufsiz++; /* Restore size for next time */
4670 b->buf--; /* Point at space */
4671 b->ptr = nl = b->buf; /* Which is what we hand
4673 *nl = NATIVE_0xd; /* Fill in the CR */
4675 goto test; /* fill() call worked */
4677 * CR at EOF - just fall through
4679 /* Should we clear EOF though ??? */
4684 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4690 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4692 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4693 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4699 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4700 /* Deferred CR at end of buffer case - we lied about count */
4713 * Test code - delete when it works ...
4715 IV flags = PerlIOBase(f)->flags;
4716 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4717 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4718 /* Deferred CR at end of buffer case - we lied about count */
4724 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4725 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4726 flags, c->nl, b->end, cnt);
4733 * They have taken what we lied about
4735 *(c->nl) = NATIVE_0xd;
4741 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4745 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4747 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4748 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4750 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4751 const STDCHAR *buf = (const STDCHAR *) vbuf;
4752 const STDCHAR * const ebuf = buf + count;
4755 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4757 while (buf < ebuf) {
4758 const STDCHAR * const eptr = b->buf + b->bufsiz;
4759 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4760 while (buf < ebuf && b->ptr < eptr) {
4762 if ((b->ptr + 2) > eptr) {
4770 *(b->ptr)++ = NATIVE_0xd; /* CR */
4771 *(b->ptr)++ = NATIVE_0xa; /* LF */
4773 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4780 *(b->ptr)++ = *buf++;
4782 if (b->ptr >= eptr) {
4788 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4790 return (buf - (STDCHAR *) vbuf);
4795 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4797 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4799 *(c->nl) = NATIVE_0xd;
4802 return PerlIOBuf_flush(aTHX_ f);
4806 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4808 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4809 /* In text mode - flush any pending stuff and flip it */
4810 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4811 #ifndef PERLIO_USING_CRLF
4812 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4813 PerlIO_pop(aTHX_ f);
4819 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4820 sizeof(PerlIO_funcs),
4823 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4825 PerlIOBuf_popped, /* popped */
4827 PerlIOCrlf_binmode, /* binmode */
4831 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4832 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4833 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4841 PerlIOBase_clearerr,
4842 PerlIOBase_setlinebuf,
4847 PerlIOCrlf_set_ptrcnt,
4851 Perl_PerlIO_stdin(pTHX)
4854 PerlIO_stdstreams(aTHX);
4856 return (PerlIO*)&PL_perlio[1];
4860 Perl_PerlIO_stdout(pTHX)
4863 PerlIO_stdstreams(aTHX);
4865 return (PerlIO*)&PL_perlio[2];
4869 Perl_PerlIO_stderr(pTHX)
4872 PerlIO_stdstreams(aTHX);
4874 return (PerlIO*)&PL_perlio[3];
4877 /*--------------------------------------------------------------------------------------*/
4880 PerlIO_getname(PerlIO *f, char *buf)
4885 bool exported = FALSE;
4886 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4888 stdio = PerlIO_exportFILE(f,0);
4892 name = fgetname(stdio, buf);
4893 if (exported) PerlIO_releaseFILE(f,stdio);
4898 PERL_UNUSED_ARG(buf);
4899 Perl_croak_nocontext("Don't know how to get file name");
4905 /*--------------------------------------------------------------------------------------*/
4907 * Functions which can be called on any kind of PerlIO implemented in
4911 #undef PerlIO_fdopen
4913 PerlIO_fdopen(int fd, const char *mode)
4916 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4921 PerlIO_open(const char *path, const char *mode)
4924 SV *name = sv_2mortal(newSVpv(path, 0));
4925 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4928 #undef Perlio_reopen
4930 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4933 SV *name = sv_2mortal(newSVpv(path,0));
4934 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4939 PerlIO_getc(PerlIO *f)
4943 if ( 1 == PerlIO_read(f, buf, 1) ) {
4944 return (unsigned char) buf[0];
4949 #undef PerlIO_ungetc
4951 PerlIO_ungetc(PerlIO *f, int ch)
4956 if (PerlIO_unread(f, &buf, 1) == 1)
4964 PerlIO_putc(PerlIO *f, int ch)
4968 return PerlIO_write(f, &buf, 1);
4973 PerlIO_puts(PerlIO *f, const char *s)
4976 return PerlIO_write(f, s, strlen(s));
4979 #undef PerlIO_rewind
4981 PerlIO_rewind(PerlIO *f)
4984 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4988 #undef PerlIO_vprintf
4990 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4999 Perl_va_copy(ap, apc);
5000 sv = vnewSVpvf(fmt, &apc);
5003 sv = vnewSVpvf(fmt, &ap);
5005 s = SvPV_const(sv, len);
5006 wrote = PerlIO_write(f, s, len);
5011 #undef PerlIO_printf
5013 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5018 result = PerlIO_vprintf(f, fmt, ap);
5023 #undef PerlIO_stdoutf
5025 PerlIO_stdoutf(const char *fmt, ...)
5031 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5036 #undef PerlIO_tmpfile
5038 PerlIO_tmpfile(void)
5045 const int fd = win32_tmpfd();
5047 f = PerlIO_fdopen(fd, "w+b");
5048 #elif ! defined(VMS) && ! defined(OS2)
5050 char tempname[] = "/tmp/PerlIO_XXXXXX";
5051 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5053 int old_umask = umask(0177);
5054 if (tmpdir && *tmpdir) {
5055 /* if TMPDIR is set and not empty, we try that first */
5056 sv = newSVpv(tmpdir, 0);
5057 sv_catpv(sv, tempname + 4);
5058 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
5063 /* else we try /tmp */
5064 fd = Perl_my_mkstemp_cloexec(tempname);
5069 sv_catpv(sv, tempname + 4);
5070 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
5074 f = PerlIO_fdopen(fd, "w+");
5076 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5077 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5080 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5081 FILE * const stdio = PerlSIO_tmpfile();
5084 f = PerlIO_fdopen(fileno(stdio), "w+");
5086 #endif /* else WIN32 */
5091 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5093 PERL_UNUSED_CONTEXT;
5094 if (!PerlIOValid(f))
5096 PerlIOBase(f)->err = errno;
5098 PerlIOBase(f)->os_err = vaxc$errno;
5100 PerlIOBase(f)->os_err = Perl_rc;
5101 #elif defined(WIN32)
5102 PerlIOBase(f)->os_err = GetLastError();
5107 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5109 PERL_UNUSED_CONTEXT;
5110 if (!PerlIOValid(f))
5112 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5114 Perl_rc = PerlIOBase(f)->os_err);
5115 #elif defined(WIN32)
5116 SetLastError(PerlIOBase(f)->os_err);
5124 /*======================================================================================*/
5126 * Now some functions in terms of above which may be needed even if we are
5127 * not in true PerlIO mode
5130 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5132 const char *direction = NULL;
5135 * Need to supply default layer info from open.pm
5141 if (mode && mode[0] != 'r') {
5142 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5143 direction = "open>";
5145 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5146 direction = "open<";
5151 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5154 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5159 #undef PerlIO_setpos
5161 PerlIO_setpos(PerlIO *f, SV *pos)
5167 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5168 if(len == sizeof(Off_t))
5169 return PerlIO_seek(f, *posn, SEEK_SET);
5172 SETERRNO(EINVAL, SS_IVCHAN);
5176 #undef PerlIO_setpos
5178 PerlIO_setpos(PerlIO *f, SV *pos)
5184 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5185 if(len == sizeof(Fpos_t))
5186 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5187 return fsetpos64(f, fpos);
5189 return fsetpos(f, fpos);
5193 SETERRNO(EINVAL, SS_IVCHAN);
5199 #undef PerlIO_getpos
5201 PerlIO_getpos(PerlIO *f, SV *pos)
5204 Off_t posn = PerlIO_tell(f);
5205 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5206 return (posn == (Off_t) - 1) ? -1 : 0;
5209 #undef PerlIO_getpos
5211 PerlIO_getpos(PerlIO *f, SV *pos)
5216 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5217 code = fgetpos64(f, &fpos);
5219 code = fgetpos(f, &fpos);
5221 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5226 /* print a failure format string message to stderr and fail exit the process
5227 using only libc without depending on any perl data structures being
5232 Perl_noperl_die(const char* pat, ...)
5235 PERL_ARGS_ASSERT_NOPERL_DIE;
5236 va_start(arglist, pat);
5237 vfprintf(stderr, pat, arglist);
5243 * ex: set ts=8 sts=4 sw=4 et: