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
53 /* Missing proto on LynxOS */
61 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
63 /* Call the callback or PerlIOBase, and return failure. */
64 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
65 if (PerlIOValid(f)) { \
66 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
67 if (tab && tab->callback) \
68 return (*tab->callback) args; \
70 return PerlIOBase_ ## base args; \
73 SETERRNO(EBADF, SS_IVCHAN); \
76 /* Call the callback or fail, and return failure. */
77 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
78 if (PerlIOValid(f)) { \
79 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
80 if (tab && tab->callback) \
81 return (*tab->callback) args; \
82 SETERRNO(EINVAL, LIB_INVARG); \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or PerlIOBase, and be void. */
89 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 (*tab->callback) args; \
95 PerlIOBase_ ## base args; \
98 SETERRNO(EBADF, SS_IVCHAN)
100 /* Call the callback or fail, and be void. */
101 #define Perl_PerlIO_or_fail_void(f, callback, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 SETERRNO(EINVAL, LIB_INVARG); \
110 SETERRNO(EBADF, SS_IVCHAN)
112 #if defined(__osf__) && _XOPEN_SOURCE < 500
113 extern int fseeko(FILE *, off_t, int);
114 extern off_t ftello(FILE *);
117 #define NATIVE_0xd CR_NATIVE
118 #define NATIVE_0xa LF_NATIVE
120 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
123 perlsio_binmode(FILE *fp, int iotype, int mode)
126 * This used to be contents of do_binmode in doio.c
130 PERL_UNUSED_ARG(iotype);
132 if (PerlLIO_setmode(fp, mode) != -1) {
134 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
141 # if defined(USEMYBINMODE)
143 # if defined(__CYGWIN__)
144 PERL_UNUSED_ARG(iotype);
146 if (my_binmode(fp, iotype, mode) != FALSE)
152 PERL_UNUSED_ARG(iotype);
153 PERL_UNUSED_ARG(mode);
160 #define O_ACCMODE 3 /* Assume traditional implementation */
164 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
166 const int result = rawmode & O_ACCMODE;
171 ptype = IoTYPE_RDONLY;
174 ptype = IoTYPE_WRONLY;
182 *writing = (result != O_RDONLY);
184 if (result == O_RDONLY) {
188 else if (rawmode & O_APPEND) {
190 if (result != O_WRONLY)
195 if (result == O_WRONLY)
203 /* Unless O_BINARY is different from zero, bit-and:ing
204 * with it won't do much good. */
205 if (rawmode & O_BINARY)
212 #ifndef PERLIO_LAYERS
214 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
216 if (!names || !*names
217 || strEQ(names, ":crlf")
218 || strEQ(names, ":raw")
219 || strEQ(names, ":bytes")
223 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
231 PerlIO_destruct(pTHX)
236 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
238 return perlsio_binmode(fp, iotype, mode);
242 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
244 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
247 #ifdef PERL_IMPLICIT_SYS
248 return PerlSIO_fdupopen(f);
251 return win32_fdupopen(f);
254 const int fd = PerlLIO_dup(PerlIO_fileno(f));
258 const int omode = djgpp_get_stream_mode(f);
260 const int omode = fcntl(fd, F_GETFL);
262 PerlIO_intmode2str(omode,mode,NULL);
263 /* the r+ is a hack */
264 return PerlIO_fdopen(fd, mode);
269 SETERRNO(EBADF, SS_IVCHAN);
279 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
283 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
284 int imode, int perm, PerlIO *old, int narg, SV **args)
288 Perl_croak(aTHX_ "More than one argument to open");
290 if (*args == &PL_sv_undef)
291 return PerlIO_tmpfile();
294 const char *name = SvPV_const(*args, len);
295 if (!IS_SAFE_PATHNAME(name, len, "open"))
298 if (*mode == IoTYPE_NUMERIC) {
299 fd = PerlLIO_open3(name, imode, perm);
301 return PerlIO_fdopen(fd, mode + 1);
304 return PerlIO_reopen(name, mode, old);
307 return PerlIO_open(name, mode);
312 return PerlIO_fdopen(fd, (char *) mode);
317 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
318 XS(XS_PerlIO__Layer__find)
322 Perl_croak(aTHX_ "Usage class->find(name[,load])");
324 const char * const name = SvPV_nolen_const(ST(1));
325 ST(0) = (strEQ(name, "crlf")
326 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
333 Perl_boot_core_PerlIO(pTHX)
335 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
341 /*======================================================================================*/
343 * Implement all the PerlIO interface ourselves.
349 PerlIO_debug(const char *fmt, ...)
359 if (!PL_perlio_debug_fd) {
361 PerlProc_getuid() == PerlProc_geteuid() &&
362 PerlProc_getgid() == PerlProc_getegid()) {
363 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
366 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
368 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
370 /* tainting or set*id, so ignore the environment and send the
371 debug output to stderr, like other -D switches. */
372 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
375 if (PL_perlio_debug_fd > 0) {
377 const char * const s = CopFILE(PL_curcop);
378 /* Use fixed buffer as sv_catpvf etc. needs SVs */
380 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
381 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
382 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
384 const char *s = CopFILE(PL_curcop);
386 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
387 (IV) CopLINE(PL_curcop));
388 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
390 s = SvPV_const(sv, len);
391 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
398 /*--------------------------------------------------------------------------------------*/
401 * Inner level routines
404 /* check that the head field of each layer points back to the head */
407 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
409 PerlIO_verify_head(pTHX_ PerlIO *f)
413 #ifndef PERL_IMPLICIT_SYS
418 p = head = PerlIOBase(f)->head;
421 assert(p->head == head);
422 if (p == (PerlIOl*)f)
429 # define VERIFY_HEAD(f)
434 * Table of pointers to the PerlIO structs (malloc'ed)
436 #define PERLIO_TABLE_SIZE 64
439 PerlIO_init_table(pTHX)
443 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
449 PerlIO_allocate(pTHX)
452 * Find a free slot in the table, allocating new table as necessary
457 while ((f = *last)) {
459 last = (PerlIOl **) (f);
460 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
461 if (!((++f)->next)) {
466 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
470 *last = (PerlIOl*) f++;
473 f->flags = 0; /* lockcnt */
479 #undef PerlIO_fdupopen
481 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
483 if (PerlIOValid(f)) {
484 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
485 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
487 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
489 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
493 SETERRNO(EBADF, SS_IVCHAN);
499 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
501 PerlIOl * const table = *tablep;
504 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
505 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
506 PerlIOl * const f = table + i;
508 PerlIO_close(&(f->next));
518 PerlIO_list_alloc(pTHX)
522 Newxz(list, 1, PerlIO_list_t);
528 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
531 if (--list->refcnt == 0) {
534 for (i = 0; i < list->cur; i++)
535 SvREFCNT_dec(list->array[i].arg);
536 Safefree(list->array);
544 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
549 if (list->cur >= list->len) {
550 const IV new_len = list->len + 8;
552 Renew(list->array, new_len, PerlIO_pair_t);
554 Newx(list->array, new_len, PerlIO_pair_t);
557 p = &(list->array[list->cur++]);
559 if ((p->arg = arg)) {
560 SvREFCNT_inc_simple_void_NN(arg);
565 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
567 PerlIO_list_t *list = NULL;
570 list = PerlIO_list_alloc(aTHX);
571 for (i=0; i < proto->cur; i++) {
572 SV *arg = proto->array[i].arg;
575 arg = sv_dup(arg, param);
577 PERL_UNUSED_ARG(param);
579 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
586 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
589 PerlIOl **table = &proto->Iperlio;
592 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
593 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
594 PerlIO_init_table(aTHX);
595 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
596 while ((f = *table)) {
598 table = (PerlIOl **) (f++);
599 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
601 (void) fp_dup(&(f->next), 0, param);
608 PERL_UNUSED_ARG(proto);
609 PERL_UNUSED_ARG(param);
614 PerlIO_destruct(pTHX)
616 PerlIOl **table = &PL_perlio;
619 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
621 while ((f = *table)) {
623 table = (PerlIOl **) (f++);
624 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
625 PerlIO *x = &(f->next);
628 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
629 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
643 PerlIO_pop(pTHX_ PerlIO *f)
645 const PerlIOl *l = *f;
648 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
649 l->tab ? l->tab->name : "(Null)") );
650 if (l->tab && l->tab->Popped) {
652 * If popped returns non-zero do not free its layer structure
653 * it has either done so itself, or it is shared and still in
656 if ((*l->tab->Popped) (aTHX_ f) != 0)
659 if (PerlIO_lockcnt(f)) {
660 /* we're in use; defer freeing the structure */
661 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
662 PerlIOBase(f)->tab = NULL;
672 /* Return as an array the stack of layers on a filehandle. Note that
673 * the stack is returned top-first in the array, and there are three
674 * times as many array elements as there are layers in the stack: the
675 * first element of a layer triplet is the name, the second one is the
676 * arguments, and the third one is the flags. */
679 PerlIO_get_layers(pTHX_ PerlIO *f)
681 AV * const av = newAV();
683 if (PerlIOValid(f)) {
684 PerlIOl *l = PerlIOBase(f);
687 /* There is some collusion in the implementation of
688 XS_PerlIO_get_layers - it knows that name and flags are
689 generated as fresh SVs here, and takes advantage of that to
690 "copy" them by taking a reference. If it changes here, it needs
691 to change there too. */
692 SV * const name = l->tab && l->tab->name ?
693 newSVpv(l->tab->name, 0) : &PL_sv_undef;
694 SV * const arg = l->tab && l->tab->Getarg ?
695 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
698 av_push(av, newSViv((IV)l->flags));
706 /*--------------------------------------------------------------------------------------*/
708 * XS Interface for perl code
712 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
716 if ((SSize_t) len <= 0)
718 for (i = 0; i < PL_known_layers->cur; i++) {
719 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
720 const STRLEN this_len = strlen(f->name);
721 if (this_len == len && memEQ(f->name, name, len)) {
722 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
726 if (load && PL_subname && PL_def_layerlist
727 && PL_def_layerlist->cur >= 2) {
728 if (PL_in_load_module) {
729 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
732 SV * const pkgsv = newSVpvs("PerlIO");
733 SV * const layer = newSVpvn(name, len);
734 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
736 SAVEBOOL(PL_in_load_module);
738 SAVEGENERICSV(PL_warnhook);
739 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
741 PL_in_load_module = TRUE;
743 * The two SVs are magically freed by load_module
745 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
747 return PerlIO_find_layer(aTHX_ name, len, 0);
750 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
754 #ifdef USE_ATTRIBUTES_FOR_PERLIO
757 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
760 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
761 PerlIO * const ifp = IoIFP(io);
762 PerlIO * const ofp = IoOFP(io);
763 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
764 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
770 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
773 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
774 PerlIO * const ifp = IoIFP(io);
775 PerlIO * const ofp = IoOFP(io);
776 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
777 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
783 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
785 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
790 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
792 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
796 MGVTBL perlio_vtab = {
804 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
805 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
808 SV * const sv = SvRV(ST(1));
809 AV * const av = newAV();
813 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
815 mg = mg_find(sv, PERL_MAGIC_ext);
816 mg->mg_virtual = &perlio_vtab;
818 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
819 for (i = 2; i < items; i++) {
821 const char * const name = SvPV_const(ST(i), len);
822 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
824 av_push(av, SvREFCNT_inc_simple_NN(layer));
835 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
838 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
840 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
841 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
845 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
846 XS(XS_PerlIO__Layer__NoWarnings)
848 /* This is used as a %SIG{__WARN__} handler to suppress warnings
849 during loading of layers.
852 PERL_UNUSED_VAR(items);
855 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
859 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
860 XS(XS_PerlIO__Layer__find)
864 Perl_croak(aTHX_ "Usage class->find(name[,load])");
867 const char * const name = SvPV_const(ST(1), len);
868 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
869 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
871 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
878 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
880 if (!PL_known_layers)
881 PL_known_layers = PerlIO_list_alloc(aTHX);
882 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
883 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
887 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
890 const char *s = names;
892 while (isSPACE(*s) || *s == ':')
897 const char *as = NULL;
899 if (!isIDFIRST(*s)) {
901 * Message is consistent with how attribute lists are
902 * passed. Even though this means "foo : : bar" is
903 * seen as an invalid separator character.
905 const char q = ((*s == '\'') ? '"' : '\'');
906 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
907 "Invalid separator character %c%c%c in PerlIO layer specification %s",
909 SETERRNO(EINVAL, LIB_INVARG);
914 } while (isWORDCHAR(*e));
930 * It's a nul terminated string, not allowed
931 * to \ the terminating null. Anything other
932 * character is passed over.
942 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
943 "Argument list not closed for PerlIO layer \"%.*s\"",
955 PerlIO_funcs * const layer =
956 PerlIO_find_layer(aTHX_ s, llen, 1);
960 arg = newSVpvn(as, alen);
961 PerlIO_list_push(aTHX_ av, layer,
962 (arg) ? arg : &PL_sv_undef);
966 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
979 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
981 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
982 #ifdef PERLIO_USING_CRLF
985 if (PerlIO_stdio.Set_ptrcnt)
988 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
989 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
993 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
995 return av->array[n].arg;
999 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1001 if (n >= 0 && n < av->cur) {
1002 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1003 av->array[n].funcs->name) );
1004 return av->array[n].funcs;
1007 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1012 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1014 PERL_UNUSED_ARG(mode);
1015 PERL_UNUSED_ARG(arg);
1016 PERL_UNUSED_ARG(tab);
1017 if (PerlIOValid(f)) {
1019 PerlIO_pop(aTHX_ f);
1025 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1026 sizeof(PerlIO_funcs),
1029 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1049 NULL, /* get_base */
1050 NULL, /* get_bufsiz */
1053 NULL, /* set_ptrcnt */
1057 PerlIO_default_layers(pTHX)
1059 if (!PL_def_layerlist) {
1060 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1061 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1062 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1063 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1065 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1067 osLayer = &PerlIO_win32;
1070 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1071 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1072 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1077 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1080 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1083 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1086 if (PL_def_layerlist->cur < 2) {
1087 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1089 return PL_def_layerlist;
1093 Perl_boot_core_PerlIO(pTHX)
1095 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1096 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1099 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1100 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1104 PerlIO_default_layer(pTHX_ I32 n)
1106 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1109 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1112 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1113 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1116 PerlIO_stdstreams(pTHX)
1119 PerlIO_init_table(aTHX);
1120 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1121 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1122 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1127 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1130 if (tab->fsize != sizeof(PerlIO_funcs)) {
1132 "%s (%" UVuf ") does not match %s (%" UVuf ")",
1133 "PerlIO layer function table size", (UV)tab->fsize,
1134 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1138 if (tab->size < sizeof(PerlIOl)) {
1140 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1141 "PerlIO layer instance size", (UV)tab->size,
1142 "size expected by this perl", (UV)sizeof(PerlIOl) );
1144 /* Real layer with a data area */
1147 Newxz(temp, tab->size, char);
1151 l->tab = (PerlIO_funcs*) tab;
1152 l->head = ((PerlIOl*)f)->head;
1154 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1155 (void*)f, tab->name,
1156 (mode) ? mode : "(Null)", (void*)arg) );
1157 if (*l->tab->Pushed &&
1159 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1160 PerlIO_pop(aTHX_ f);
1169 /* Pseudo-layer where push does its own stack adjust */
1170 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1171 (mode) ? mode : "(Null)", (void*)arg) );
1173 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1181 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1182 IV n, const char *mode, int fd, int imode, int perm,
1183 PerlIO *old, int narg, SV **args)
1185 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1186 if (tab && tab->Open) {
1187 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1188 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1194 SETERRNO(EINVAL, LIB_INVARG);
1199 PerlIOBase_binmode(pTHX_ PerlIO *f)
1201 if (PerlIOValid(f)) {
1202 /* Is layer suitable for raw stream ? */
1203 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1204 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1205 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1208 /* Not suitable - pop it */
1209 PerlIO_pop(aTHX_ f);
1217 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1219 PERL_UNUSED_ARG(mode);
1220 PERL_UNUSED_ARG(arg);
1221 PERL_UNUSED_ARG(tab);
1223 if (PerlIOValid(f)) {
1228 * Strip all layers that are not suitable for a raw stream
1231 while (t && (l = *t)) {
1232 if (l->tab && l->tab->Binmode) {
1233 /* Has a handler - normal case */
1234 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1236 /* Layer still there - move down a layer */
1245 /* No handler - pop it */
1246 PerlIO_pop(aTHX_ t);
1249 if (PerlIOValid(f)) {
1250 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1251 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1259 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1260 PerlIO_list_t *layers, IV n, IV max)
1264 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1266 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1277 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1281 save_scalar(PL_errgv);
1283 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1284 code = PerlIO_parse_layers(aTHX_ layers, names);
1286 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1288 PerlIO_list_free(aTHX_ layers);
1295 /*--------------------------------------------------------------------------------------*/
1297 * Given the abstraction above the public API functions
1301 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1303 PERL_UNUSED_ARG(iotype);
1304 PERL_UNUSED_ARG(mode);
1307 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1308 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1309 PerlIOBase(f)->tab->name : "(Null)",
1310 iotype, mode, (names) ? names : "(Null)") );
1313 /* Do not flush etc. if (e.g.) switching encodings.
1314 if a pushed layer knows it needs to flush lower layers
1315 (for example :unix which is never going to call them)
1316 it can do the flush when it is pushed.
1318 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1321 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1322 #ifdef PERLIO_USING_CRLF
1323 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1324 O_BINARY so we can look for it in mode.
1326 if (!(mode & O_BINARY)) {
1328 /* FIXME?: Looking down the layer stack seems wrong,
1329 but is a way of reaching past (say) an encoding layer
1330 to flip CRLF-ness of the layer(s) below
1333 /* Perhaps we should turn on bottom-most aware layer
1334 e.g. Ilya's idea that UNIX TTY could serve
1336 if (PerlIOBase(f)->tab &&
1337 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1339 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1340 /* Not in text mode - flush any pending stuff and flip it */
1342 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1344 /* Only need to turn it on in one layer so we are done */
1349 /* Not finding a CRLF aware layer presumably means we are binary
1350 which is not what was requested - so we failed
1351 We _could_ push :crlf layer but so could caller
1356 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1357 So code that used to be here is now in PerlIORaw_pushed().
1359 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1364 PerlIO__close(pTHX_ PerlIO *f)
1366 if (PerlIOValid(f)) {
1367 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1368 if (tab && tab->Close)
1369 return (*tab->Close)(aTHX_ f);
1371 return PerlIOBase_close(aTHX_ f);
1374 SETERRNO(EBADF, SS_IVCHAN);
1380 Perl_PerlIO_close(pTHX_ PerlIO *f)
1382 const int code = PerlIO__close(aTHX_ f);
1383 while (PerlIOValid(f)) {
1384 PerlIO_pop(aTHX_ f);
1385 if (PerlIO_lockcnt(f))
1386 /* we're in use; the 'pop' deferred freeing the structure */
1393 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1395 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1399 static PerlIO_funcs *
1400 PerlIO_layer_from_ref(pTHX_ SV *sv)
1403 * For any scalar type load the handler which is bundled with perl
1405 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1406 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1407 /* This isn't supposed to happen, since PerlIO::scalar is core,
1408 * but could happen anyway in smaller installs or with PAR */
1410 /* diag_listed_as: Unknown PerlIO layer "%s" */
1411 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1416 * For other types allow if layer is known but don't try and load it
1418 switch (SvTYPE(sv)) {
1420 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1422 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1424 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1426 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1433 PerlIO_resolve_layers(pTHX_ const char *layers,
1434 const char *mode, int narg, SV **args)
1436 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1439 PerlIO_stdstreams(aTHX);
1441 SV * const arg = *args;
1443 * If it is a reference but not an object see if we have a handler
1446 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1447 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1449 def = PerlIO_list_alloc(aTHX);
1450 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1454 * Don't fail if handler cannot be found :via(...) etc. may do
1455 * something sensible else we will just stringfy and open
1460 if (!layers || !*layers)
1461 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1462 if (layers && *layers) {
1465 av = PerlIO_clone_list(aTHX_ def, NULL);
1470 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1474 PerlIO_list_free(aTHX_ av);
1486 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1487 int imode, int perm, PerlIO *f, int narg, SV **args)
1489 if (!f && narg == 1 && *args == &PL_sv_undef) {
1490 if ((f = PerlIO_tmpfile())) {
1491 if (!layers || !*layers)
1492 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1493 if (layers && *layers)
1494 PerlIO_apply_layers(aTHX_ f, mode, layers);
1498 PerlIO_list_t *layera;
1500 PerlIO_funcs *tab = NULL;
1501 if (PerlIOValid(f)) {
1503 * This is "reopen" - it is not tested as perl does not use it
1507 layera = PerlIO_list_alloc(aTHX);
1510 if (l->tab && l->tab->Getarg)
1511 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1512 PerlIO_list_push(aTHX_ layera, l->tab,
1513 (arg) ? arg : &PL_sv_undef);
1515 l = *PerlIONext(&l);
1519 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1525 * Start at "top" of layer stack
1527 n = layera->cur - 1;
1529 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1538 * Found that layer 'n' can do opens - call it
1540 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1541 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1543 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1544 tab->name, layers ? layers : "(Null)", mode, fd,
1545 imode, perm, (void*)f, narg, (void*)args) );
1547 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1550 SETERRNO(EINVAL, LIB_INVARG);
1554 if (n + 1 < layera->cur) {
1556 * More layers above the one that we used to open -
1559 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1560 /* If pushing layers fails close the file */
1567 PerlIO_list_free(aTHX_ layera);
1574 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1576 PERL_ARGS_ASSERT_PERLIO_READ;
1578 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1582 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1584 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1586 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1590 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1592 PERL_ARGS_ASSERT_PERLIO_WRITE;
1594 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1598 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1600 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1604 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1606 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1610 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1614 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1616 if (tab && tab->Flush)
1617 return (*tab->Flush) (aTHX_ f);
1619 return 0; /* If no Flush defined, silently succeed. */
1622 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1623 SETERRNO(EBADF, SS_IVCHAN);
1629 * Is it good API design to do flush-all on NULL, a potentially
1630 * erroneous input? Maybe some magical value (PerlIO*
1631 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1632 * things on fflush(NULL), but should we be bound by their design
1635 PerlIOl **table = &PL_perlio;
1638 while ((ff = *table)) {
1640 table = (PerlIOl **) (ff++);
1641 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1642 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1652 PerlIOBase_flush_linebuf(pTHX)
1654 PerlIOl **table = &PL_perlio;
1656 while ((f = *table)) {
1658 table = (PerlIOl **) (f++);
1659 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1661 && (PerlIOBase(&(f->next))->
1662 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1663 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1664 PerlIO_flush(&(f->next));
1671 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1673 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1677 PerlIO_isutf8(PerlIO *f)
1680 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1682 SETERRNO(EBADF, SS_IVCHAN);
1688 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1690 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1694 Perl_PerlIO_error(pTHX_ PerlIO *f)
1696 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1700 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1702 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1706 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1708 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1712 PerlIO_has_base(PerlIO *f)
1714 if (PerlIOValid(f)) {
1715 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1718 return (tab->Get_base != NULL);
1725 PerlIO_fast_gets(PerlIO *f)
1727 if (PerlIOValid(f)) {
1728 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1729 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1732 return (tab->Set_ptrcnt != NULL);
1740 PerlIO_has_cntptr(PerlIO *f)
1742 if (PerlIOValid(f)) {
1743 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1746 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1753 PerlIO_canset_cnt(PerlIO *f)
1755 if (PerlIOValid(f)) {
1756 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1759 return (tab->Set_ptrcnt != NULL);
1766 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1768 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1772 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1774 /* Note that Get_bufsiz returns a Size_t */
1775 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1779 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1781 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1785 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1787 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1791 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1793 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1797 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1799 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1803 /*--------------------------------------------------------------------------------------*/
1805 * utf8 and raw dummy layers
1809 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1811 PERL_UNUSED_CONTEXT;
1812 PERL_UNUSED_ARG(mode);
1813 PERL_UNUSED_ARG(arg);
1814 if (PerlIOValid(f)) {
1815 if (tab && tab->kind & PERLIO_K_UTF8)
1816 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1818 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1824 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1825 sizeof(PerlIO_funcs),
1828 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1848 NULL, /* get_base */
1849 NULL, /* get_bufsiz */
1852 NULL, /* set_ptrcnt */
1855 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1856 sizeof(PerlIO_funcs),
1859 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1879 NULL, /* get_base */
1880 NULL, /* get_bufsiz */
1883 NULL, /* set_ptrcnt */
1886 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1887 sizeof(PerlIO_funcs),
1910 NULL, /* get_base */
1911 NULL, /* get_bufsiz */
1914 NULL, /* set_ptrcnt */
1916 /*--------------------------------------------------------------------------------------*/
1917 /*--------------------------------------------------------------------------------------*/
1919 * "Methods" of the "base class"
1923 PerlIOBase_fileno(pTHX_ PerlIO *f)
1925 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1929 PerlIO_modestr(PerlIO * f, char *buf)
1932 if (PerlIOValid(f)) {
1933 const IV flags = PerlIOBase(f)->flags;
1934 if (flags & PERLIO_F_APPEND) {
1936 if (flags & PERLIO_F_CANREAD) {
1940 else if (flags & PERLIO_F_CANREAD) {
1942 if (flags & PERLIO_F_CANWRITE)
1945 else if (flags & PERLIO_F_CANWRITE) {
1947 if (flags & PERLIO_F_CANREAD) {
1951 #ifdef PERLIO_USING_CRLF
1952 if (!(flags & PERLIO_F_CRLF))
1962 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1964 PerlIOl * const l = PerlIOBase(f);
1965 PERL_UNUSED_CONTEXT;
1966 PERL_UNUSED_ARG(arg);
1968 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1969 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1970 if (tab && tab->Set_ptrcnt != NULL)
1971 l->flags |= PERLIO_F_FASTGETS;
1973 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1977 l->flags |= PERLIO_F_CANREAD;
1980 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1983 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1986 SETERRNO(EINVAL, LIB_INVARG);
1991 /* The mode variable contains one positional parameter followed by
1992 * optional keyword parameters. The positional parameters must be
1993 * passed as lowercase characters. The keyword parameters can be
1994 * passed in mixed case. They must be separated by commas. Only one
1995 * instance of a keyword can be specified. */
2001 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2005 l->flags &= ~PERLIO_F_CRLF;
2009 l->flags |= PERLIO_F_CRLF;
2023 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2026 l->flags &= ~PERLIO_F_CRLF;
2029 l->flags |= PERLIO_F_CRLF;
2032 SETERRNO(EINVAL, LIB_INVARG);
2040 l->flags |= l->next->flags &
2041 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2047 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2048 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2049 l->flags, PerlIO_modestr(f, temp));
2056 PerlIOBase_popped(pTHX_ PerlIO *f)
2058 PERL_UNUSED_CONTEXT;
2064 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2067 * Save the position as current head considers it
2069 const Off_t old = PerlIO_tell(f);
2070 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2071 PerlIOSelf(f, PerlIOBuf)->posn = old;
2072 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2076 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2078 STDCHAR *buf = (STDCHAR *) vbuf;
2080 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2081 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2082 SETERRNO(EBADF, SS_IVCHAN);
2083 PerlIO_save_errno(f);
2089 SSize_t avail = PerlIO_get_cnt(f);
2092 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2094 STDCHAR *ptr = PerlIO_get_ptr(f);
2095 Copy(ptr, buf, take, STDCHAR);
2096 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2099 if (avail == 0) /* set_ptrcnt could have reset avail */
2102 if (count > 0 && avail <= 0) {
2103 if (PerlIO_fill(f) != 0)
2108 return (buf - (STDCHAR *) vbuf);
2114 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2116 PERL_UNUSED_CONTEXT;
2122 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2124 PERL_UNUSED_CONTEXT;
2130 PerlIOBase_close(pTHX_ PerlIO *f)
2133 if (PerlIOValid(f)) {
2134 PerlIO *n = PerlIONext(f);
2135 code = PerlIO_flush(f);
2136 PerlIOBase(f)->flags &=
2137 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2138 while (PerlIOValid(n)) {
2139 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2140 if (tab && tab->Close) {
2141 if ((*tab->Close)(aTHX_ n) != 0)
2146 PerlIOBase(n)->flags &=
2147 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2153 SETERRNO(EBADF, SS_IVCHAN);
2159 PerlIOBase_eof(pTHX_ PerlIO *f)
2161 PERL_UNUSED_CONTEXT;
2162 if (PerlIOValid(f)) {
2163 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2169 PerlIOBase_error(pTHX_ PerlIO *f)
2171 PERL_UNUSED_CONTEXT;
2172 if (PerlIOValid(f)) {
2173 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2179 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2181 if (PerlIOValid(f)) {
2182 PerlIO * const n = PerlIONext(f);
2183 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2190 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2192 PERL_UNUSED_CONTEXT;
2193 if (PerlIOValid(f)) {
2194 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2199 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2205 arg = sv_dup(arg, param);
2206 SvREFCNT_inc_simple_void_NN(arg);
2210 return newSVsv(arg);
2213 PERL_UNUSED_ARG(param);
2214 return newSVsv(arg);
2219 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2221 PerlIO * const nexto = PerlIONext(o);
2222 if (PerlIOValid(nexto)) {
2223 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2224 if (tab && tab->Dup)
2225 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2227 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2230 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2234 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2236 (void*)f, (void*)o, (void*)param) );
2238 arg = (*self->Getarg)(aTHX_ o, param, flags);
2239 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2240 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2241 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2247 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2249 /* Must be called with PL_perlio_mutex locked. */
2251 S_more_refcounted_fds(pTHX_ const int new_fd)
2252 PERL_TSA_REQUIRES(PL_perlio_mutex)
2255 const int old_max = PL_perlio_fd_refcnt_size;
2256 const int new_max = 16 + (new_fd & ~15);
2259 #ifndef PERL_IMPLICIT_SYS
2260 PERL_UNUSED_CONTEXT;
2263 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2264 old_max, new_fd, new_max) );
2266 if (new_fd < old_max) {
2270 assert (new_max > new_fd);
2272 /* Use plain realloc() since we need this memory to be really
2273 * global and visible to all the interpreters and/or threads. */
2274 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2278 MUTEX_UNLOCK(&PL_perlio_mutex);
2283 PL_perlio_fd_refcnt_size = new_max;
2284 PL_perlio_fd_refcnt = new_array;
2286 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2287 (void*)(new_array + old_max),
2288 new_max - old_max) );
2290 Zero(new_array + old_max, new_max - old_max, int);
2297 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2298 PERL_UNUSED_CONTEXT;
2302 PerlIOUnix_refcnt_inc(int fd)
2309 MUTEX_LOCK(&PL_perlio_mutex);
2311 if (fd >= PL_perlio_fd_refcnt_size)
2312 S_more_refcounted_fds(aTHX_ fd);
2314 PL_perlio_fd_refcnt[fd]++;
2315 if (PL_perlio_fd_refcnt[fd] <= 0) {
2316 /* diag_listed_as: refcnt_inc: fd %d%s */
2317 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2318 fd, PL_perlio_fd_refcnt[fd]);
2320 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2321 fd, PL_perlio_fd_refcnt[fd]) );
2324 MUTEX_UNLOCK(&PL_perlio_mutex);
2327 /* diag_listed_as: refcnt_inc: fd %d%s */
2328 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2333 PerlIOUnix_refcnt_dec(int fd)
2343 MUTEX_LOCK(&PL_perlio_mutex);
2345 if (fd >= PL_perlio_fd_refcnt_size) {
2346 /* diag_listed_as: refcnt_dec: fd %d%s */
2347 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2348 fd, PL_perlio_fd_refcnt_size);
2350 if (PL_perlio_fd_refcnt[fd] <= 0) {
2351 /* diag_listed_as: refcnt_dec: fd %d%s */
2352 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2353 fd, PL_perlio_fd_refcnt[fd]);
2355 cnt = --PL_perlio_fd_refcnt[fd];
2356 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2358 MUTEX_UNLOCK(&PL_perlio_mutex);
2361 /* diag_listed_as: refcnt_dec: fd %d%s */
2362 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2368 PerlIOUnix_refcnt(int fd)
2375 MUTEX_LOCK(&PL_perlio_mutex);
2377 if (fd >= PL_perlio_fd_refcnt_size) {
2378 /* diag_listed_as: refcnt: fd %d%s */
2379 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2380 fd, PL_perlio_fd_refcnt_size);
2382 if (PL_perlio_fd_refcnt[fd] <= 0) {
2383 /* diag_listed_as: refcnt: fd %d%s */
2384 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2385 fd, PL_perlio_fd_refcnt[fd]);
2387 cnt = PL_perlio_fd_refcnt[fd];
2389 MUTEX_UNLOCK(&PL_perlio_mutex);
2392 /* diag_listed_as: refcnt: fd %d%s */
2393 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2399 PerlIO_cleanup(pTHX)
2403 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2405 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2408 /* Raise STDIN..STDERR refcount so we don't close them */
2409 for (i=0; i < 3; i++)
2410 PerlIOUnix_refcnt_inc(i);
2411 PerlIO_cleantable(aTHX_ &PL_perlio);
2412 /* Restore STDIN..STDERR refcount */
2413 for (i=0; i < 3; i++)
2414 PerlIOUnix_refcnt_dec(i);
2416 if (PL_known_layers) {
2417 PerlIO_list_free(aTHX_ PL_known_layers);
2418 PL_known_layers = NULL;
2420 if (PL_def_layerlist) {
2421 PerlIO_list_free(aTHX_ PL_def_layerlist);
2422 PL_def_layerlist = NULL;
2426 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2430 /* XXX we can't rely on an interpreter being present at this late stage,
2431 XXX so we can't use a function like PerlLIO_write that relies on one
2432 being present (at least in win32) :-(.
2437 /* By now all filehandles should have been closed, so any
2438 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2440 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2441 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2442 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2444 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2445 if (PL_perlio_fd_refcnt[i]) {
2447 my_snprintf(buf, sizeof(buf),
2448 "PerlIO_teardown: fd %d refcnt=%d\n",
2449 i, PL_perlio_fd_refcnt[i]);
2450 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2456 /* Not bothering with PL_perlio_mutex since by now
2457 * all the interpreters are gone. */
2458 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2459 && PL_perlio_fd_refcnt) {
2460 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2461 PL_perlio_fd_refcnt = NULL;
2462 PL_perlio_fd_refcnt_size = 0;
2466 /*--------------------------------------------------------------------------------------*/
2468 * Bottom-most level for UNIX-like case
2472 struct _PerlIO base; /* The generic part */
2473 int fd; /* UNIX like file descriptor */
2474 int oflags; /* open/fcntl flags */
2478 S_lockcnt_dec(pTHX_ const void* f)
2480 #ifndef PERL_IMPLICIT_SYS
2481 PERL_UNUSED_CONTEXT;
2483 PerlIO_lockcnt((PerlIO*)f)--;
2487 /* call the signal handler, and if that handler happens to clear
2488 * this handle, free what we can and return true */
2491 S_perlio_async_run(pTHX_ PerlIO* f) {
2493 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2494 PerlIO_lockcnt(f)++;
2496 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2500 /* we've just run some perl-level code that could have done
2501 * anything, including closing the file or clearing this layer.
2502 * If so, free any lower layers that have already been
2503 * cleared, then return an error. */
2504 while (PerlIOValid(f) &&
2505 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2507 const PerlIOl *l = *f;
2516 PerlIOUnix_oflags(const char *mode)
2519 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2524 if (*++mode == '+') {
2531 oflags = O_CREAT | O_TRUNC;
2532 if (*++mode == '+') {
2541 oflags = O_CREAT | O_APPEND;
2542 if (*++mode == '+') {
2551 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2553 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2554 * of them in, and then bit-and-masking the other them away, won't
2555 * have much of an effect. */
2558 #if O_TEXT != O_BINARY
2565 #if O_TEXT != O_BINARY
2567 oflags &= ~O_BINARY;
2573 /* bit-or:ing with zero O_BINARY would be useless. */
2575 * If neither "t" nor "b" was specified, open the file
2578 * Note that if something else than the zero byte was seen
2579 * here (e.g. bogus mode "rx"), just few lines later we will
2580 * set the errno and invalidate the flags.
2586 if (*mode || oflags == -1) {
2587 SETERRNO(EINVAL, LIB_INVARG);
2594 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2596 PERL_UNUSED_CONTEXT;
2597 return PerlIOSelf(f, PerlIOUnix)->fd;
2601 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2603 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2606 if (PerlLIO_fstat(fd, &st) == 0) {
2607 if (!S_ISREG(st.st_mode)) {
2608 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2609 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2612 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2618 PerlIOUnix_refcnt_inc(fd);
2619 PERL_UNUSED_CONTEXT;
2623 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2625 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2626 if (*PerlIONext(f)) {
2627 /* We never call down so do any pending stuff now */
2628 PerlIO_flush(PerlIONext(f));
2630 * XXX could (or should) we retrieve the oflags from the open file
2631 * handle rather than believing the "mode" we are passed in? XXX
2632 * Should the value on NULL mode be 0 or -1?
2634 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2635 mode ? PerlIOUnix_oflags(mode) : -1);
2637 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2643 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2645 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2647 PERL_UNUSED_CONTEXT;
2648 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2650 SETERRNO(ESPIPE, LIB_INVARG);
2652 SETERRNO(EINVAL, LIB_INVARG);
2656 new_loc = PerlLIO_lseek(fd, offset, whence);
2657 if (new_loc == (Off_t) - 1)
2659 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2664 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2665 IV n, const char *mode, int fd, int imode,
2666 int perm, PerlIO *f, int narg, SV **args)
2668 if (PerlIOValid(f)) {
2669 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2670 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2673 if (*mode == IoTYPE_NUMERIC)
2676 imode = PerlIOUnix_oflags(mode);
2678 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2685 const char *path = SvPV_const(*args, len);
2686 if (!IS_SAFE_PATHNAME(path, len, "open"))
2688 fd = PerlLIO_open3(path, imode, perm);
2692 if (*mode == IoTYPE_IMPLICIT)
2695 f = PerlIO_allocate(aTHX);
2697 if (!PerlIOValid(f)) {
2698 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2703 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2704 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2705 if (*mode == IoTYPE_APPEND)
2706 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2713 * FIXME: pop layers ???
2721 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2723 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2725 if (flags & PERLIO_DUP_FD) {
2726 fd = PerlLIO_dup(fd);
2729 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2731 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2732 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2742 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2745 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2747 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2748 #ifdef PERLIO_STD_SPECIAL
2750 return PERLIO_STD_IN(fd, vbuf, count);
2752 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2753 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2757 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2758 if (len >= 0 || errno != EINTR) {
2760 if (errno != EAGAIN) {
2761 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2762 PerlIO_save_errno(f);
2765 else if (len == 0 && count != 0) {
2766 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2772 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2775 NOT_REACHED; /*NOTREACHED*/
2779 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2782 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2784 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2785 #ifdef PERLIO_STD_SPECIAL
2786 if (fd == 1 || fd == 2)
2787 return PERLIO_STD_OUT(fd, vbuf, count);
2790 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2791 if (len >= 0 || errno != EINTR) {
2793 if (errno != EAGAIN) {
2794 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2795 PerlIO_save_errno(f);
2801 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2804 NOT_REACHED; /*NOTREACHED*/
2808 PerlIOUnix_tell(pTHX_ PerlIO *f)
2810 PERL_UNUSED_CONTEXT;
2812 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2817 PerlIOUnix_close(pTHX_ PerlIO *f)
2819 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2821 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2822 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2823 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2828 SETERRNO(EBADF,SS_IVCHAN);
2831 while (PerlLIO_close(fd) != 0) {
2832 if (errno != EINTR) {
2837 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2841 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2846 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2847 sizeof(PerlIO_funcs),
2854 PerlIOBase_binmode, /* binmode */
2864 PerlIOBase_noop_ok, /* flush */
2865 PerlIOBase_noop_fail, /* fill */
2868 PerlIOBase_clearerr,
2869 PerlIOBase_setlinebuf,
2870 NULL, /* get_base */
2871 NULL, /* get_bufsiz */
2874 NULL, /* set_ptrcnt */
2877 /*--------------------------------------------------------------------------------------*/
2882 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2883 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2884 broken by the last second glibc 2.3 fix
2886 #define STDIO_BUFFER_WRITABLE
2891 struct _PerlIO base;
2892 FILE *stdio; /* The stream */
2896 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2898 PERL_UNUSED_CONTEXT;
2900 if (PerlIOValid(f)) {
2901 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2903 return PerlSIO_fileno(s);
2910 PerlIOStdio_mode(const char *mode, char *tmode)
2912 char * const ret = tmode;
2918 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2926 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2929 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2930 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2931 if (toptab == tab) {
2932 /* Top is already stdio - pop self (duplicate) and use original */
2933 PerlIO_pop(aTHX_ f);
2936 const int fd = PerlIO_fileno(n);
2939 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2940 mode = PerlIOStdio_mode(mode, tmode)))) {
2941 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2942 /* We never call down so do any pending stuff now */
2943 PerlIO_flush(PerlIONext(f));
2944 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2951 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2956 PerlIO_importFILE(FILE *stdio, const char *mode)
2962 char filename[FILENAME_MAX];
2967 int fd0 = fileno(stdio);
2970 rc = fldata(stdio,filename,&fileinfo);
2974 if(fileinfo.__dsorgHFS){
2977 /*This MVS dataset , OK!*/
2982 if (!mode || !*mode) {
2983 /* We need to probe to see how we can open the stream
2984 so start with read/write and then try write and read
2985 we dup() so that we can fclose without loosing the fd.
2987 Note that the errno value set by a failing fdopen
2988 varies between stdio implementations.
2990 const int fd = PerlLIO_dup(fd0);
2995 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2997 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3000 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3003 /* Don't seem to be able to open */
3009 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3010 s = PerlIOSelf(f, PerlIOStdio);
3013 fd0 = fileno(stdio);
3015 PerlIOUnix_refcnt_inc(fd0);
3018 rc = fldata(stdio,filename,&fileinfo);
3020 PerlIOUnix_refcnt_inc(fd0);
3022 if(fileinfo.__dsorgHFS){
3023 PerlIOUnix_refcnt_inc(fd0);
3025 /*This MVS dataset , OK!*/
3028 PerlIOUnix_refcnt_inc(fileno(stdio));
3036 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3037 IV n, const char *mode, int fd, int imode,
3038 int perm, PerlIO *f, int narg, SV **args)
3041 if (PerlIOValid(f)) {
3043 const char * const path = SvPV_const(*args, len);
3044 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3046 if (!IS_SAFE_PATHNAME(path, len, "open"))
3048 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3049 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3054 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3060 const char * const path = SvPV_const(*args, len);
3061 if (!IS_SAFE_PATHNAME(path, len, "open"))
3063 if (*mode == IoTYPE_NUMERIC) {
3065 fd = PerlLIO_open3(path, imode, perm);
3069 bool appended = FALSE;
3071 /* Cygwin wants its 'b' early. */
3073 mode = PerlIOStdio_mode(mode, tmode);
3075 stdio = PerlSIO_fopen(path, mode);
3078 f = PerlIO_allocate(aTHX);
3081 mode = PerlIOStdio_mode(mode, tmode);
3082 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3084 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3085 PerlIOUnix_refcnt_inc(fileno(stdio));
3087 PerlSIO_fclose(stdio);
3099 if (*mode == IoTYPE_IMPLICIT) {
3106 stdio = PerlSIO_stdin;
3109 stdio = PerlSIO_stdout;
3112 stdio = PerlSIO_stderr;
3117 stdio = PerlSIO_fdopen(fd, mode =
3118 PerlIOStdio_mode(mode, tmode));
3122 f = PerlIO_allocate(aTHX);
3124 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3125 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3126 PerlIOUnix_refcnt_inc(fileno(stdio));
3137 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3139 /* This assumes no layers underneath - which is what
3140 happens, but is not how I remember it. NI-S 2001/10/16
3142 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3143 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3144 const int fd = fileno(stdio);
3146 if (flags & PERLIO_DUP_FD) {
3147 const int dfd = PerlLIO_dup(fileno(stdio));
3149 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3154 /* FIXME: To avoid messy error recovery if dup fails
3155 re-use the existing stdio as though flag was not set
3159 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3161 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3163 PerlIOUnix_refcnt_inc(fileno(stdio));
3170 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3172 PERL_UNUSED_CONTEXT;
3174 /* XXX this could use PerlIO_canset_fileno() and
3175 * PerlIO_set_fileno() support from Configure
3177 # if defined(HAS_FDCLOSE)
3178 return fdclose(f, NULL) == 0 ? 1 : 0;
3179 # elif defined(__UCLIBC__)
3180 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3183 # elif defined(__GLIBC__)
3184 /* There may be a better way for GLIBC:
3185 - libio.h defines a flag to not close() on cleanup
3189 # elif defined(__sun)
3192 # elif defined(__hpux)
3196 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3197 your platform does not have special entry try this one.
3198 [For OSF only have confirmation for Tru64 (alpha)
3199 but assume other OSFs will be similar.]
3201 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3204 # elif defined(__FreeBSD__)
3205 /* There may be a better way on FreeBSD:
3206 - we could insert a dummy func in the _close function entry
3207 f->_close = (int (*)(void *)) dummy_close;
3211 # elif defined(__OpenBSD__)
3212 /* There may be a better way on OpenBSD:
3213 - we could insert a dummy func in the _close function entry
3214 f->_close = (int (*)(void *)) dummy_close;
3218 # elif defined(__EMX__)
3219 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3222 # elif defined(__CYGWIN__)
3223 /* There may be a better way on CYGWIN:
3224 - we could insert a dummy func in the _close function entry
3225 f->_close = (int (*)(void *)) dummy_close;
3229 # elif defined(WIN32)
3230 # if defined(UNDER_CE)
3231 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3235 PERLIO_FILE_file(f) = -1;
3240 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3241 (which isn't thread safe) instead
3243 # error "Don't know how to set FILE.fileno on your platform"
3251 PerlIOStdio_close(pTHX_ PerlIO *f)
3253 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3259 const int fd = fileno(stdio);
3267 #ifdef SOCKS5_VERSION_NAME
3268 /* Socks lib overrides close() but stdio isn't linked to
3269 that library (though we are) - so we must call close()
3270 on sockets on stdio's behalf.
3273 Sock_size_t optlen = sizeof(int);
3274 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3277 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3278 that a subsequent fileno() on it returns -1. Don't want to croak()
3279 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3280 trying to close an already closed handle which somehow it still has
3281 a reference to. (via.xs, I'm looking at you). */
3282 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3283 /* File descriptor still in use */
3287 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3288 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3290 if (stdio == stdout || stdio == stderr)
3291 return PerlIO_flush(f);
3294 MUTEX_LOCK(&PL_perlio_mutex);
3295 /* Right. We need a mutex here because for a brief while we
3296 will have the situation that fd is actually closed. Hence if
3297 a second thread were to get into this block, its dup() would
3298 likely return our fd as its dupfd. (after all, it is closed)
3299 Then if we get to the dup2() first, we blat the fd back
3300 (messing up its temporary as a side effect) only for it to
3301 then close its dupfd (== our fd) in its close(dupfd) */
3303 /* There is, of course, a race condition, that any other thread
3304 trying to input/output/whatever on this fd will be stuffed
3305 for the duration of this little manoeuvrer. Perhaps we
3306 should hold an IO mutex for the duration of every IO
3307 operation if we know that invalidate doesn't work on this
3308 platform, but that would suck, and could kill performance.
3310 Except that correctness trumps speed.
3311 Advice from klortho #11912. */
3314 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3315 Use Sarathy's trick from maint-5.6 to invalidate the
3316 fileno slot of the FILE *
3318 result = PerlIO_flush(f);
3320 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3322 dupfd = PerlLIO_dup(fd);
3325 /* Oh cXap. This isn't going to go well. Not sure if we can
3326 recover from here, or if closing this particular FILE *
3327 is a good idea now. */
3332 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3334 result = PerlSIO_fclose(stdio);
3335 /* We treat error from stdio as success if we invalidated
3336 errno may NOT be expected EBADF
3338 if (invalidate && result != 0) {
3342 #ifdef SOCKS5_VERSION_NAME
3343 /* in SOCKS' case, let close() determine return value */
3347 PerlLIO_dup2(dupfd,fd);
3348 PerlLIO_close(dupfd);
3351 MUTEX_UNLOCK(&PL_perlio_mutex);
3358 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3362 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3364 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3367 STDCHAR *buf = (STDCHAR *) vbuf;
3369 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3370 * stdio does not do that for fread()
3372 const int ch = PerlSIO_fgetc(s);
3379 got = PerlSIO_fread(vbuf, 1, count, s);
3380 if (got == 0 && PerlSIO_ferror(s))
3382 if (got >= 0 || errno != EINTR)
3384 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3386 SETERRNO(0,0); /* just in case */
3389 /* Under some circumstances IRIX stdio fgetc() and fread()
3390 * set the errno to ENOENT, which makes no sense according
3391 * to either IRIX or POSIX. [rt.perl.org #123977] */
3392 if (errno == ENOENT) SETERRNO(0,0);
3398 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3401 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3403 #ifdef STDIO_BUFFER_WRITABLE
3404 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3405 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3406 STDCHAR *base = PerlIO_get_base(f);
3407 SSize_t cnt = PerlIO_get_cnt(f);
3408 STDCHAR *ptr = PerlIO_get_ptr(f);
3409 SSize_t avail = ptr - base;
3411 if (avail > count) {
3415 Move(buf-avail,ptr,avail,STDCHAR);
3418 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3419 if (PerlSIO_feof(s) && unread >= 0)
3420 PerlSIO_clearerr(s);
3425 if (PerlIO_has_cntptr(f)) {
3426 /* We can get pointer to buffer but not its base
3427 Do ungetc() but check chars are ending up in the
3430 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3431 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3433 const int ch = *--buf & 0xFF;
3434 if (ungetc(ch,s) != ch) {
3435 /* ungetc did not work */
3438 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3439 /* Did not change pointer as expected */
3440 if (fgetc(s) != EOF) /* get char back again */
3450 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3456 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3459 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3462 got = PerlSIO_fwrite(vbuf, 1, count,
3463 PerlIOSelf(f, PerlIOStdio)->stdio);
3464 if (got >= 0 || errno != EINTR)
3466 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3468 SETERRNO(0,0); /* just in case */
3474 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3476 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3477 PERL_UNUSED_CONTEXT;
3479 return PerlSIO_fseek(stdio, offset, whence);
3483 PerlIOStdio_tell(pTHX_ PerlIO *f)
3485 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3486 PERL_UNUSED_CONTEXT;
3488 return PerlSIO_ftell(stdio);
3492 PerlIOStdio_flush(pTHX_ PerlIO *f)
3494 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3495 PERL_UNUSED_CONTEXT;
3497 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3498 return PerlSIO_fflush(stdio);
3504 * FIXME: This discards ungetc() and pre-read stuff which is not
3505 * right if this is just a "sync" from a layer above Suspect right
3506 * design is to do _this_ but not have layer above flush this
3507 * layer read-to-read
3510 * Not writeable - sync by attempting a seek
3513 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3521 PerlIOStdio_eof(pTHX_ PerlIO *f)
3523 PERL_UNUSED_CONTEXT;
3525 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3529 PerlIOStdio_error(pTHX_ PerlIO *f)
3531 PERL_UNUSED_CONTEXT;
3533 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3537 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3539 PERL_UNUSED_CONTEXT;
3541 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3545 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3547 PERL_UNUSED_CONTEXT;
3549 #ifdef HAS_SETLINEBUF
3550 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3552 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3558 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3560 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3561 PERL_UNUSED_CONTEXT;
3562 return (STDCHAR*)PerlSIO_get_base(stdio);
3566 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3568 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3569 PERL_UNUSED_CONTEXT;
3570 return PerlSIO_get_bufsiz(stdio);
3574 #ifdef USE_STDIO_PTR
3576 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3578 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3579 PERL_UNUSED_CONTEXT;
3580 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3584 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3586 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3587 PERL_UNUSED_CONTEXT;
3588 return PerlSIO_get_cnt(stdio);
3592 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3594 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3595 PERL_UNUSED_CONTEXT;
3597 #ifdef STDIO_PTR_LVALUE
3598 /* This is a long-standing infamous mess. The root of the
3599 * problem is that one cannot know the signedness of char, and
3600 * more precisely the signedness of FILE._ptr. The following
3601 * things have been tried, and they have all failed (across
3602 * different compilers (remember that core needs to to build
3603 * also with c++) and compiler options:
3605 * - casting the RHS to (void*) -- works in *some* places
3606 * - casting the LHS to (void*) -- totally unportable
3608 * So let's try silencing the warning at least for gcc. */
3609 GCC_DIAG_IGNORE(-Wpointer-sign);
3610 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3612 #ifdef STDIO_PTR_LVAL_SETS_CNT
3613 assert(PerlSIO_get_cnt(stdio) == (cnt));
3615 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3617 * Setting ptr _does_ change cnt - we are done
3621 #else /* STDIO_PTR_LVALUE */
3623 #endif /* STDIO_PTR_LVALUE */
3626 * Now (or only) set cnt
3628 #ifdef STDIO_CNT_LVALUE
3629 PerlSIO_set_cnt(stdio, cnt);
3630 #else /* STDIO_CNT_LVALUE */
3631 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3632 PerlSIO_set_ptr(stdio,
3633 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3635 #else /* STDIO_PTR_LVAL_SETS_CNT */
3637 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3638 #endif /* STDIO_CNT_LVALUE */
3645 PerlIOStdio_fill(pTHX_ PerlIO *f)
3649 PERL_UNUSED_CONTEXT;
3650 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3652 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3655 * fflush()ing read-only streams can cause trouble on some stdio-s
3657 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3658 if (PerlSIO_fflush(stdio) != 0)
3662 c = PerlSIO_fgetc(stdio);
3665 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3667 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3672 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3674 #ifdef STDIO_BUFFER_WRITABLE
3675 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3676 /* Fake ungetc() to the real buffer in case system's ungetc
3679 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3680 SSize_t cnt = PerlSIO_get_cnt(stdio);
3681 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3682 if (ptr == base+1) {
3683 *--ptr = (STDCHAR) c;
3684 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3685 if (PerlSIO_feof(stdio))
3686 PerlSIO_clearerr(stdio);
3692 if (PerlIO_has_cntptr(f)) {
3694 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3700 /* If buffer snoop scheme above fails fall back to
3703 if (PerlSIO_ungetc(c, stdio) != c)
3711 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3712 sizeof(PerlIO_funcs),
3714 sizeof(PerlIOStdio),
3715 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3719 PerlIOBase_binmode, /* binmode */
3733 PerlIOStdio_clearerr,
3734 PerlIOStdio_setlinebuf,
3736 PerlIOStdio_get_base,
3737 PerlIOStdio_get_bufsiz,
3742 #ifdef USE_STDIO_PTR
3743 PerlIOStdio_get_ptr,
3744 PerlIOStdio_get_cnt,
3745 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3746 PerlIOStdio_set_ptrcnt,
3749 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3754 #endif /* USE_STDIO_PTR */
3757 /* Note that calls to PerlIO_exportFILE() are reversed using
3758 * PerlIO_releaseFILE(), not importFILE. */
3760 PerlIO_exportFILE(PerlIO * f, const char *mode)
3764 if (PerlIOValid(f)) {
3766 int fd = PerlIO_fileno(f);
3771 if (!mode || !*mode) {
3772 mode = PerlIO_modestr(f, buf);
3774 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3778 /* De-link any lower layers so new :stdio sticks */
3780 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3781 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3783 PerlIOUnix_refcnt_inc(fileno(stdio));
3784 /* Link previous lower layers under new one */
3788 /* restore layers list */
3798 PerlIO_findFILE(PerlIO *f)
3803 if (l->tab == &PerlIO_stdio) {
3804 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3807 l = *PerlIONext(&l);
3809 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3810 /* However, we're not really exporting a FILE * to someone else (who
3811 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3812 So we need to undo its reference count increase on the underlying file
3813 descriptor. We have to do this, because if the loop above returns you
3814 the FILE *, then *it* didn't increase any reference count. So there's
3815 only one way to be consistent. */
3816 stdio = PerlIO_exportFILE(f, NULL);
3818 const int fd = fileno(stdio);
3820 PerlIOUnix_refcnt_dec(fd);
3825 /* Use this to reverse PerlIO_exportFILE calls. */
3827 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3831 if (l->tab == &PerlIO_stdio) {
3832 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3833 if (s->stdio == f) { /* not in a loop */
3834 const int fd = fileno(f);
3836 PerlIOUnix_refcnt_dec(fd);
3839 PerlIO_pop(aTHX_ p);
3849 /*--------------------------------------------------------------------------------------*/
3851 * perlio buffer layer
3855 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3857 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3858 const int fd = PerlIO_fileno(f);
3859 if (fd >= 0 && PerlLIO_isatty(fd)) {
3860 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3862 if (*PerlIONext(f)) {
3863 const Off_t posn = PerlIO_tell(PerlIONext(f));
3864 if (posn != (Off_t) - 1) {
3868 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3872 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3873 IV n, const char *mode, int fd, int imode, int perm,
3874 PerlIO *f, int narg, SV **args)
3876 if (PerlIOValid(f)) {
3877 PerlIO *next = PerlIONext(f);
3879 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3880 if (tab && tab->Open)
3882 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3884 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3889 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3891 if (*mode == IoTYPE_IMPLICIT) {
3897 if (tab && tab->Open)
3898 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3901 SETERRNO(EINVAL, LIB_INVARG);
3903 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3905 * if push fails during open, open fails. close will pop us.
3910 fd = PerlIO_fileno(f);
3911 if (init && fd == 2) {
3913 * Initial stderr is unbuffered
3915 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3917 #ifdef PERLIO_USING_CRLF
3918 # ifdef PERLIO_IS_BINMODE_FD
3919 if (PERLIO_IS_BINMODE_FD(fd))
3920 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3924 * do something about failing setmode()? --jhi
3926 PerlLIO_setmode(fd, O_BINARY);
3929 /* Enable line buffering with record-oriented regular files
3930 * so we don't introduce an extraneous record boundary when
3931 * the buffer fills up.
3933 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3935 if (PerlLIO_fstat(fd, &st) == 0
3936 && S_ISREG(st.st_mode)
3937 && (st.st_fab_rfm == FAB$C_VAR
3938 || st.st_fab_rfm == FAB$C_VFC)) {
3939 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3950 * This "flush" is akin to sfio's sync in that it handles files in either
3951 * read or write state. For write state, we put the postponed data through
3952 * the next layers. For read state, we seek() the next layers to the
3953 * offset given by current position in the buffer, and discard the buffer
3954 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3955 * in any case?). Then the pass the stick further in chain.
3958 PerlIOBuf_flush(pTHX_ PerlIO *f)
3960 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3962 PerlIO *n = PerlIONext(f);
3963 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3965 * write() the buffer
3967 const STDCHAR *buf = b->buf;
3968 const STDCHAR *p = buf;
3969 while (p < b->ptr) {
3970 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3974 else if (count < 0 || PerlIO_error(n)) {
3975 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3976 PerlIO_save_errno(f);
3981 b->posn += (p - buf);
3983 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3984 STDCHAR *buf = PerlIO_get_base(f);
3986 * Note position change
3988 b->posn += (b->ptr - buf);
3989 if (b->ptr < b->end) {
3990 /* We did not consume all of it - try and seek downstream to
3991 our logical position
3993 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3994 /* Reload n as some layers may pop themselves on seek */
3995 b->posn = PerlIO_tell(n = PerlIONext(f));
3998 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3999 data is lost for good - so return saying "ok" having undone
4002 b->posn -= (b->ptr - buf);
4007 b->ptr = b->end = b->buf;
4008 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4009 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4010 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4015 /* This discards the content of the buffer after b->ptr, and rereads
4016 * the buffer from the position off in the layer downstream; here off
4017 * is at offset corresponding to b->ptr - b->buf.
4020 PerlIOBuf_fill(pTHX_ PerlIO *f)
4022 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4023 PerlIO *n = PerlIONext(f);
4026 * Down-stream flush is defined not to loose read data so is harmless.
4027 * we would not normally be fill'ing if there was data left in anycase.
4029 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4031 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4032 PerlIOBase_flush_linebuf(aTHX);
4035 PerlIO_get_base(f); /* allocate via vtable */
4037 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4039 b->ptr = b->end = b->buf;
4041 if (!PerlIOValid(n)) {
4042 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4046 if (PerlIO_fast_gets(n)) {
4048 * Layer below is also buffered. We do _NOT_ want to call its
4049 * ->Read() because that will loop till it gets what we asked for
4050 * which may hang on a pipe etc. Instead take anything it has to
4051 * hand, or ask it to fill _once_.
4053 avail = PerlIO_get_cnt(n);
4055 avail = PerlIO_fill(n);
4057 avail = PerlIO_get_cnt(n);
4059 if (!PerlIO_error(n) && PerlIO_eof(n))
4064 STDCHAR *ptr = PerlIO_get_ptr(n);
4065 const SSize_t cnt = avail;
4066 if (avail > (SSize_t)b->bufsiz)
4068 Copy(ptr, b->buf, avail, STDCHAR);
4069 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4073 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4077 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4080 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4081 PerlIO_save_errno(f);
4085 b->end = b->buf + avail;
4086 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4091 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4093 if (PerlIOValid(f)) {
4094 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4097 return PerlIOBase_read(aTHX_ f, vbuf, count);
4103 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4105 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4106 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4109 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4114 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4116 * Buffer is already a read buffer, we can overwrite any chars
4117 * which have been read back to buffer start
4119 avail = (b->ptr - b->buf);
4123 * Buffer is idle, set it up so whole buffer is available for
4127 b->end = b->buf + avail;
4129 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4131 * Buffer extends _back_ from where we are now
4133 b->posn -= b->bufsiz;
4135 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4137 * If we have space for more than count, just move count
4145 * In simple stdio-like ungetc() case chars will be already
4148 if (buf != b->ptr) {
4149 Copy(buf, b->ptr, avail, STDCHAR);
4153 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4157 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4163 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4165 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4166 const STDCHAR *buf = (const STDCHAR *) vbuf;
4167 const STDCHAR *flushptr = buf;
4171 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4173 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4174 if (PerlIO_flush(f) != 0) {
4178 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4179 flushptr = buf + count;
4180 while (flushptr > buf && *(flushptr - 1) != '\n')
4184 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4185 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4187 if (flushptr > buf && flushptr <= buf + avail)
4188 avail = flushptr - buf;
4189 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4191 Copy(buf, b->ptr, avail, STDCHAR);
4196 if (buf == flushptr)
4199 if (b->ptr >= (b->buf + b->bufsiz))
4200 if (PerlIO_flush(f) == -1)
4203 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4209 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4212 if ((code = PerlIO_flush(f)) == 0) {
4213 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4214 code = PerlIO_seek(PerlIONext(f), offset, whence);
4216 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4217 b->posn = PerlIO_tell(PerlIONext(f));
4224 PerlIOBuf_tell(pTHX_ PerlIO *f)
4226 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4228 * b->posn is file position where b->buf was read, or will be written
4230 Off_t posn = b->posn;
4231 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4232 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4234 /* As O_APPEND files are normally shared in some sense it is better
4239 /* when file is NOT shared then this is sufficient */
4240 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4242 posn = b->posn = PerlIO_tell(PerlIONext(f));
4246 * If buffer is valid adjust position by amount in buffer
4248 posn += (b->ptr - b->buf);
4254 PerlIOBuf_popped(pTHX_ PerlIO *f)
4256 const IV code = PerlIOBase_popped(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_close(pTHX_ PerlIO *f)
4269 const IV code = PerlIOBase_close(aTHX_ f);
4270 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4271 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4274 b->ptr = b->end = b->buf = NULL;
4275 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4280 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4282 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4289 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4291 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4294 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4295 return (b->end - b->ptr);
4300 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4302 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4303 PERL_UNUSED_CONTEXT;
4307 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4308 Newxz(b->buf,b->bufsiz, STDCHAR);
4310 b->buf = (STDCHAR *) & b->oneword;
4311 b->bufsiz = sizeof(b->oneword);
4313 b->end = b->ptr = b->buf;
4319 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4321 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4324 return (b->end - b->buf);
4328 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4330 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4332 PERL_UNUSED_ARG(cnt);
4337 assert(PerlIO_get_cnt(f) == cnt);
4338 assert(b->ptr >= b->buf);
4339 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4343 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4345 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4350 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4351 sizeof(PerlIO_funcs),
4354 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4358 PerlIOBase_binmode, /* binmode */
4372 PerlIOBase_clearerr,
4373 PerlIOBase_setlinebuf,
4378 PerlIOBuf_set_ptrcnt,
4381 /*--------------------------------------------------------------------------------------*/
4383 * Temp layer to hold unread chars when cannot do it any other way
4387 PerlIOPending_fill(pTHX_ PerlIO *f)
4390 * Should never happen
4397 PerlIOPending_close(pTHX_ PerlIO *f)
4400 * A tad tricky - flush pops us, then we close new top
4403 return PerlIO_close(f);
4407 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4410 * A tad tricky - flush pops us, then we seek new top
4413 return PerlIO_seek(f, offset, whence);
4418 PerlIOPending_flush(pTHX_ PerlIO *f)
4420 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4421 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4425 PerlIO_pop(aTHX_ f);
4430 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4436 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4441 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4443 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4444 PerlIOl * const l = PerlIOBase(f);
4446 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4447 * etc. get muddled when it changes mid-string when we auto-pop.
4449 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4450 (PerlIOBase(PerlIONext(f))->
4451 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4456 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4458 SSize_t avail = PerlIO_get_cnt(f);
4460 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4463 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4464 if (got >= 0 && got < (SSize_t)count) {
4465 const SSize_t more =
4466 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4467 if (more >= 0 || got == 0)
4473 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4474 sizeof(PerlIO_funcs),
4477 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4478 PerlIOPending_pushed,
4481 PerlIOBase_binmode, /* binmode */
4490 PerlIOPending_close,
4491 PerlIOPending_flush,
4495 PerlIOBase_clearerr,
4496 PerlIOBase_setlinebuf,
4501 PerlIOPending_set_ptrcnt,
4506 /*--------------------------------------------------------------------------------------*/
4508 * crlf - translation On read translate CR,LF to "\n" we do this by
4509 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4510 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4512 * c->nl points on the first byte of CR LF pair when it is temporarily
4513 * replaced by LF, or to the last CR of the buffer. In the former case
4514 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4515 * that it ends at c->nl; these two cases can be distinguished by
4516 * *c->nl. c->nl is set during _getcnt() call, and unset during
4517 * _unread() and _flush() calls.
4518 * It only matters for read operations.
4522 PerlIOBuf base; /* PerlIOBuf stuff */
4523 STDCHAR *nl; /* Position of crlf we "lied" about in the
4527 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4528 * Otherwise the :crlf layer would always revert back to
4532 S_inherit_utf8_flag(PerlIO *f)
4534 PerlIO *g = PerlIONext(f);
4535 if (PerlIOValid(g)) {
4536 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4537 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4543 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4546 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4547 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4550 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4551 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4552 PerlIOBase(f)->flags);
4556 /* If the old top layer is a CRLF layer, reactivate it (if
4557 * necessary) and remove this new layer from the stack */
4558 PerlIO *g = PerlIONext(f);
4559 if (PerlIOValid(g)) {
4560 PerlIOl *b = PerlIOBase(g);
4561 if (b && b->tab == &PerlIO_crlf) {
4562 if (!(b->flags & PERLIO_F_CRLF))
4563 b->flags |= PERLIO_F_CRLF;
4564 S_inherit_utf8_flag(g);
4565 PerlIO_pop(aTHX_ f);
4570 S_inherit_utf8_flag(f);
4576 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4578 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4579 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4580 *(c->nl) = NATIVE_0xd;
4583 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4584 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4586 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4587 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4589 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4594 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4595 b->end = b->ptr = b->buf + b->bufsiz;
4596 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4597 b->posn -= b->bufsiz;
4599 while (count > 0 && b->ptr > b->buf) {
4600 const int ch = *--buf;
4602 if (b->ptr - 2 >= b->buf) {
4603 *--(b->ptr) = NATIVE_0xa;
4604 *--(b->ptr) = NATIVE_0xd;
4609 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4610 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4624 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4629 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4631 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4633 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4636 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4637 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4638 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4639 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4641 while (nl < b->end && *nl != NATIVE_0xd)
4643 if (nl < b->end && *nl == NATIVE_0xd) {
4645 if (nl + 1 < b->end) {
4646 if (nl[1] == NATIVE_0xa) {
4652 * Not CR,LF but just CR
4660 * Blast - found CR as last char in buffer
4665 * They may not care, defer work as long as
4669 return (nl - b->ptr);
4673 b->ptr++; /* say we have read it as far as
4674 * flush() is concerned */
4675 b->buf++; /* Leave space in front of buffer */
4676 /* Note as we have moved buf up flush's
4678 will naturally make posn point at CR
4680 b->bufsiz--; /* Buffer is thus smaller */
4681 code = PerlIO_fill(f); /* Fetch some more */
4682 b->bufsiz++; /* Restore size for next time */
4683 b->buf--; /* Point at space */
4684 b->ptr = nl = b->buf; /* Which is what we hand
4686 *nl = NATIVE_0xd; /* Fill in the CR */
4688 goto test; /* fill() call worked */
4690 * CR at EOF - just fall through
4692 /* Should we clear EOF though ??? */
4697 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4703 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4705 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4706 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4712 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4713 /* Deferred CR at end of buffer case - we lied about count */
4726 * Test code - delete when it works ...
4728 IV flags = PerlIOBase(f)->flags;
4729 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4730 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4731 /* Deferred CR at end of buffer case - we lied about count */
4737 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4738 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4739 flags, c->nl, b->end, cnt);
4746 * They have taken what we lied about
4748 *(c->nl) = NATIVE_0xd;
4754 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4758 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4760 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4761 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4763 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4764 const STDCHAR *buf = (const STDCHAR *) vbuf;
4765 const STDCHAR * const ebuf = buf + count;
4768 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4770 while (buf < ebuf) {
4771 const STDCHAR * const eptr = b->buf + b->bufsiz;
4772 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4773 while (buf < ebuf && b->ptr < eptr) {
4775 if ((b->ptr + 2) > eptr) {
4783 *(b->ptr)++ = NATIVE_0xd; /* CR */
4784 *(b->ptr)++ = NATIVE_0xa; /* LF */
4786 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4793 *(b->ptr)++ = *buf++;
4795 if (b->ptr >= eptr) {
4801 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4803 return (buf - (STDCHAR *) vbuf);
4808 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4810 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4812 *(c->nl) = NATIVE_0xd;
4815 return PerlIOBuf_flush(aTHX_ f);
4819 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4821 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4822 /* In text mode - flush any pending stuff and flip it */
4823 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4824 #ifndef PERLIO_USING_CRLF
4825 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4826 PerlIO_pop(aTHX_ f);
4832 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4833 sizeof(PerlIO_funcs),
4836 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4838 PerlIOBuf_popped, /* popped */
4840 PerlIOCrlf_binmode, /* binmode */
4844 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4845 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4846 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4854 PerlIOBase_clearerr,
4855 PerlIOBase_setlinebuf,
4860 PerlIOCrlf_set_ptrcnt,
4864 Perl_PerlIO_stdin(pTHX)
4867 PerlIO_stdstreams(aTHX);
4869 return (PerlIO*)&PL_perlio[1];
4873 Perl_PerlIO_stdout(pTHX)
4876 PerlIO_stdstreams(aTHX);
4878 return (PerlIO*)&PL_perlio[2];
4882 Perl_PerlIO_stderr(pTHX)
4885 PerlIO_stdstreams(aTHX);
4887 return (PerlIO*)&PL_perlio[3];
4890 /*--------------------------------------------------------------------------------------*/
4893 PerlIO_getname(PerlIO *f, char *buf)
4898 bool exported = FALSE;
4899 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4901 stdio = PerlIO_exportFILE(f,0);
4905 name = fgetname(stdio, buf);
4906 if (exported) PerlIO_releaseFILE(f,stdio);
4911 PERL_UNUSED_ARG(buf);
4912 Perl_croak_nocontext("Don't know how to get file name");
4918 /*--------------------------------------------------------------------------------------*/
4920 * Functions which can be called on any kind of PerlIO implemented in
4924 #undef PerlIO_fdopen
4926 PerlIO_fdopen(int fd, const char *mode)
4929 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4934 PerlIO_open(const char *path, const char *mode)
4937 SV *name = sv_2mortal(newSVpv(path, 0));
4938 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4941 #undef Perlio_reopen
4943 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4946 SV *name = sv_2mortal(newSVpv(path,0));
4947 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4952 PerlIO_getc(PerlIO *f)
4956 if ( 1 == PerlIO_read(f, buf, 1) ) {
4957 return (unsigned char) buf[0];
4962 #undef PerlIO_ungetc
4964 PerlIO_ungetc(PerlIO *f, int ch)
4969 if (PerlIO_unread(f, &buf, 1) == 1)
4977 PerlIO_putc(PerlIO *f, int ch)
4981 return PerlIO_write(f, &buf, 1);
4986 PerlIO_puts(PerlIO *f, const char *s)
4989 return PerlIO_write(f, s, strlen(s));
4992 #undef PerlIO_rewind
4994 PerlIO_rewind(PerlIO *f)
4997 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5001 #undef PerlIO_vprintf
5003 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5012 Perl_va_copy(ap, apc);
5013 sv = vnewSVpvf(fmt, &apc);
5016 sv = vnewSVpvf(fmt, &ap);
5018 s = SvPV_const(sv, len);
5019 wrote = PerlIO_write(f, s, len);
5024 #undef PerlIO_printf
5026 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5031 result = PerlIO_vprintf(f, fmt, ap);
5036 #undef PerlIO_stdoutf
5038 PerlIO_stdoutf(const char *fmt, ...)
5044 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5049 #undef PerlIO_tmpfile
5051 PerlIO_tmpfile(void)
5058 const int fd = win32_tmpfd();
5060 f = PerlIO_fdopen(fd, "w+b");
5062 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5064 char tempname[] = "/tmp/PerlIO_XXXXXX";
5065 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5067 int old_umask = umask(0177);
5069 * I have no idea how portable mkstemp() is ... NI-S
5071 if (tmpdir && *tmpdir) {
5072 /* if TMPDIR is set and not empty, we try that first */
5073 sv = newSVpv(tmpdir, 0);
5074 sv_catpv(sv, tempname + 4);
5075 fd = mkstemp(SvPVX(sv));
5080 /* else we try /tmp */
5081 fd = mkstemp(tempname);
5086 sv_catpv(sv, tempname + 4);
5087 fd = mkstemp(SvPVX(sv));
5091 f = PerlIO_fdopen(fd, "w+");
5093 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5094 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5097 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5098 FILE * const stdio = PerlSIO_tmpfile();
5101 f = PerlIO_fdopen(fileno(stdio), "w+");
5103 # endif /* else HAS_MKSTEMP */
5104 #endif /* else WIN32 */
5109 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5111 PERL_UNUSED_CONTEXT;
5112 if (!PerlIOValid(f))
5114 PerlIOBase(f)->err = errno;
5116 PerlIOBase(f)->os_err = vaxc$errno;
5118 PerlIOBase(f)->os_err = Perl_rc;
5119 #elif defined(WIN32)
5120 PerlIOBase(f)->os_err = GetLastError();
5125 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5127 PERL_UNUSED_CONTEXT;
5128 if (!PerlIOValid(f))
5130 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5132 Perl_rc = PerlIOBase(f)->os_err);
5133 #elif defined(WIN32)
5134 SetLastError(PerlIOBase(f)->os_err);
5142 /*======================================================================================*/
5144 * Now some functions in terms of above which may be needed even if we are
5145 * not in true PerlIO mode
5148 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5150 const char *direction = NULL;
5153 * Need to supply default layer info from open.pm
5159 if (mode && mode[0] != 'r') {
5160 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5161 direction = "open>";
5163 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5164 direction = "open<";
5169 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5172 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5177 #undef PerlIO_setpos
5179 PerlIO_setpos(PerlIO *f, SV *pos)
5185 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5186 if(len == sizeof(Off_t))
5187 return PerlIO_seek(f, *posn, SEEK_SET);
5190 SETERRNO(EINVAL, SS_IVCHAN);
5194 #undef PerlIO_setpos
5196 PerlIO_setpos(PerlIO *f, SV *pos)
5202 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5203 if(len == sizeof(Fpos_t))
5204 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5205 return fsetpos64(f, fpos);
5207 return fsetpos(f, fpos);
5211 SETERRNO(EINVAL, SS_IVCHAN);
5217 #undef PerlIO_getpos
5219 PerlIO_getpos(PerlIO *f, SV *pos)
5222 Off_t posn = PerlIO_tell(f);
5223 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5224 return (posn == (Off_t) - 1) ? -1 : 0;
5227 #undef PerlIO_getpos
5229 PerlIO_getpos(PerlIO *f, SV *pos)
5234 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5235 code = fgetpos64(f, &fpos);
5237 code = fgetpos(f, &fpos);
5239 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5244 #if !defined(HAS_VPRINTF)
5247 vprintf(char *pat, char *args)
5249 _doprnt(pat, args, stdout);
5250 return 0; /* wrong, but perl doesn't use the return
5255 vfprintf(FILE *fd, char *pat, char *args)
5257 _doprnt(pat, args, fd);
5258 return 0; /* wrong, but perl doesn't use the return
5264 /* print a failure format string message to stderr and fail exit the process
5265 using only libc without depending on any perl data structures being
5270 Perl_noperl_die(const char* pat, ...)
5273 PERL_ARGS_ASSERT_NOPERL_DIE;
5274 va_start(arglist, pat);
5275 vfprintf(stderr, pat, arglist);
5281 * ex: set ts=8 sts=4 sw=4 et: