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, ...)
354 if (!PL_perlio_debug_fd) {
356 PerlProc_getuid() == PerlProc_geteuid() &&
357 PerlProc_getgid() == PerlProc_getegid()) {
358 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
361 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
363 PL_perlio_debug_fd = -1;
365 /* tainting or set*id, so ignore the environment, and ensure we
366 skip these tests next time through. */
367 PL_perlio_debug_fd = -1;
370 if (PL_perlio_debug_fd > 0) {
372 const char * const s = CopFILE(PL_curcop);
373 /* Use fixed buffer as sv_catpvf etc. needs SVs */
375 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
376 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
377 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
379 const char *s = CopFILE(PL_curcop);
381 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
382 (IV) CopLINE(PL_curcop));
383 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
385 s = SvPV_const(sv, len);
386 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
393 /*--------------------------------------------------------------------------------------*/
396 * Inner level routines
399 /* check that the head field of each layer points back to the head */
402 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
404 PerlIO_verify_head(pTHX_ PerlIO *f)
408 #ifndef PERL_IMPLICIT_SYS
413 p = head = PerlIOBase(f)->head;
416 assert(p->head == head);
417 if (p == (PerlIOl*)f)
424 # define VERIFY_HEAD(f)
429 * Table of pointers to the PerlIO structs (malloc'ed)
431 #define PERLIO_TABLE_SIZE 64
434 PerlIO_init_table(pTHX)
438 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
444 PerlIO_allocate(pTHX)
447 * Find a free slot in the table, allocating new table as necessary
452 while ((f = *last)) {
454 last = (PerlIOl **) (f);
455 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
456 if (!((++f)->next)) {
461 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
465 *last = (PerlIOl*) f++;
468 f->flags = 0; /* lockcnt */
474 #undef PerlIO_fdupopen
476 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
478 if (PerlIOValid(f)) {
479 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
480 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
482 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
484 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
488 SETERRNO(EBADF, SS_IVCHAN);
494 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
496 PerlIOl * const table = *tablep;
499 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
500 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
501 PerlIOl * const f = table + i;
503 PerlIO_close(&(f->next));
513 PerlIO_list_alloc(pTHX)
517 Newxz(list, 1, PerlIO_list_t);
523 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
526 if (--list->refcnt == 0) {
529 for (i = 0; i < list->cur; i++)
530 SvREFCNT_dec(list->array[i].arg);
531 Safefree(list->array);
539 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
544 if (list->cur >= list->len) {
547 Renew(list->array, list->len, PerlIO_pair_t);
549 Newx(list->array, list->len, PerlIO_pair_t);
551 p = &(list->array[list->cur++]);
553 if ((p->arg = arg)) {
554 SvREFCNT_inc_simple_void_NN(arg);
559 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
561 PerlIO_list_t *list = NULL;
564 list = PerlIO_list_alloc(aTHX);
565 for (i=0; i < proto->cur; i++) {
566 SV *arg = proto->array[i].arg;
569 arg = sv_dup(arg, param);
571 PERL_UNUSED_ARG(param);
573 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
580 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
583 PerlIOl **table = &proto->Iperlio;
586 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
587 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
588 PerlIO_init_table(aTHX);
589 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
590 while ((f = *table)) {
592 table = (PerlIOl **) (f++);
593 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
595 (void) fp_dup(&(f->next), 0, param);
602 PERL_UNUSED_ARG(proto);
603 PERL_UNUSED_ARG(param);
608 PerlIO_destruct(pTHX)
610 PerlIOl **table = &PL_perlio;
613 PerlIO_debug("Destruct %p\n",(void*)aTHX);
615 while ((f = *table)) {
617 table = (PerlIOl **) (f++);
618 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
619 PerlIO *x = &(f->next);
622 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
623 PerlIO_debug("Destruct popping %s\n", l->tab->name);
637 PerlIO_pop(pTHX_ PerlIO *f)
639 const PerlIOl *l = *f;
642 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
643 l->tab ? l->tab->name : "(Null)");
644 if (l->tab && l->tab->Popped) {
646 * If popped returns non-zero do not free its layer structure
647 * it has either done so itself, or it is shared and still in
650 if ((*l->tab->Popped) (aTHX_ f) != 0)
653 if (PerlIO_lockcnt(f)) {
654 /* we're in use; defer freeing the structure */
655 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
656 PerlIOBase(f)->tab = NULL;
666 /* Return as an array the stack of layers on a filehandle. Note that
667 * the stack is returned top-first in the array, and there are three
668 * times as many array elements as there are layers in the stack: the
669 * first element of a layer triplet is the name, the second one is the
670 * arguments, and the third one is the flags. */
673 PerlIO_get_layers(pTHX_ PerlIO *f)
675 AV * const av = newAV();
677 if (PerlIOValid(f)) {
678 PerlIOl *l = PerlIOBase(f);
681 /* There is some collusion in the implementation of
682 XS_PerlIO_get_layers - it knows that name and flags are
683 generated as fresh SVs here, and takes advantage of that to
684 "copy" them by taking a reference. If it changes here, it needs
685 to change there too. */
686 SV * const name = l->tab && l->tab->name ?
687 newSVpv(l->tab->name, 0) : &PL_sv_undef;
688 SV * const arg = l->tab && l->tab->Getarg ?
689 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
692 av_push(av, newSViv((IV)l->flags));
700 /*--------------------------------------------------------------------------------------*/
702 * XS Interface for perl code
706 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
710 if ((SSize_t) len <= 0)
712 for (i = 0; i < PL_known_layers->cur; i++) {
713 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
714 const STRLEN this_len = strlen(f->name);
715 if (this_len == len && memEQ(f->name, name, len)) {
716 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
720 if (load && PL_subname && PL_def_layerlist
721 && PL_def_layerlist->cur >= 2) {
722 if (PL_in_load_module) {
723 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
726 SV * const pkgsv = newSVpvs("PerlIO");
727 SV * const layer = newSVpvn(name, len);
728 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
730 SAVEBOOL(PL_in_load_module);
732 SAVEGENERICSV(PL_warnhook);
733 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
735 PL_in_load_module = TRUE;
737 * The two SVs are magically freed by load_module
739 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
741 return PerlIO_find_layer(aTHX_ name, len, 0);
744 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
748 #ifdef USE_ATTRIBUTES_FOR_PERLIO
751 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
754 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
755 PerlIO * const ifp = IoIFP(io);
756 PerlIO * const ofp = IoOFP(io);
757 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
758 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
764 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
767 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
768 PerlIO * const ifp = IoIFP(io);
769 PerlIO * const ofp = IoOFP(io);
770 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
771 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
777 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
779 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
784 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
786 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
790 MGVTBL perlio_vtab = {
798 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
799 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
802 SV * const sv = SvRV(ST(1));
803 AV * const av = newAV();
807 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
809 mg = mg_find(sv, PERL_MAGIC_ext);
810 mg->mg_virtual = &perlio_vtab;
812 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
813 for (i = 2; i < items; i++) {
815 const char * const name = SvPV_const(ST(i), len);
816 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
818 av_push(av, SvREFCNT_inc_simple_NN(layer));
829 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
832 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
834 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
835 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
839 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
840 XS(XS_PerlIO__Layer__NoWarnings)
842 /* This is used as a %SIG{__WARN__} handler to suppress warnings
843 during loading of layers.
848 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
852 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
853 XS(XS_PerlIO__Layer__find)
858 Perl_croak(aTHX_ "Usage class->find(name[,load])");
861 const char * const name = SvPV_const(ST(1), len);
862 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
863 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
865 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
872 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
874 if (!PL_known_layers)
875 PL_known_layers = PerlIO_list_alloc(aTHX);
876 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
877 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
881 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
884 const char *s = names;
886 while (isSPACE(*s) || *s == ':')
891 const char *as = NULL;
893 if (!isIDFIRST(*s)) {
895 * Message is consistent with how attribute lists are
896 * passed. Even though this means "foo : : bar" is
897 * seen as an invalid separator character.
899 const char q = ((*s == '\'') ? '"' : '\'');
900 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
901 "Invalid separator character %c%c%c in PerlIO layer specification %s",
903 SETERRNO(EINVAL, LIB_INVARG);
908 } while (isWORDCHAR(*e));
924 * It's a nul terminated string, not allowed
925 * to \ the terminating null. Anything other
926 * character is passed over.
936 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
937 "Argument list not closed for PerlIO layer \"%.*s\"",
949 PerlIO_funcs * const layer =
950 PerlIO_find_layer(aTHX_ s, llen, 1);
954 arg = newSVpvn(as, alen);
955 PerlIO_list_push(aTHX_ av, layer,
956 (arg) ? arg : &PL_sv_undef);
960 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
973 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
975 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
976 #ifdef PERLIO_USING_CRLF
979 if (PerlIO_stdio.Set_ptrcnt)
982 PerlIO_debug("Pushing %s\n", tab->name);
983 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
987 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
989 return av->array[n].arg;
993 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
995 if (n >= 0 && n < av->cur) {
996 PerlIO_debug("Layer %" IVdf " is %s\n", n,
997 av->array[n].funcs->name);
998 return av->array[n].funcs;
1001 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1006 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1008 PERL_UNUSED_ARG(mode);
1009 PERL_UNUSED_ARG(arg);
1010 PERL_UNUSED_ARG(tab);
1011 if (PerlIOValid(f)) {
1013 PerlIO_pop(aTHX_ f);
1019 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1020 sizeof(PerlIO_funcs),
1023 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1043 NULL, /* get_base */
1044 NULL, /* get_bufsiz */
1047 NULL, /* set_ptrcnt */
1051 PerlIO_default_layers(pTHX)
1053 if (!PL_def_layerlist) {
1054 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1055 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1056 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1057 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1059 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1061 osLayer = &PerlIO_win32;
1064 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1065 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1067 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1068 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1069 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1070 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1071 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1074 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1077 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1080 if (PL_def_layerlist->cur < 2) {
1081 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1083 return PL_def_layerlist;
1087 Perl_boot_core_PerlIO(pTHX)
1089 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1090 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1093 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1094 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1098 PerlIO_default_layer(pTHX_ I32 n)
1100 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1103 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1106 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1107 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1110 PerlIO_stdstreams(pTHX)
1113 PerlIO_init_table(aTHX);
1114 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1115 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1116 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1121 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1124 if (tab->fsize != sizeof(PerlIO_funcs)) {
1126 "%s (%"UVuf") does not match %s (%"UVuf")",
1127 "PerlIO layer function table size", (UV)tab->fsize,
1128 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1132 if (tab->size < sizeof(PerlIOl)) {
1134 "%s (%"UVuf") smaller than %s (%"UVuf")",
1135 "PerlIO layer instance size", (UV)tab->size,
1136 "size expected by this perl", (UV)sizeof(PerlIOl) );
1138 /* Real layer with a data area */
1141 Newxz(temp, tab->size, char);
1145 l->tab = (PerlIO_funcs*) tab;
1146 l->head = ((PerlIOl*)f)->head;
1148 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1149 (void*)f, tab->name,
1150 (mode) ? mode : "(Null)", (void*)arg);
1151 if (*l->tab->Pushed &&
1153 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1154 PerlIO_pop(aTHX_ f);
1163 /* Pseudo-layer where push does its own stack adjust */
1164 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1165 (mode) ? mode : "(Null)", (void*)arg);
1167 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1175 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1176 IV n, const char *mode, int fd, int imode, int perm,
1177 PerlIO *old, int narg, SV **args)
1179 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1180 if (tab && tab->Open) {
1181 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1182 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1188 SETERRNO(EINVAL, LIB_INVARG);
1193 PerlIOBase_binmode(pTHX_ PerlIO *f)
1195 if (PerlIOValid(f)) {
1196 /* Is layer suitable for raw stream ? */
1197 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1198 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1199 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1202 /* Not suitable - pop it */
1203 PerlIO_pop(aTHX_ f);
1211 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1213 PERL_UNUSED_ARG(mode);
1214 PERL_UNUSED_ARG(arg);
1215 PERL_UNUSED_ARG(tab);
1217 if (PerlIOValid(f)) {
1222 * Strip all layers that are not suitable for a raw stream
1225 while (t && (l = *t)) {
1226 if (l->tab && l->tab->Binmode) {
1227 /* Has a handler - normal case */
1228 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1230 /* Layer still there - move down a layer */
1239 /* No handler - pop it */
1240 PerlIO_pop(aTHX_ t);
1243 if (PerlIOValid(f)) {
1244 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1245 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1253 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1254 PerlIO_list_t *layers, IV n, IV max)
1258 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1260 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1271 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1275 save_scalar(PL_errgv);
1277 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1278 code = PerlIO_parse_layers(aTHX_ layers, names);
1280 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1282 PerlIO_list_free(aTHX_ layers);
1289 /*--------------------------------------------------------------------------------------*/
1291 * Given the abstraction above the public API functions
1295 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1297 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1298 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1299 PerlIOBase(f)->tab->name : "(Null)",
1300 iotype, mode, (names) ? names : "(Null)");
1303 /* Do not flush etc. if (e.g.) switching encodings.
1304 if a pushed layer knows it needs to flush lower layers
1305 (for example :unix which is never going to call them)
1306 it can do the flush when it is pushed.
1308 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1311 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1312 #ifdef PERLIO_USING_CRLF
1313 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1314 O_BINARY so we can look for it in mode.
1316 if (!(mode & O_BINARY)) {
1318 /* FIXME?: Looking down the layer stack seems wrong,
1319 but is a way of reaching past (say) an encoding layer
1320 to flip CRLF-ness of the layer(s) below
1323 /* Perhaps we should turn on bottom-most aware layer
1324 e.g. Ilya's idea that UNIX TTY could serve
1326 if (PerlIOBase(f)->tab &&
1327 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1329 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1330 /* Not in text mode - flush any pending stuff and flip it */
1332 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1334 /* Only need to turn it on in one layer so we are done */
1339 /* Not finding a CRLF aware layer presumably means we are binary
1340 which is not what was requested - so we failed
1341 We _could_ push :crlf layer but so could caller
1346 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1347 So code that used to be here is now in PerlIORaw_pushed().
1349 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1354 PerlIO__close(pTHX_ PerlIO *f)
1356 if (PerlIOValid(f)) {
1357 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1358 if (tab && tab->Close)
1359 return (*tab->Close)(aTHX_ f);
1361 return PerlIOBase_close(aTHX_ f);
1364 SETERRNO(EBADF, SS_IVCHAN);
1370 Perl_PerlIO_close(pTHX_ PerlIO *f)
1372 const int code = PerlIO__close(aTHX_ f);
1373 while (PerlIOValid(f)) {
1374 PerlIO_pop(aTHX_ f);
1375 if (PerlIO_lockcnt(f))
1376 /* we're in use; the 'pop' deferred freeing the structure */
1383 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1385 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1389 static PerlIO_funcs *
1390 PerlIO_layer_from_ref(pTHX_ SV *sv)
1393 * For any scalar type load the handler which is bundled with perl
1395 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1396 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1397 /* This isn't supposed to happen, since PerlIO::scalar is core,
1398 * but could happen anyway in smaller installs or with PAR */
1400 /* diag_listed_as: Unknown PerlIO layer "%s" */
1401 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1406 * For other types allow if layer is known but don't try and load it
1408 switch (SvTYPE(sv)) {
1410 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1412 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1414 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1416 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1423 PerlIO_resolve_layers(pTHX_ const char *layers,
1424 const char *mode, int narg, SV **args)
1426 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1429 PerlIO_stdstreams(aTHX);
1431 SV * const arg = *args;
1433 * If it is a reference but not an object see if we have a handler
1436 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1437 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1439 def = PerlIO_list_alloc(aTHX);
1440 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1444 * Don't fail if handler cannot be found :via(...) etc. may do
1445 * something sensible else we will just stringfy and open
1450 if (!layers || !*layers)
1451 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1452 if (layers && *layers) {
1455 av = PerlIO_clone_list(aTHX_ def, NULL);
1460 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1464 PerlIO_list_free(aTHX_ av);
1476 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1477 int imode, int perm, PerlIO *f, int narg, SV **args)
1479 if (!f && narg == 1 && *args == &PL_sv_undef) {
1480 if ((f = PerlIO_tmpfile())) {
1481 if (!layers || !*layers)
1482 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1483 if (layers && *layers)
1484 PerlIO_apply_layers(aTHX_ f, mode, layers);
1488 PerlIO_list_t *layera;
1490 PerlIO_funcs *tab = NULL;
1491 if (PerlIOValid(f)) {
1493 * This is "reopen" - it is not tested as perl does not use it
1497 layera = PerlIO_list_alloc(aTHX);
1500 if (l->tab && l->tab->Getarg)
1501 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1502 PerlIO_list_push(aTHX_ layera, l->tab,
1503 (arg) ? arg : &PL_sv_undef);
1505 l = *PerlIONext(&l);
1509 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1515 * Start at "top" of layer stack
1517 n = layera->cur - 1;
1519 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1528 * Found that layer 'n' can do opens - call it
1530 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1531 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1533 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1534 tab->name, layers ? layers : "(Null)", mode, fd,
1535 imode, perm, (void*)f, narg, (void*)args);
1537 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1540 SETERRNO(EINVAL, LIB_INVARG);
1544 if (n + 1 < layera->cur) {
1546 * More layers above the one that we used to open -
1549 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1550 /* If pushing layers fails close the file */
1557 PerlIO_list_free(aTHX_ layera);
1564 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1566 PERL_ARGS_ASSERT_PERLIO_READ;
1568 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1572 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1574 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1576 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1580 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1582 PERL_ARGS_ASSERT_PERLIO_WRITE;
1584 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1588 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1590 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1594 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1596 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1600 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1604 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1606 if (tab && tab->Flush)
1607 return (*tab->Flush) (aTHX_ f);
1609 return 0; /* If no Flush defined, silently succeed. */
1612 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1613 SETERRNO(EBADF, SS_IVCHAN);
1619 * Is it good API design to do flush-all on NULL, a potentially
1620 * erroneous input? Maybe some magical value (PerlIO*
1621 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1622 * things on fflush(NULL), but should we be bound by their design
1625 PerlIOl **table = &PL_perlio;
1628 while ((ff = *table)) {
1630 table = (PerlIOl **) (ff++);
1631 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1632 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1642 PerlIOBase_flush_linebuf(pTHX)
1644 PerlIOl **table = &PL_perlio;
1646 while ((f = *table)) {
1648 table = (PerlIOl **) (f++);
1649 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1651 && (PerlIOBase(&(f->next))->
1652 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1653 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1654 PerlIO_flush(&(f->next));
1661 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1663 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1667 PerlIO_isutf8(PerlIO *f)
1670 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1672 SETERRNO(EBADF, SS_IVCHAN);
1678 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1680 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1684 Perl_PerlIO_error(pTHX_ PerlIO *f)
1686 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1690 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1692 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1696 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1698 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1702 PerlIO_has_base(PerlIO *f)
1704 if (PerlIOValid(f)) {
1705 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1708 return (tab->Get_base != NULL);
1715 PerlIO_fast_gets(PerlIO *f)
1717 if (PerlIOValid(f)) {
1718 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1719 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1722 return (tab->Set_ptrcnt != NULL);
1730 PerlIO_has_cntptr(PerlIO *f)
1732 if (PerlIOValid(f)) {
1733 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1736 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1743 PerlIO_canset_cnt(PerlIO *f)
1745 if (PerlIOValid(f)) {
1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1749 return (tab->Set_ptrcnt != NULL);
1756 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1758 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1762 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1764 /* Note that Get_bufsiz returns a Size_t */
1765 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1769 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1771 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1775 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1777 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1781 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1783 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1787 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1789 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1793 /*--------------------------------------------------------------------------------------*/
1795 * utf8 and raw dummy layers
1799 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1801 PERL_UNUSED_CONTEXT;
1802 PERL_UNUSED_ARG(mode);
1803 PERL_UNUSED_ARG(arg);
1804 if (PerlIOValid(f)) {
1805 if (tab && tab->kind & PERLIO_K_UTF8)
1806 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1808 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1814 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1815 sizeof(PerlIO_funcs),
1818 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1838 NULL, /* get_base */
1839 NULL, /* get_bufsiz */
1842 NULL, /* set_ptrcnt */
1845 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1846 sizeof(PerlIO_funcs),
1849 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1869 NULL, /* get_base */
1870 NULL, /* get_bufsiz */
1873 NULL, /* set_ptrcnt */
1876 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1877 sizeof(PerlIO_funcs),
1900 NULL, /* get_base */
1901 NULL, /* get_bufsiz */
1904 NULL, /* set_ptrcnt */
1906 /*--------------------------------------------------------------------------------------*/
1907 /*--------------------------------------------------------------------------------------*/
1909 * "Methods" of the "base class"
1913 PerlIOBase_fileno(pTHX_ PerlIO *f)
1915 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1919 PerlIO_modestr(PerlIO * f, char *buf)
1922 if (PerlIOValid(f)) {
1923 const IV flags = PerlIOBase(f)->flags;
1924 if (flags & PERLIO_F_APPEND) {
1926 if (flags & PERLIO_F_CANREAD) {
1930 else if (flags & PERLIO_F_CANREAD) {
1932 if (flags & PERLIO_F_CANWRITE)
1935 else if (flags & PERLIO_F_CANWRITE) {
1937 if (flags & PERLIO_F_CANREAD) {
1941 #ifdef PERLIO_USING_CRLF
1942 if (!(flags & PERLIO_F_CRLF))
1952 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1954 PerlIOl * const l = PerlIOBase(f);
1955 PERL_UNUSED_CONTEXT;
1956 PERL_UNUSED_ARG(arg);
1958 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1959 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1960 if (tab && tab->Set_ptrcnt != NULL)
1961 l->flags |= PERLIO_F_FASTGETS;
1963 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1967 l->flags |= PERLIO_F_CANREAD;
1970 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1973 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1976 SETERRNO(EINVAL, LIB_INVARG);
1982 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1985 l->flags &= ~PERLIO_F_CRLF;
1988 l->flags |= PERLIO_F_CRLF;
1991 SETERRNO(EINVAL, LIB_INVARG);
1998 l->flags |= l->next->flags &
1999 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2004 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2005 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2006 l->flags, PerlIO_modestr(f, temp));
2012 PerlIOBase_popped(pTHX_ PerlIO *f)
2014 PERL_UNUSED_CONTEXT;
2020 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2023 * Save the position as current head considers it
2025 const Off_t old = PerlIO_tell(f);
2026 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2027 PerlIOSelf(f, PerlIOBuf)->posn = old;
2028 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2032 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2034 STDCHAR *buf = (STDCHAR *) vbuf;
2036 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2037 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2038 SETERRNO(EBADF, SS_IVCHAN);
2039 PerlIO_save_errno(f);
2045 SSize_t avail = PerlIO_get_cnt(f);
2048 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2050 STDCHAR *ptr = PerlIO_get_ptr(f);
2051 Copy(ptr, buf, take, STDCHAR);
2052 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2055 if (avail == 0) /* set_ptrcnt could have reset avail */
2058 if (count > 0 && avail <= 0) {
2059 if (PerlIO_fill(f) != 0)
2064 return (buf - (STDCHAR *) vbuf);
2070 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2072 PERL_UNUSED_CONTEXT;
2078 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2080 PERL_UNUSED_CONTEXT;
2086 PerlIOBase_close(pTHX_ PerlIO *f)
2089 if (PerlIOValid(f)) {
2090 PerlIO *n = PerlIONext(f);
2091 code = PerlIO_flush(f);
2092 PerlIOBase(f)->flags &=
2093 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2094 while (PerlIOValid(n)) {
2095 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2096 if (tab && tab->Close) {
2097 if ((*tab->Close)(aTHX_ n) != 0)
2102 PerlIOBase(n)->flags &=
2103 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2109 SETERRNO(EBADF, SS_IVCHAN);
2115 PerlIOBase_eof(pTHX_ PerlIO *f)
2117 PERL_UNUSED_CONTEXT;
2118 if (PerlIOValid(f)) {
2119 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2125 PerlIOBase_error(pTHX_ PerlIO *f)
2127 PERL_UNUSED_CONTEXT;
2128 if (PerlIOValid(f)) {
2129 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2135 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2137 if (PerlIOValid(f)) {
2138 PerlIO * const n = PerlIONext(f);
2139 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2146 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2148 PERL_UNUSED_CONTEXT;
2149 if (PerlIOValid(f)) {
2150 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2155 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2161 arg = sv_dup(arg, param);
2162 SvREFCNT_inc_simple_void_NN(arg);
2166 return newSVsv(arg);
2169 PERL_UNUSED_ARG(param);
2170 return newSVsv(arg);
2175 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2177 PerlIO * const nexto = PerlIONext(o);
2178 if (PerlIOValid(nexto)) {
2179 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2180 if (tab && tab->Dup)
2181 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2183 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2186 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2190 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2192 (void*)f, (void*)o, (void*)param);
2194 arg = (*self->Getarg)(aTHX_ o, param, flags);
2195 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2196 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2197 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2203 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2205 /* Must be called with PL_perlio_mutex locked. */
2207 S_more_refcounted_fds(pTHX_ const int new_fd) {
2209 const int old_max = PL_perlio_fd_refcnt_size;
2210 const int new_max = 16 + (new_fd & ~15);
2213 #ifndef PERL_IMPLICIT_SYS
2214 PERL_UNUSED_CONTEXT;
2217 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2218 old_max, new_fd, new_max);
2220 if (new_fd < old_max) {
2224 assert (new_max > new_fd);
2226 /* Use plain realloc() since we need this memory to be really
2227 * global and visible to all the interpreters and/or threads. */
2228 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2232 MUTEX_UNLOCK(&PL_perlio_mutex);
2237 PL_perlio_fd_refcnt_size = new_max;
2238 PL_perlio_fd_refcnt = new_array;
2240 PerlIO_debug("Zeroing %p, %d\n",
2241 (void*)(new_array + old_max),
2244 Zero(new_array + old_max, new_max - old_max, int);
2251 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2252 PERL_UNUSED_CONTEXT;
2256 PerlIOUnix_refcnt_inc(int fd)
2263 MUTEX_LOCK(&PL_perlio_mutex);
2265 if (fd >= PL_perlio_fd_refcnt_size)
2266 S_more_refcounted_fds(aTHX_ fd);
2268 PL_perlio_fd_refcnt[fd]++;
2269 if (PL_perlio_fd_refcnt[fd] <= 0) {
2270 /* diag_listed_as: refcnt_inc: fd %d%s */
2271 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2272 fd, PL_perlio_fd_refcnt[fd]);
2274 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2275 fd, PL_perlio_fd_refcnt[fd]);
2278 MUTEX_UNLOCK(&PL_perlio_mutex);
2281 /* diag_listed_as: refcnt_inc: fd %d%s */
2282 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2287 PerlIOUnix_refcnt_dec(int fd)
2293 MUTEX_LOCK(&PL_perlio_mutex);
2295 if (fd >= PL_perlio_fd_refcnt_size) {
2296 /* diag_listed_as: refcnt_dec: fd %d%s */
2297 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2298 fd, PL_perlio_fd_refcnt_size);
2300 if (PL_perlio_fd_refcnt[fd] <= 0) {
2301 /* diag_listed_as: refcnt_dec: fd %d%s */
2302 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2303 fd, PL_perlio_fd_refcnt[fd]);
2305 cnt = --PL_perlio_fd_refcnt[fd];
2306 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2308 MUTEX_UNLOCK(&PL_perlio_mutex);
2311 /* diag_listed_as: refcnt_dec: fd %d%s */
2312 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2318 PerlIOUnix_refcnt(int fd)
2325 MUTEX_LOCK(&PL_perlio_mutex);
2327 if (fd >= PL_perlio_fd_refcnt_size) {
2328 /* diag_listed_as: refcnt: fd %d%s */
2329 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2330 fd, PL_perlio_fd_refcnt_size);
2332 if (PL_perlio_fd_refcnt[fd] <= 0) {
2333 /* diag_listed_as: refcnt: fd %d%s */
2334 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2335 fd, PL_perlio_fd_refcnt[fd]);
2337 cnt = PL_perlio_fd_refcnt[fd];
2339 MUTEX_UNLOCK(&PL_perlio_mutex);
2342 /* diag_listed_as: refcnt: fd %d%s */
2343 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2349 PerlIO_cleanup(pTHX)
2353 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2355 PerlIO_debug("Cleanup layers\n");
2358 /* Raise STDIN..STDERR refcount so we don't close them */
2359 for (i=0; i < 3; i++)
2360 PerlIOUnix_refcnt_inc(i);
2361 PerlIO_cleantable(aTHX_ &PL_perlio);
2362 /* Restore STDIN..STDERR refcount */
2363 for (i=0; i < 3; i++)
2364 PerlIOUnix_refcnt_dec(i);
2366 if (PL_known_layers) {
2367 PerlIO_list_free(aTHX_ PL_known_layers);
2368 PL_known_layers = NULL;
2370 if (PL_def_layerlist) {
2371 PerlIO_list_free(aTHX_ PL_def_layerlist);
2372 PL_def_layerlist = NULL;
2376 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2380 /* XXX we can't rely on an interpreter being present at this late stage,
2381 XXX so we can't use a function like PerlLIO_write that relies on one
2382 being present (at least in win32) :-(.
2387 /* By now all filehandles should have been closed, so any
2388 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2390 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2391 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2392 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2394 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2395 if (PL_perlio_fd_refcnt[i]) {
2397 my_snprintf(buf, sizeof(buf),
2398 "PerlIO_teardown: fd %d refcnt=%d\n",
2399 i, PL_perlio_fd_refcnt[i]);
2400 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2406 /* Not bothering with PL_perlio_mutex since by now
2407 * all the interpreters are gone. */
2408 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2409 && PL_perlio_fd_refcnt) {
2410 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2411 PL_perlio_fd_refcnt = NULL;
2412 PL_perlio_fd_refcnt_size = 0;
2416 /*--------------------------------------------------------------------------------------*/
2418 * Bottom-most level for UNIX-like case
2422 struct _PerlIO base; /* The generic part */
2423 int fd; /* UNIX like file descriptor */
2424 int oflags; /* open/fcntl flags */
2428 S_lockcnt_dec(pTHX_ const void* f)
2430 #ifndef PERL_IMPLICIT_SYS
2431 PERL_UNUSED_CONTEXT;
2433 PerlIO_lockcnt((PerlIO*)f)--;
2437 /* call the signal handler, and if that handler happens to clear
2438 * this handle, free what we can and return true */
2441 S_perlio_async_run(pTHX_ PerlIO* f) {
2443 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2444 PerlIO_lockcnt(f)++;
2446 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2450 /* we've just run some perl-level code that could have done
2451 * anything, including closing the file or clearing this layer.
2452 * If so, free any lower layers that have already been
2453 * cleared, then return an error. */
2454 while (PerlIOValid(f) &&
2455 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2457 const PerlIOl *l = *f;
2466 PerlIOUnix_oflags(const char *mode)
2469 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2474 if (*++mode == '+') {
2481 oflags = O_CREAT | O_TRUNC;
2482 if (*++mode == '+') {
2491 oflags = O_CREAT | O_APPEND;
2492 if (*++mode == '+') {
2501 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2503 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2504 * of them in, and then bit-and-masking the other them away, won't
2505 * have much of an effect. */
2508 #if O_TEXT != O_BINARY
2515 #if O_TEXT != O_BINARY
2517 oflags &= ~O_BINARY;
2523 /* bit-or:ing with zero O_BINARY would be useless. */
2525 * If neither "t" nor "b" was specified, open the file
2528 * Note that if something else than the zero byte was seen
2529 * here (e.g. bogus mode "rx"), just few lines later we will
2530 * set the errno and invalidate the flags.
2536 if (*mode || oflags == -1) {
2537 SETERRNO(EINVAL, LIB_INVARG);
2544 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2546 PERL_UNUSED_CONTEXT;
2547 return PerlIOSelf(f, PerlIOUnix)->fd;
2551 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2553 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2556 if (PerlLIO_fstat(fd, &st) == 0) {
2557 if (!S_ISREG(st.st_mode)) {
2558 PerlIO_debug("%d is not regular file\n",fd);
2559 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2562 PerlIO_debug("%d _is_ a regular file\n",fd);
2568 PerlIOUnix_refcnt_inc(fd);
2569 PERL_UNUSED_CONTEXT;
2573 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2575 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2576 if (*PerlIONext(f)) {
2577 /* We never call down so do any pending stuff now */
2578 PerlIO_flush(PerlIONext(f));
2580 * XXX could (or should) we retrieve the oflags from the open file
2581 * handle rather than believing the "mode" we are passed in? XXX
2582 * Should the value on NULL mode be 0 or -1?
2584 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2585 mode ? PerlIOUnix_oflags(mode) : -1);
2587 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2593 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2595 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2597 PERL_UNUSED_CONTEXT;
2598 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2600 SETERRNO(ESPIPE, LIB_INVARG);
2602 SETERRNO(EINVAL, LIB_INVARG);
2606 new_loc = PerlLIO_lseek(fd, offset, whence);
2607 if (new_loc == (Off_t) - 1)
2609 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2614 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2615 IV n, const char *mode, int fd, int imode,
2616 int perm, PerlIO *f, int narg, SV **args)
2618 if (PerlIOValid(f)) {
2619 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2620 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2623 if (*mode == IoTYPE_NUMERIC)
2626 imode = PerlIOUnix_oflags(mode);
2628 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2635 const char *path = SvPV_const(*args, len);
2636 if (!IS_SAFE_PATHNAME(path, len, "open"))
2638 fd = PerlLIO_open3(path, imode, perm);
2642 if (*mode == IoTYPE_IMPLICIT)
2645 f = PerlIO_allocate(aTHX);
2647 if (!PerlIOValid(f)) {
2648 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2653 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2654 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2655 if (*mode == IoTYPE_APPEND)
2656 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2663 * FIXME: pop layers ???
2671 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2673 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2675 if (flags & PERLIO_DUP_FD) {
2676 fd = PerlLIO_dup(fd);
2679 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2681 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2682 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2692 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2695 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2697 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2698 #ifdef PERLIO_STD_SPECIAL
2700 return PERLIO_STD_IN(fd, vbuf, count);
2702 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2703 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2707 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2708 if (len >= 0 || errno != EINTR) {
2710 if (errno != EAGAIN) {
2711 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2712 PerlIO_save_errno(f);
2715 else if (len == 0 && count != 0) {
2716 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2722 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2725 NOT_REACHED; /*NOTREACHED*/
2729 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2732 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2734 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2735 #ifdef PERLIO_STD_SPECIAL
2736 if (fd == 1 || fd == 2)
2737 return PERLIO_STD_OUT(fd, vbuf, count);
2740 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2741 if (len >= 0 || errno != EINTR) {
2743 if (errno != EAGAIN) {
2744 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2745 PerlIO_save_errno(f);
2751 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2754 NOT_REACHED; /*NOTREACHED*/
2758 PerlIOUnix_tell(pTHX_ PerlIO *f)
2760 PERL_UNUSED_CONTEXT;
2762 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2767 PerlIOUnix_close(pTHX_ PerlIO *f)
2769 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2771 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2772 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2773 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2778 SETERRNO(EBADF,SS_IVCHAN);
2781 while (PerlLIO_close(fd) != 0) {
2782 if (errno != EINTR) {
2787 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2791 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2796 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2797 sizeof(PerlIO_funcs),
2804 PerlIOBase_binmode, /* binmode */
2814 PerlIOBase_noop_ok, /* flush */
2815 PerlIOBase_noop_fail, /* fill */
2818 PerlIOBase_clearerr,
2819 PerlIOBase_setlinebuf,
2820 NULL, /* get_base */
2821 NULL, /* get_bufsiz */
2824 NULL, /* set_ptrcnt */
2827 /*--------------------------------------------------------------------------------------*/
2832 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2833 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2834 broken by the last second glibc 2.3 fix
2836 #define STDIO_BUFFER_WRITABLE
2841 struct _PerlIO base;
2842 FILE *stdio; /* The stream */
2846 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2848 PERL_UNUSED_CONTEXT;
2850 if (PerlIOValid(f)) {
2851 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2853 return PerlSIO_fileno(s);
2860 PerlIOStdio_mode(const char *mode, char *tmode)
2862 char * const ret = tmode;
2868 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2876 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2879 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2880 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2881 if (toptab == tab) {
2882 /* Top is already stdio - pop self (duplicate) and use original */
2883 PerlIO_pop(aTHX_ f);
2886 const int fd = PerlIO_fileno(n);
2889 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2890 mode = PerlIOStdio_mode(mode, tmode)))) {
2891 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2892 /* We never call down so do any pending stuff now */
2893 PerlIO_flush(PerlIONext(f));
2894 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2901 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2906 PerlIO_importFILE(FILE *stdio, const char *mode)
2912 char filename[FILENAME_MAX];
2917 int fd0 = fileno(stdio);
2920 rc = fldata(stdio,filename,&fileinfo);
2924 if(fileinfo.__dsorgHFS){
2927 /*This MVS dataset , OK!*/
2932 if (!mode || !*mode) {
2933 /* We need to probe to see how we can open the stream
2934 so start with read/write and then try write and read
2935 we dup() so that we can fclose without loosing the fd.
2937 Note that the errno value set by a failing fdopen
2938 varies between stdio implementations.
2940 const int fd = PerlLIO_dup(fd0);
2945 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2947 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2950 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2953 /* Don't seem to be able to open */
2959 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2960 s = PerlIOSelf(f, PerlIOStdio);
2963 fd0 = fileno(stdio);
2965 PerlIOUnix_refcnt_inc(fd0);
2968 rc = fldata(stdio,filename,&fileinfo);
2970 PerlIOUnix_refcnt_inc(fd0);
2972 if(fileinfo.__dsorgHFS){
2973 PerlIOUnix_refcnt_inc(fd0);
2975 /*This MVS dataset , OK!*/
2978 PerlIOUnix_refcnt_inc(fileno(stdio));
2986 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2987 IV n, const char *mode, int fd, int imode,
2988 int perm, PerlIO *f, int narg, SV **args)
2991 if (PerlIOValid(f)) {
2993 const char * const path = SvPV_const(*args, len);
2994 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2996 if (!IS_SAFE_PATHNAME(path, len, "open"))
2998 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2999 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3004 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3010 const char * const path = SvPV_const(*args, len);
3011 if (!IS_SAFE_PATHNAME(path, len, "open"))
3013 if (*mode == IoTYPE_NUMERIC) {
3015 fd = PerlLIO_open3(path, imode, perm);
3019 bool appended = FALSE;
3021 /* Cygwin wants its 'b' early. */
3023 mode = PerlIOStdio_mode(mode, tmode);
3025 stdio = PerlSIO_fopen(path, mode);
3028 f = PerlIO_allocate(aTHX);
3031 mode = PerlIOStdio_mode(mode, tmode);
3032 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3034 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3035 PerlIOUnix_refcnt_inc(fileno(stdio));
3037 PerlSIO_fclose(stdio);
3049 if (*mode == IoTYPE_IMPLICIT) {
3056 stdio = PerlSIO_stdin;
3059 stdio = PerlSIO_stdout;
3062 stdio = PerlSIO_stderr;
3067 stdio = PerlSIO_fdopen(fd, mode =
3068 PerlIOStdio_mode(mode, tmode));
3072 f = PerlIO_allocate(aTHX);
3074 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3075 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3076 PerlIOUnix_refcnt_inc(fileno(stdio));
3087 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3089 /* This assumes no layers underneath - which is what
3090 happens, but is not how I remember it. NI-S 2001/10/16
3092 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3093 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3094 const int fd = fileno(stdio);
3096 if (flags & PERLIO_DUP_FD) {
3097 const int dfd = PerlLIO_dup(fileno(stdio));
3099 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3104 /* FIXME: To avoid messy error recovery if dup fails
3105 re-use the existing stdio as though flag was not set
3109 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3111 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3113 PerlIOUnix_refcnt_inc(fileno(stdio));
3120 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3122 PERL_UNUSED_CONTEXT;
3124 /* XXX this could use PerlIO_canset_fileno() and
3125 * PerlIO_set_fileno() support from Configure
3127 # if defined(__UCLIBC__)
3128 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3131 # elif defined(__GLIBC__)
3132 /* There may be a better way for GLIBC:
3133 - libio.h defines a flag to not close() on cleanup
3137 # elif defined(__sun)
3140 # elif defined(__hpux)
3144 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3145 your platform does not have special entry try this one.
3146 [For OSF only have confirmation for Tru64 (alpha)
3147 but assume other OSFs will be similar.]
3149 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3152 # elif defined(__FreeBSD__)
3153 /* There may be a better way on FreeBSD:
3154 - we could insert a dummy func in the _close function entry
3155 f->_close = (int (*)(void *)) dummy_close;
3159 # elif defined(__OpenBSD__)
3160 /* There may be a better way on OpenBSD:
3161 - we could insert a dummy func in the _close function entry
3162 f->_close = (int (*)(void *)) dummy_close;
3166 # elif defined(__EMX__)
3167 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3170 # elif defined(__CYGWIN__)
3171 /* There may be a better way on CYGWIN:
3172 - we could insert a dummy func in the _close function entry
3173 f->_close = (int (*)(void *)) dummy_close;
3177 # elif defined(WIN32)
3178 # if defined(UNDER_CE)
3179 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3188 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3189 (which isn't thread safe) instead
3191 # error "Don't know how to set FILE.fileno on your platform"
3199 PerlIOStdio_close(pTHX_ PerlIO *f)
3201 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3207 const int fd = fileno(stdio);
3215 #ifdef SOCKS5_VERSION_NAME
3216 /* Socks lib overrides close() but stdio isn't linked to
3217 that library (though we are) - so we must call close()
3218 on sockets on stdio's behalf.
3221 Sock_size_t optlen = sizeof(int);
3222 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3225 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3226 that a subsequent fileno() on it returns -1. Don't want to croak()
3227 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3228 trying to close an already closed handle which somehow it still has
3229 a reference to. (via.xs, I'm looking at you). */
3230 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3231 /* File descriptor still in use */
3235 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3236 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3238 if (stdio == stdout || stdio == stderr)
3239 return PerlIO_flush(f);
3240 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3241 Use Sarathy's trick from maint-5.6 to invalidate the
3242 fileno slot of the FILE *
3244 result = PerlIO_flush(f);
3246 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3249 MUTEX_LOCK(&PL_perlio_mutex);
3250 /* Right. We need a mutex here because for a brief while we
3251 will have the situation that fd is actually closed. Hence if
3252 a second thread were to get into this block, its dup() would
3253 likely return our fd as its dupfd. (after all, it is closed)
3254 Then if we get to the dup2() first, we blat the fd back
3255 (messing up its temporary as a side effect) only for it to
3256 then close its dupfd (== our fd) in its close(dupfd) */
3258 /* There is, of course, a race condition, that any other thread
3259 trying to input/output/whatever on this fd will be stuffed
3260 for the duration of this little manoeuvrer. Perhaps we
3261 should hold an IO mutex for the duration of every IO
3262 operation if we know that invalidate doesn't work on this
3263 platform, but that would suck, and could kill performance.
3265 Except that correctness trumps speed.
3266 Advice from klortho #11912. */
3268 dupfd = PerlLIO_dup(fd);
3271 MUTEX_UNLOCK(&PL_perlio_mutex);
3272 /* Oh cXap. This isn't going to go well. Not sure if we can
3273 recover from here, or if closing this particular FILE *
3274 is a good idea now. */
3279 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3281 result = PerlSIO_fclose(stdio);
3282 /* We treat error from stdio as success if we invalidated
3283 errno may NOT be expected EBADF
3285 if (invalidate && result != 0) {
3289 #ifdef SOCKS5_VERSION_NAME
3290 /* in SOCKS' case, let close() determine return value */
3294 PerlLIO_dup2(dupfd,fd);
3295 PerlLIO_close(dupfd);
3297 MUTEX_UNLOCK(&PL_perlio_mutex);
3305 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3309 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3311 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3314 STDCHAR *buf = (STDCHAR *) vbuf;
3316 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3317 * stdio does not do that for fread()
3319 const int ch = PerlSIO_fgetc(s);
3326 got = PerlSIO_fread(vbuf, 1, count, s);
3327 if (got == 0 && PerlSIO_ferror(s))
3329 if (got >= 0 || errno != EINTR)
3331 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3333 SETERRNO(0,0); /* just in case */
3339 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3342 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3344 #ifdef STDIO_BUFFER_WRITABLE
3345 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3346 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3347 STDCHAR *base = PerlIO_get_base(f);
3348 SSize_t cnt = PerlIO_get_cnt(f);
3349 STDCHAR *ptr = PerlIO_get_ptr(f);
3350 SSize_t avail = ptr - base;
3352 if (avail > count) {
3356 Move(buf-avail,ptr,avail,STDCHAR);
3359 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3360 if (PerlSIO_feof(s) && unread >= 0)
3361 PerlSIO_clearerr(s);
3366 if (PerlIO_has_cntptr(f)) {
3367 /* We can get pointer to buffer but not its base
3368 Do ungetc() but check chars are ending up in the
3371 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3372 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3374 const int ch = *--buf & 0xFF;
3375 if (ungetc(ch,s) != ch) {
3376 /* ungetc did not work */
3379 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3380 /* Did not change pointer as expected */
3381 if (fgetc(s) != EOF) /* get char back again */
3391 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3397 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3400 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3403 got = PerlSIO_fwrite(vbuf, 1, count,
3404 PerlIOSelf(f, PerlIOStdio)->stdio);
3405 if (got >= 0 || errno != EINTR)
3407 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3409 SETERRNO(0,0); /* just in case */
3415 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3417 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3418 PERL_UNUSED_CONTEXT;
3420 return PerlSIO_fseek(stdio, offset, whence);
3424 PerlIOStdio_tell(pTHX_ PerlIO *f)
3426 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3427 PERL_UNUSED_CONTEXT;
3429 return PerlSIO_ftell(stdio);
3433 PerlIOStdio_flush(pTHX_ PerlIO *f)
3435 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3436 PERL_UNUSED_CONTEXT;
3438 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3439 return PerlSIO_fflush(stdio);
3445 * FIXME: This discards ungetc() and pre-read stuff which is not
3446 * right if this is just a "sync" from a layer above Suspect right
3447 * design is to do _this_ but not have layer above flush this
3448 * layer read-to-read
3451 * Not writeable - sync by attempting a seek
3454 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3462 PerlIOStdio_eof(pTHX_ PerlIO *f)
3464 PERL_UNUSED_CONTEXT;
3466 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3470 PerlIOStdio_error(pTHX_ PerlIO *f)
3472 PERL_UNUSED_CONTEXT;
3474 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3478 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3480 PERL_UNUSED_CONTEXT;
3482 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3486 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3488 PERL_UNUSED_CONTEXT;
3490 #ifdef HAS_SETLINEBUF
3491 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3493 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3499 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3501 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3502 return (STDCHAR*)PerlSIO_get_base(stdio);
3506 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3508 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3509 return PerlSIO_get_bufsiz(stdio);
3513 #ifdef USE_STDIO_PTR
3515 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3517 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3518 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3522 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3524 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3525 return PerlSIO_get_cnt(stdio);
3529 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3531 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3533 #ifdef STDIO_PTR_LVALUE
3534 /* This is a long-standing infamous mess. The root of the
3535 * problem is that one cannot know the signedness of char, and
3536 * more precisely the signedness of FILE._ptr. The following
3537 * things have been tried, and they have all failed (across
3538 * different compilers (remember that core needs to to build
3539 * also with c++) and compiler options:
3541 * - casting the RHS to (void*) -- works in *some* places
3542 * - casting the LHS to (void*) -- totally unportable
3544 * So let's try silencing the warning at least for gcc. */
3545 GCC_DIAG_IGNORE(-Wpointer-sign);
3546 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3548 #ifdef STDIO_PTR_LVAL_SETS_CNT
3549 assert(PerlSIO_get_cnt(stdio) == (cnt));
3551 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3553 * Setting ptr _does_ change cnt - we are done
3557 #else /* STDIO_PTR_LVALUE */
3559 #endif /* STDIO_PTR_LVALUE */
3562 * Now (or only) set cnt
3564 #ifdef STDIO_CNT_LVALUE
3565 PerlSIO_set_cnt(stdio, cnt);
3566 #else /* STDIO_CNT_LVALUE */
3567 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3568 PerlSIO_set_ptr(stdio,
3569 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3571 #else /* STDIO_PTR_LVAL_SETS_CNT */
3573 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3574 #endif /* STDIO_CNT_LVALUE */
3581 PerlIOStdio_fill(pTHX_ PerlIO *f)
3585 PERL_UNUSED_CONTEXT;
3586 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3588 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3591 * fflush()ing read-only streams can cause trouble on some stdio-s
3593 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3594 if (PerlSIO_fflush(stdio) != 0)
3598 c = PerlSIO_fgetc(stdio);
3601 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3603 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3608 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3610 #ifdef STDIO_BUFFER_WRITABLE
3611 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3612 /* Fake ungetc() to the real buffer in case system's ungetc
3615 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3616 SSize_t cnt = PerlSIO_get_cnt(stdio);
3617 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3618 if (ptr == base+1) {
3619 *--ptr = (STDCHAR) c;
3620 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3621 if (PerlSIO_feof(stdio))
3622 PerlSIO_clearerr(stdio);
3628 if (PerlIO_has_cntptr(f)) {
3630 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3636 /* If buffer snoop scheme above fails fall back to
3639 if (PerlSIO_ungetc(c, stdio) != c)
3647 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3648 sizeof(PerlIO_funcs),
3650 sizeof(PerlIOStdio),
3651 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3655 PerlIOBase_binmode, /* binmode */
3669 PerlIOStdio_clearerr,
3670 PerlIOStdio_setlinebuf,
3672 PerlIOStdio_get_base,
3673 PerlIOStdio_get_bufsiz,
3678 #ifdef USE_STDIO_PTR
3679 PerlIOStdio_get_ptr,
3680 PerlIOStdio_get_cnt,
3681 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3682 PerlIOStdio_set_ptrcnt,
3685 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3690 #endif /* USE_STDIO_PTR */
3693 /* Note that calls to PerlIO_exportFILE() are reversed using
3694 * PerlIO_releaseFILE(), not importFILE. */
3696 PerlIO_exportFILE(PerlIO * f, const char *mode)
3700 if (PerlIOValid(f)) {
3702 int fd = PerlIO_fileno(f);
3707 if (!mode || !*mode) {
3708 mode = PerlIO_modestr(f, buf);
3710 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3714 /* De-link any lower layers so new :stdio sticks */
3716 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3717 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3719 PerlIOUnix_refcnt_inc(fileno(stdio));
3720 /* Link previous lower layers under new one */
3724 /* restore layers list */
3734 PerlIO_findFILE(PerlIO *f)
3739 if (l->tab == &PerlIO_stdio) {
3740 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3743 l = *PerlIONext(&l);
3745 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3746 /* However, we're not really exporting a FILE * to someone else (who
3747 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3748 So we need to undo its reference count increase on the underlying file
3749 descriptor. We have to do this, because if the loop above returns you
3750 the FILE *, then *it* didn't increase any reference count. So there's
3751 only one way to be consistent. */
3752 stdio = PerlIO_exportFILE(f, NULL);
3754 const int fd = fileno(stdio);
3756 PerlIOUnix_refcnt_dec(fd);
3761 /* Use this to reverse PerlIO_exportFILE calls. */
3763 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3767 if (l->tab == &PerlIO_stdio) {
3768 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3769 if (s->stdio == f) { /* not in a loop */
3770 const int fd = fileno(f);
3772 PerlIOUnix_refcnt_dec(fd);
3775 PerlIO_pop(aTHX_ p);
3785 /*--------------------------------------------------------------------------------------*/
3787 * perlio buffer layer
3791 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3793 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3794 const int fd = PerlIO_fileno(f);
3795 if (fd >= 0 && PerlLIO_isatty(fd)) {
3796 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3798 if (*PerlIONext(f)) {
3799 const Off_t posn = PerlIO_tell(PerlIONext(f));
3800 if (posn != (Off_t) - 1) {
3804 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3808 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3809 IV n, const char *mode, int fd, int imode, int perm,
3810 PerlIO *f, int narg, SV **args)
3812 if (PerlIOValid(f)) {
3813 PerlIO *next = PerlIONext(f);
3815 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3816 if (tab && tab->Open)
3818 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3820 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3825 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3827 if (*mode == IoTYPE_IMPLICIT) {
3833 if (tab && tab->Open)
3834 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3837 SETERRNO(EINVAL, LIB_INVARG);
3839 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3841 * if push fails during open, open fails. close will pop us.
3846 fd = PerlIO_fileno(f);
3847 if (init && fd == 2) {
3849 * Initial stderr is unbuffered
3851 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3853 #ifdef PERLIO_USING_CRLF
3854 # ifdef PERLIO_IS_BINMODE_FD
3855 if (PERLIO_IS_BINMODE_FD(fd))
3856 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3860 * do something about failing setmode()? --jhi
3862 PerlLIO_setmode(fd, O_BINARY);
3865 /* Enable line buffering with record-oriented regular files
3866 * so we don't introduce an extraneous record boundary when
3867 * the buffer fills up.
3869 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3871 if (PerlLIO_fstat(fd, &st) == 0
3872 && S_ISREG(st.st_mode)
3873 && (st.st_fab_rfm == FAB$C_VAR
3874 || st.st_fab_rfm == FAB$C_VFC)) {
3875 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3886 * This "flush" is akin to sfio's sync in that it handles files in either
3887 * read or write state. For write state, we put the postponed data through
3888 * the next layers. For read state, we seek() the next layers to the
3889 * offset given by current position in the buffer, and discard the buffer
3890 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3891 * in any case?). Then the pass the stick further in chain.
3894 PerlIOBuf_flush(pTHX_ PerlIO *f)
3896 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3898 PerlIO *n = PerlIONext(f);
3899 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3901 * write() the buffer
3903 const STDCHAR *buf = b->buf;
3904 const STDCHAR *p = buf;
3905 while (p < b->ptr) {
3906 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3910 else if (count < 0 || PerlIO_error(n)) {
3911 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3912 PerlIO_save_errno(f);
3917 b->posn += (p - buf);
3919 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3920 STDCHAR *buf = PerlIO_get_base(f);
3922 * Note position change
3924 b->posn += (b->ptr - buf);
3925 if (b->ptr < b->end) {
3926 /* We did not consume all of it - try and seek downstream to
3927 our logical position
3929 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3930 /* Reload n as some layers may pop themselves on seek */
3931 b->posn = PerlIO_tell(n = PerlIONext(f));
3934 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3935 data is lost for good - so return saying "ok" having undone
3938 b->posn -= (b->ptr - buf);
3943 b->ptr = b->end = b->buf;
3944 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3945 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3946 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3951 /* This discards the content of the buffer after b->ptr, and rereads
3952 * the buffer from the position off in the layer downstream; here off
3953 * is at offset corresponding to b->ptr - b->buf.
3956 PerlIOBuf_fill(pTHX_ PerlIO *f)
3958 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3959 PerlIO *n = PerlIONext(f);
3962 * Down-stream flush is defined not to loose read data so is harmless.
3963 * we would not normally be fill'ing if there was data left in anycase.
3965 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3967 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3968 PerlIOBase_flush_linebuf(aTHX);
3971 PerlIO_get_base(f); /* allocate via vtable */
3973 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3975 b->ptr = b->end = b->buf;
3977 if (!PerlIOValid(n)) {
3978 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3982 if (PerlIO_fast_gets(n)) {
3984 * Layer below is also buffered. We do _NOT_ want to call its
3985 * ->Read() because that will loop till it gets what we asked for
3986 * which may hang on a pipe etc. Instead take anything it has to
3987 * hand, or ask it to fill _once_.
3989 avail = PerlIO_get_cnt(n);
3991 avail = PerlIO_fill(n);
3993 avail = PerlIO_get_cnt(n);
3995 if (!PerlIO_error(n) && PerlIO_eof(n))
4000 STDCHAR *ptr = PerlIO_get_ptr(n);
4001 const SSize_t cnt = avail;
4002 if (avail > (SSize_t)b->bufsiz)
4004 Copy(ptr, b->buf, avail, STDCHAR);
4005 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4009 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4013 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4016 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4017 PerlIO_save_errno(f);
4021 b->end = b->buf + avail;
4022 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4027 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4029 if (PerlIOValid(f)) {
4030 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4033 return PerlIOBase_read(aTHX_ f, vbuf, count);
4039 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4041 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4042 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4045 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4050 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4052 * Buffer is already a read buffer, we can overwrite any chars
4053 * which have been read back to buffer start
4055 avail = (b->ptr - b->buf);
4059 * Buffer is idle, set it up so whole buffer is available for
4063 b->end = b->buf + avail;
4065 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4067 * Buffer extends _back_ from where we are now
4069 b->posn -= b->bufsiz;
4071 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4073 * If we have space for more than count, just move count
4081 * In simple stdio-like ungetc() case chars will be already
4084 if (buf != b->ptr) {
4085 Copy(buf, b->ptr, avail, STDCHAR);
4089 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4093 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4099 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4101 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4102 const STDCHAR *buf = (const STDCHAR *) vbuf;
4103 const STDCHAR *flushptr = buf;
4107 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4109 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4110 if (PerlIO_flush(f) != 0) {
4114 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4115 flushptr = buf + count;
4116 while (flushptr > buf && *(flushptr - 1) != '\n')
4120 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4121 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4123 if (flushptr > buf && flushptr <= buf + avail)
4124 avail = flushptr - buf;
4125 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4127 Copy(buf, b->ptr, avail, STDCHAR);
4132 if (buf == flushptr)
4135 if (b->ptr >= (b->buf + b->bufsiz))
4136 if (PerlIO_flush(f) == -1)
4139 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4145 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4148 if ((code = PerlIO_flush(f)) == 0) {
4149 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4150 code = PerlIO_seek(PerlIONext(f), offset, whence);
4152 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4153 b->posn = PerlIO_tell(PerlIONext(f));
4160 PerlIOBuf_tell(pTHX_ PerlIO *f)
4162 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4164 * b->posn is file position where b->buf was read, or will be written
4166 Off_t posn = b->posn;
4167 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4168 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4170 /* As O_APPEND files are normally shared in some sense it is better
4175 /* when file is NOT shared then this is sufficient */
4176 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4178 posn = b->posn = PerlIO_tell(PerlIONext(f));
4182 * If buffer is valid adjust position by amount in buffer
4184 posn += (b->ptr - b->buf);
4190 PerlIOBuf_popped(pTHX_ PerlIO *f)
4192 const IV code = PerlIOBase_popped(aTHX_ f);
4193 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4194 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4197 b->ptr = b->end = b->buf = NULL;
4198 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4203 PerlIOBuf_close(pTHX_ PerlIO *f)
4205 const IV code = PerlIOBase_close(aTHX_ f);
4206 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4207 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4210 b->ptr = b->end = b->buf = NULL;
4211 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4216 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4218 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4225 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4227 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4230 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4231 return (b->end - b->ptr);
4236 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4238 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4239 PERL_UNUSED_CONTEXT;
4243 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4244 Newxz(b->buf,b->bufsiz, STDCHAR);
4246 b->buf = (STDCHAR *) & b->oneword;
4247 b->bufsiz = sizeof(b->oneword);
4249 b->end = b->ptr = b->buf;
4255 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4257 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4260 return (b->end - b->buf);
4264 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4266 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4268 PERL_UNUSED_ARG(cnt);
4273 assert(PerlIO_get_cnt(f) == cnt);
4274 assert(b->ptr >= b->buf);
4275 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4279 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4281 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4286 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4287 sizeof(PerlIO_funcs),
4290 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4294 PerlIOBase_binmode, /* binmode */
4308 PerlIOBase_clearerr,
4309 PerlIOBase_setlinebuf,
4314 PerlIOBuf_set_ptrcnt,
4317 /*--------------------------------------------------------------------------------------*/
4319 * Temp layer to hold unread chars when cannot do it any other way
4323 PerlIOPending_fill(pTHX_ PerlIO *f)
4326 * Should never happen
4333 PerlIOPending_close(pTHX_ PerlIO *f)
4336 * A tad tricky - flush pops us, then we close new top
4339 return PerlIO_close(f);
4343 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4346 * A tad tricky - flush pops us, then we seek new top
4349 return PerlIO_seek(f, offset, whence);
4354 PerlIOPending_flush(pTHX_ PerlIO *f)
4356 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4357 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4361 PerlIO_pop(aTHX_ f);
4366 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4372 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4377 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4379 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4380 PerlIOl * const l = PerlIOBase(f);
4382 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4383 * etc. get muddled when it changes mid-string when we auto-pop.
4385 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4386 (PerlIOBase(PerlIONext(f))->
4387 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4392 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4394 SSize_t avail = PerlIO_get_cnt(f);
4396 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4399 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4400 if (got >= 0 && got < (SSize_t)count) {
4401 const SSize_t more =
4402 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4403 if (more >= 0 || got == 0)
4409 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4410 sizeof(PerlIO_funcs),
4413 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4414 PerlIOPending_pushed,
4417 PerlIOBase_binmode, /* binmode */
4426 PerlIOPending_close,
4427 PerlIOPending_flush,
4431 PerlIOBase_clearerr,
4432 PerlIOBase_setlinebuf,
4437 PerlIOPending_set_ptrcnt,
4442 /*--------------------------------------------------------------------------------------*/
4444 * crlf - translation On read translate CR,LF to "\n" we do this by
4445 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4446 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4448 * c->nl points on the first byte of CR LF pair when it is temporarily
4449 * replaced by LF, or to the last CR of the buffer. In the former case
4450 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4451 * that it ends at c->nl; these two cases can be distinguished by
4452 * *c->nl. c->nl is set during _getcnt() call, and unset during
4453 * _unread() and _flush() calls.
4454 * It only matters for read operations.
4458 PerlIOBuf base; /* PerlIOBuf stuff */
4459 STDCHAR *nl; /* Position of crlf we "lied" about in the
4463 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4464 * Otherwise the :crlf layer would always revert back to
4468 S_inherit_utf8_flag(PerlIO *f)
4470 PerlIO *g = PerlIONext(f);
4471 if (PerlIOValid(g)) {
4472 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4473 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4479 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4482 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4483 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4485 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4486 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4487 PerlIOBase(f)->flags);
4490 /* If the old top layer is a CRLF layer, reactivate it (if
4491 * necessary) and remove this new layer from the stack */
4492 PerlIO *g = PerlIONext(f);
4493 if (PerlIOValid(g)) {
4494 PerlIOl *b = PerlIOBase(g);
4495 if (b && b->tab == &PerlIO_crlf) {
4496 if (!(b->flags & PERLIO_F_CRLF))
4497 b->flags |= PERLIO_F_CRLF;
4498 S_inherit_utf8_flag(g);
4499 PerlIO_pop(aTHX_ f);
4504 S_inherit_utf8_flag(f);
4510 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4512 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4513 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4514 *(c->nl) = NATIVE_0xd;
4517 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4518 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4520 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4521 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4523 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4528 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4529 b->end = b->ptr = b->buf + b->bufsiz;
4530 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4531 b->posn -= b->bufsiz;
4533 while (count > 0 && b->ptr > b->buf) {
4534 const int ch = *--buf;
4536 if (b->ptr - 2 >= b->buf) {
4537 *--(b->ptr) = NATIVE_0xa;
4538 *--(b->ptr) = NATIVE_0xd;
4543 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4544 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4558 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4563 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4565 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4567 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4570 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4571 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4572 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4573 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4575 while (nl < b->end && *nl != NATIVE_0xd)
4577 if (nl < b->end && *nl == NATIVE_0xd) {
4579 if (nl + 1 < b->end) {
4580 if (nl[1] == NATIVE_0xa) {
4586 * Not CR,LF but just CR
4594 * Blast - found CR as last char in buffer
4599 * They may not care, defer work as long as
4603 return (nl - b->ptr);
4607 b->ptr++; /* say we have read it as far as
4608 * flush() is concerned */
4609 b->buf++; /* Leave space in front of buffer */
4610 /* Note as we have moved buf up flush's
4612 will naturally make posn point at CR
4614 b->bufsiz--; /* Buffer is thus smaller */
4615 code = PerlIO_fill(f); /* Fetch some more */
4616 b->bufsiz++; /* Restore size for next time */
4617 b->buf--; /* Point at space */
4618 b->ptr = nl = b->buf; /* Which is what we hand
4620 *nl = NATIVE_0xd; /* Fill in the CR */
4622 goto test; /* fill() call worked */
4624 * CR at EOF - just fall through
4626 /* Should we clear EOF though ??? */
4631 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4637 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4639 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4640 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4646 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4647 /* Deferred CR at end of buffer case - we lied about count */
4660 * Test code - delete when it works ...
4662 IV flags = PerlIOBase(f)->flags;
4663 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4664 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4665 /* Deferred CR at end of buffer case - we lied about count */
4671 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4672 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4673 flags, c->nl, b->end, cnt);
4680 * They have taken what we lied about
4682 *(c->nl) = NATIVE_0xd;
4688 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4692 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4694 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4695 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4697 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4698 const STDCHAR *buf = (const STDCHAR *) vbuf;
4699 const STDCHAR * const ebuf = buf + count;
4702 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4704 while (buf < ebuf) {
4705 const STDCHAR * const eptr = b->buf + b->bufsiz;
4706 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4707 while (buf < ebuf && b->ptr < eptr) {
4709 if ((b->ptr + 2) > eptr) {
4717 *(b->ptr)++ = NATIVE_0xd; /* CR */
4718 *(b->ptr)++ = NATIVE_0xa; /* LF */
4720 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4727 *(b->ptr)++ = *buf++;
4729 if (b->ptr >= eptr) {
4735 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4737 return (buf - (STDCHAR *) vbuf);
4742 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4744 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4746 *(c->nl) = NATIVE_0xd;
4749 return PerlIOBuf_flush(aTHX_ f);
4753 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4755 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4756 /* In text mode - flush any pending stuff and flip it */
4757 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4758 #ifndef PERLIO_USING_CRLF
4759 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4760 PerlIO_pop(aTHX_ f);
4766 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4767 sizeof(PerlIO_funcs),
4770 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4772 PerlIOBuf_popped, /* popped */
4774 PerlIOCrlf_binmode, /* binmode */
4778 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4779 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4780 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4788 PerlIOBase_clearerr,
4789 PerlIOBase_setlinebuf,
4794 PerlIOCrlf_set_ptrcnt,
4798 Perl_PerlIO_stdin(pTHX)
4801 PerlIO_stdstreams(aTHX);
4803 return (PerlIO*)&PL_perlio[1];
4807 Perl_PerlIO_stdout(pTHX)
4810 PerlIO_stdstreams(aTHX);
4812 return (PerlIO*)&PL_perlio[2];
4816 Perl_PerlIO_stderr(pTHX)
4819 PerlIO_stdstreams(aTHX);
4821 return (PerlIO*)&PL_perlio[3];
4824 /*--------------------------------------------------------------------------------------*/
4827 PerlIO_getname(PerlIO *f, char *buf)
4832 bool exported = FALSE;
4833 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4835 stdio = PerlIO_exportFILE(f,0);
4839 name = fgetname(stdio, buf);
4840 if (exported) PerlIO_releaseFILE(f,stdio);
4845 PERL_UNUSED_ARG(buf);
4846 Perl_croak_nocontext("Don't know how to get file name");
4852 /*--------------------------------------------------------------------------------------*/
4854 * Functions which can be called on any kind of PerlIO implemented in
4858 #undef PerlIO_fdopen
4860 PerlIO_fdopen(int fd, const char *mode)
4863 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4868 PerlIO_open(const char *path, const char *mode)
4871 SV *name = sv_2mortal(newSVpv(path, 0));
4872 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4875 #undef Perlio_reopen
4877 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4880 SV *name = sv_2mortal(newSVpv(path,0));
4881 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4886 PerlIO_getc(PerlIO *f)
4890 if ( 1 == PerlIO_read(f, buf, 1) ) {
4891 return (unsigned char) buf[0];
4896 #undef PerlIO_ungetc
4898 PerlIO_ungetc(PerlIO *f, int ch)
4903 if (PerlIO_unread(f, &buf, 1) == 1)
4911 PerlIO_putc(PerlIO *f, int ch)
4915 return PerlIO_write(f, &buf, 1);
4920 PerlIO_puts(PerlIO *f, const char *s)
4923 return PerlIO_write(f, s, strlen(s));
4926 #undef PerlIO_rewind
4928 PerlIO_rewind(PerlIO *f)
4931 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4935 #undef PerlIO_vprintf
4937 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4946 Perl_va_copy(ap, apc);
4947 sv = vnewSVpvf(fmt, &apc);
4950 sv = vnewSVpvf(fmt, &ap);
4952 s = SvPV_const(sv, len);
4953 wrote = PerlIO_write(f, s, len);
4958 #undef PerlIO_printf
4960 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4965 result = PerlIO_vprintf(f, fmt, ap);
4970 #undef PerlIO_stdoutf
4972 PerlIO_stdoutf(const char *fmt, ...)
4978 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4983 #undef PerlIO_tmpfile
4985 PerlIO_tmpfile(void)
4992 const int fd = win32_tmpfd();
4994 f = PerlIO_fdopen(fd, "w+b");
4996 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4998 char tempname[] = "/tmp/PerlIO_XXXXXX";
4999 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5001 int old_umask = umask(0600);
5003 * I have no idea how portable mkstemp() is ... NI-S
5005 if (tmpdir && *tmpdir) {
5006 /* if TMPDIR is set and not empty, we try that first */
5007 sv = newSVpv(tmpdir, 0);
5008 sv_catpv(sv, tempname + 4);
5009 fd = mkstemp(SvPVX(sv));
5014 /* else we try /tmp */
5015 fd = mkstemp(tempname);
5020 sv_catpv(sv, tempname + 4);
5021 fd = mkstemp(SvPVX(sv));
5025 f = PerlIO_fdopen(fd, "w+");
5027 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5028 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5031 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5032 FILE * const stdio = PerlSIO_tmpfile();
5035 f = PerlIO_fdopen(fileno(stdio), "w+");
5037 # endif /* else HAS_MKSTEMP */
5038 #endif /* else WIN32 */
5043 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5045 if (!PerlIOValid(f))
5047 PerlIOBase(f)->err = errno;
5049 PerlIOBase(f)->os_err = vaxc$errno;
5051 PerlIOBase(f)->os_err = Perl_rc;
5052 #elif defined(WIN32)
5053 PerlIOBase(f)->os_err = GetLastError();
5058 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5060 if (!PerlIOValid(f))
5062 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5064 Perl_rc = PerlIOBase(f)->os_err);
5065 #elif defined(WIN32)
5066 SetLastError(PerlIOBase(f)->os_err);
5074 /*======================================================================================*/
5076 * Now some functions in terms of above which may be needed even if we are
5077 * not in true PerlIO mode
5080 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5082 const char *direction = NULL;
5085 * Need to supply default layer info from open.pm
5091 if (mode && mode[0] != 'r') {
5092 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5093 direction = "open>";
5095 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5096 direction = "open<";
5101 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5104 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5109 #undef PerlIO_setpos
5111 PerlIO_setpos(PerlIO *f, SV *pos)
5117 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5118 if(len == sizeof(Off_t))
5119 return PerlIO_seek(f, *posn, SEEK_SET);
5122 SETERRNO(EINVAL, SS_IVCHAN);
5126 #undef PerlIO_setpos
5128 PerlIO_setpos(PerlIO *f, SV *pos)
5134 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5135 if(len == sizeof(Fpos_t))
5136 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5137 return fsetpos64(f, fpos);
5139 return fsetpos(f, fpos);
5143 SETERRNO(EINVAL, SS_IVCHAN);
5149 #undef PerlIO_getpos
5151 PerlIO_getpos(PerlIO *f, SV *pos)
5154 Off_t posn = PerlIO_tell(f);
5155 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5156 return (posn == (Off_t) - 1) ? -1 : 0;
5159 #undef PerlIO_getpos
5161 PerlIO_getpos(PerlIO *f, SV *pos)
5166 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5167 code = fgetpos64(f, &fpos);
5169 code = fgetpos(f, &fpos);
5171 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5176 #if !defined(HAS_VPRINTF)
5179 vprintf(char *pat, char *args)
5181 _doprnt(pat, args, stdout);
5182 return 0; /* wrong, but perl doesn't use the return
5187 vfprintf(FILE *fd, char *pat, char *args)
5189 _doprnt(pat, args, fd);
5190 return 0; /* wrong, but perl doesn't use the return
5196 /* print a failure format string message to stderr and fail exit the process
5197 using only libc without depending on any perl data structures being
5202 Perl_noperl_die(const char* pat, ...)
5205 PERL_ARGS_ASSERT_NOPERL_DIE;
5206 va_start(arglist, pat);
5207 vfprintf(stderr, pat, arglist);
5213 * ex: set ts=8 sts=4 sw=4 et: