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)
2208 PERL_TSA_REQUIRES(PL_perlio_mutex)
2211 const int old_max = PL_perlio_fd_refcnt_size;
2212 const int new_max = 16 + (new_fd & ~15);
2215 #ifndef PERL_IMPLICIT_SYS
2216 PERL_UNUSED_CONTEXT;
2219 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2220 old_max, new_fd, new_max);
2222 if (new_fd < old_max) {
2226 assert (new_max > new_fd);
2228 /* Use plain realloc() since we need this memory to be really
2229 * global and visible to all the interpreters and/or threads. */
2230 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2234 MUTEX_UNLOCK(&PL_perlio_mutex);
2239 PL_perlio_fd_refcnt_size = new_max;
2240 PL_perlio_fd_refcnt = new_array;
2242 PerlIO_debug("Zeroing %p, %d\n",
2243 (void*)(new_array + old_max),
2246 Zero(new_array + old_max, new_max - old_max, int);
2253 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2254 PERL_UNUSED_CONTEXT;
2258 PerlIOUnix_refcnt_inc(int fd)
2265 MUTEX_LOCK(&PL_perlio_mutex);
2267 if (fd >= PL_perlio_fd_refcnt_size)
2268 S_more_refcounted_fds(aTHX_ fd);
2270 PL_perlio_fd_refcnt[fd]++;
2271 if (PL_perlio_fd_refcnt[fd] <= 0) {
2272 /* diag_listed_as: refcnt_inc: fd %d%s */
2273 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2274 fd, PL_perlio_fd_refcnt[fd]);
2276 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2277 fd, PL_perlio_fd_refcnt[fd]);
2280 MUTEX_UNLOCK(&PL_perlio_mutex);
2283 /* diag_listed_as: refcnt_inc: fd %d%s */
2284 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2289 PerlIOUnix_refcnt_dec(int fd)
2295 MUTEX_LOCK(&PL_perlio_mutex);
2297 if (fd >= PL_perlio_fd_refcnt_size) {
2298 /* diag_listed_as: refcnt_dec: fd %d%s */
2299 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2300 fd, PL_perlio_fd_refcnt_size);
2302 if (PL_perlio_fd_refcnt[fd] <= 0) {
2303 /* diag_listed_as: refcnt_dec: fd %d%s */
2304 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2305 fd, PL_perlio_fd_refcnt[fd]);
2307 cnt = --PL_perlio_fd_refcnt[fd];
2308 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2310 MUTEX_UNLOCK(&PL_perlio_mutex);
2313 /* diag_listed_as: refcnt_dec: fd %d%s */
2314 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2320 PerlIOUnix_refcnt(int fd)
2327 MUTEX_LOCK(&PL_perlio_mutex);
2329 if (fd >= PL_perlio_fd_refcnt_size) {
2330 /* diag_listed_as: refcnt: fd %d%s */
2331 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2332 fd, PL_perlio_fd_refcnt_size);
2334 if (PL_perlio_fd_refcnt[fd] <= 0) {
2335 /* diag_listed_as: refcnt: fd %d%s */
2336 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2337 fd, PL_perlio_fd_refcnt[fd]);
2339 cnt = PL_perlio_fd_refcnt[fd];
2341 MUTEX_UNLOCK(&PL_perlio_mutex);
2344 /* diag_listed_as: refcnt: fd %d%s */
2345 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2351 PerlIO_cleanup(pTHX)
2355 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2357 PerlIO_debug("Cleanup layers\n");
2360 /* Raise STDIN..STDERR refcount so we don't close them */
2361 for (i=0; i < 3; i++)
2362 PerlIOUnix_refcnt_inc(i);
2363 PerlIO_cleantable(aTHX_ &PL_perlio);
2364 /* Restore STDIN..STDERR refcount */
2365 for (i=0; i < 3; i++)
2366 PerlIOUnix_refcnt_dec(i);
2368 if (PL_known_layers) {
2369 PerlIO_list_free(aTHX_ PL_known_layers);
2370 PL_known_layers = NULL;
2372 if (PL_def_layerlist) {
2373 PerlIO_list_free(aTHX_ PL_def_layerlist);
2374 PL_def_layerlist = NULL;
2378 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2382 /* XXX we can't rely on an interpreter being present at this late stage,
2383 XXX so we can't use a function like PerlLIO_write that relies on one
2384 being present (at least in win32) :-(.
2389 /* By now all filehandles should have been closed, so any
2390 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2392 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2393 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2394 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2396 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2397 if (PL_perlio_fd_refcnt[i]) {
2399 my_snprintf(buf, sizeof(buf),
2400 "PerlIO_teardown: fd %d refcnt=%d\n",
2401 i, PL_perlio_fd_refcnt[i]);
2402 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2408 /* Not bothering with PL_perlio_mutex since by now
2409 * all the interpreters are gone. */
2410 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2411 && PL_perlio_fd_refcnt) {
2412 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2413 PL_perlio_fd_refcnt = NULL;
2414 PL_perlio_fd_refcnt_size = 0;
2418 /*--------------------------------------------------------------------------------------*/
2420 * Bottom-most level for UNIX-like case
2424 struct _PerlIO base; /* The generic part */
2425 int fd; /* UNIX like file descriptor */
2426 int oflags; /* open/fcntl flags */
2430 S_lockcnt_dec(pTHX_ const void* f)
2432 #ifndef PERL_IMPLICIT_SYS
2433 PERL_UNUSED_CONTEXT;
2435 PerlIO_lockcnt((PerlIO*)f)--;
2439 /* call the signal handler, and if that handler happens to clear
2440 * this handle, free what we can and return true */
2443 S_perlio_async_run(pTHX_ PerlIO* f) {
2445 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2446 PerlIO_lockcnt(f)++;
2448 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2452 /* we've just run some perl-level code that could have done
2453 * anything, including closing the file or clearing this layer.
2454 * If so, free any lower layers that have already been
2455 * cleared, then return an error. */
2456 while (PerlIOValid(f) &&
2457 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2459 const PerlIOl *l = *f;
2468 PerlIOUnix_oflags(const char *mode)
2471 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2476 if (*++mode == '+') {
2483 oflags = O_CREAT | O_TRUNC;
2484 if (*++mode == '+') {
2493 oflags = O_CREAT | O_APPEND;
2494 if (*++mode == '+') {
2503 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2505 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2506 * of them in, and then bit-and-masking the other them away, won't
2507 * have much of an effect. */
2510 #if O_TEXT != O_BINARY
2517 #if O_TEXT != O_BINARY
2519 oflags &= ~O_BINARY;
2525 /* bit-or:ing with zero O_BINARY would be useless. */
2527 * If neither "t" nor "b" was specified, open the file
2530 * Note that if something else than the zero byte was seen
2531 * here (e.g. bogus mode "rx"), just few lines later we will
2532 * set the errno and invalidate the flags.
2538 if (*mode || oflags == -1) {
2539 SETERRNO(EINVAL, LIB_INVARG);
2546 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2548 PERL_UNUSED_CONTEXT;
2549 return PerlIOSelf(f, PerlIOUnix)->fd;
2553 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2555 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2558 if (PerlLIO_fstat(fd, &st) == 0) {
2559 if (!S_ISREG(st.st_mode)) {
2560 PerlIO_debug("%d is not regular file\n",fd);
2561 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2564 PerlIO_debug("%d _is_ a regular file\n",fd);
2570 PerlIOUnix_refcnt_inc(fd);
2571 PERL_UNUSED_CONTEXT;
2575 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2577 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2578 if (*PerlIONext(f)) {
2579 /* We never call down so do any pending stuff now */
2580 PerlIO_flush(PerlIONext(f));
2582 * XXX could (or should) we retrieve the oflags from the open file
2583 * handle rather than believing the "mode" we are passed in? XXX
2584 * Should the value on NULL mode be 0 or -1?
2586 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2587 mode ? PerlIOUnix_oflags(mode) : -1);
2589 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2595 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2597 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2599 PERL_UNUSED_CONTEXT;
2600 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2602 SETERRNO(ESPIPE, LIB_INVARG);
2604 SETERRNO(EINVAL, LIB_INVARG);
2608 new_loc = PerlLIO_lseek(fd, offset, whence);
2609 if (new_loc == (Off_t) - 1)
2611 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2616 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2617 IV n, const char *mode, int fd, int imode,
2618 int perm, PerlIO *f, int narg, SV **args)
2620 if (PerlIOValid(f)) {
2621 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2622 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2625 if (*mode == IoTYPE_NUMERIC)
2628 imode = PerlIOUnix_oflags(mode);
2630 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2637 const char *path = SvPV_const(*args, len);
2638 if (!IS_SAFE_PATHNAME(path, len, "open"))
2640 fd = PerlLIO_open3(path, imode, perm);
2644 if (*mode == IoTYPE_IMPLICIT)
2647 f = PerlIO_allocate(aTHX);
2649 if (!PerlIOValid(f)) {
2650 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2655 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2656 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2657 if (*mode == IoTYPE_APPEND)
2658 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2665 * FIXME: pop layers ???
2673 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2675 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2677 if (flags & PERLIO_DUP_FD) {
2678 fd = PerlLIO_dup(fd);
2681 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2683 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2684 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2694 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2697 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2699 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2700 #ifdef PERLIO_STD_SPECIAL
2702 return PERLIO_STD_IN(fd, vbuf, count);
2704 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2705 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2709 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2710 if (len >= 0 || errno != EINTR) {
2712 if (errno != EAGAIN) {
2713 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2714 PerlIO_save_errno(f);
2717 else if (len == 0 && count != 0) {
2718 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2724 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2727 NOT_REACHED; /*NOTREACHED*/
2731 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2734 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2736 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2737 #ifdef PERLIO_STD_SPECIAL
2738 if (fd == 1 || fd == 2)
2739 return PERLIO_STD_OUT(fd, vbuf, count);
2742 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2743 if (len >= 0 || errno != EINTR) {
2745 if (errno != EAGAIN) {
2746 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2747 PerlIO_save_errno(f);
2753 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2756 NOT_REACHED; /*NOTREACHED*/
2760 PerlIOUnix_tell(pTHX_ PerlIO *f)
2762 PERL_UNUSED_CONTEXT;
2764 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2769 PerlIOUnix_close(pTHX_ PerlIO *f)
2771 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2773 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2774 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2775 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2780 SETERRNO(EBADF,SS_IVCHAN);
2783 while (PerlLIO_close(fd) != 0) {
2784 if (errno != EINTR) {
2789 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2793 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2798 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2799 sizeof(PerlIO_funcs),
2806 PerlIOBase_binmode, /* binmode */
2816 PerlIOBase_noop_ok, /* flush */
2817 PerlIOBase_noop_fail, /* fill */
2820 PerlIOBase_clearerr,
2821 PerlIOBase_setlinebuf,
2822 NULL, /* get_base */
2823 NULL, /* get_bufsiz */
2826 NULL, /* set_ptrcnt */
2829 /*--------------------------------------------------------------------------------------*/
2834 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2835 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2836 broken by the last second glibc 2.3 fix
2838 #define STDIO_BUFFER_WRITABLE
2843 struct _PerlIO base;
2844 FILE *stdio; /* The stream */
2848 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2850 PERL_UNUSED_CONTEXT;
2852 if (PerlIOValid(f)) {
2853 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2855 return PerlSIO_fileno(s);
2862 PerlIOStdio_mode(const char *mode, char *tmode)
2864 char * const ret = tmode;
2870 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2878 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2881 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2882 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2883 if (toptab == tab) {
2884 /* Top is already stdio - pop self (duplicate) and use original */
2885 PerlIO_pop(aTHX_ f);
2888 const int fd = PerlIO_fileno(n);
2891 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2892 mode = PerlIOStdio_mode(mode, tmode)))) {
2893 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2894 /* We never call down so do any pending stuff now */
2895 PerlIO_flush(PerlIONext(f));
2896 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2903 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2908 PerlIO_importFILE(FILE *stdio, const char *mode)
2914 char filename[FILENAME_MAX];
2919 int fd0 = fileno(stdio);
2922 rc = fldata(stdio,filename,&fileinfo);
2926 if(fileinfo.__dsorgHFS){
2929 /*This MVS dataset , OK!*/
2934 if (!mode || !*mode) {
2935 /* We need to probe to see how we can open the stream
2936 so start with read/write and then try write and read
2937 we dup() so that we can fclose without loosing the fd.
2939 Note that the errno value set by a failing fdopen
2940 varies between stdio implementations.
2942 const int fd = PerlLIO_dup(fd0);
2947 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2949 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2952 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2955 /* Don't seem to be able to open */
2961 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2962 s = PerlIOSelf(f, PerlIOStdio);
2965 fd0 = fileno(stdio);
2967 PerlIOUnix_refcnt_inc(fd0);
2970 rc = fldata(stdio,filename,&fileinfo);
2972 PerlIOUnix_refcnt_inc(fd0);
2974 if(fileinfo.__dsorgHFS){
2975 PerlIOUnix_refcnt_inc(fd0);
2977 /*This MVS dataset , OK!*/
2980 PerlIOUnix_refcnt_inc(fileno(stdio));
2988 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2989 IV n, const char *mode, int fd, int imode,
2990 int perm, PerlIO *f, int narg, SV **args)
2993 if (PerlIOValid(f)) {
2995 const char * const path = SvPV_const(*args, len);
2996 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2998 if (!IS_SAFE_PATHNAME(path, len, "open"))
3000 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3001 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3006 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3012 const char * const path = SvPV_const(*args, len);
3013 if (!IS_SAFE_PATHNAME(path, len, "open"))
3015 if (*mode == IoTYPE_NUMERIC) {
3017 fd = PerlLIO_open3(path, imode, perm);
3021 bool appended = FALSE;
3023 /* Cygwin wants its 'b' early. */
3025 mode = PerlIOStdio_mode(mode, tmode);
3027 stdio = PerlSIO_fopen(path, mode);
3030 f = PerlIO_allocate(aTHX);
3033 mode = PerlIOStdio_mode(mode, tmode);
3034 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3036 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3037 PerlIOUnix_refcnt_inc(fileno(stdio));
3039 PerlSIO_fclose(stdio);
3051 if (*mode == IoTYPE_IMPLICIT) {
3058 stdio = PerlSIO_stdin;
3061 stdio = PerlSIO_stdout;
3064 stdio = PerlSIO_stderr;
3069 stdio = PerlSIO_fdopen(fd, mode =
3070 PerlIOStdio_mode(mode, tmode));
3074 f = PerlIO_allocate(aTHX);
3076 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3077 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3078 PerlIOUnix_refcnt_inc(fileno(stdio));
3089 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3091 /* This assumes no layers underneath - which is what
3092 happens, but is not how I remember it. NI-S 2001/10/16
3094 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3095 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3096 const int fd = fileno(stdio);
3098 if (flags & PERLIO_DUP_FD) {
3099 const int dfd = PerlLIO_dup(fileno(stdio));
3101 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3106 /* FIXME: To avoid messy error recovery if dup fails
3107 re-use the existing stdio as though flag was not set
3111 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3113 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3115 PerlIOUnix_refcnt_inc(fileno(stdio));
3122 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3124 PERL_UNUSED_CONTEXT;
3126 /* XXX this could use PerlIO_canset_fileno() and
3127 * PerlIO_set_fileno() support from Configure
3129 # if defined(HAS_FDCLOSE)
3130 return fdclose(f, NULL) == 0 ? 1 : 0;
3131 # elif defined(__UCLIBC__)
3132 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3135 # elif defined(__GLIBC__)
3136 /* There may be a better way for GLIBC:
3137 - libio.h defines a flag to not close() on cleanup
3141 # elif defined(__sun)
3144 # elif defined(__hpux)
3148 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3149 your platform does not have special entry try this one.
3150 [For OSF only have confirmation for Tru64 (alpha)
3151 but assume other OSFs will be similar.]
3153 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3156 # elif defined(__FreeBSD__)
3157 /* There may be a better way on FreeBSD:
3158 - we could insert a dummy func in the _close function entry
3159 f->_close = (int (*)(void *)) dummy_close;
3163 # elif defined(__OpenBSD__)
3164 /* There may be a better way on OpenBSD:
3165 - we could insert a dummy func in the _close function entry
3166 f->_close = (int (*)(void *)) dummy_close;
3170 # elif defined(__EMX__)
3171 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3174 # elif defined(__CYGWIN__)
3175 /* There may be a better way on CYGWIN:
3176 - we could insert a dummy func in the _close function entry
3177 f->_close = (int (*)(void *)) dummy_close;
3181 # elif defined(WIN32)
3182 # if defined(UNDER_CE)
3183 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3192 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3193 (which isn't thread safe) instead
3195 # error "Don't know how to set FILE.fileno on your platform"
3203 PerlIOStdio_close(pTHX_ PerlIO *f)
3205 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3211 const int fd = fileno(stdio);
3219 #ifdef SOCKS5_VERSION_NAME
3220 /* Socks lib overrides close() but stdio isn't linked to
3221 that library (though we are) - so we must call close()
3222 on sockets on stdio's behalf.
3225 Sock_size_t optlen = sizeof(int);
3226 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3229 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3230 that a subsequent fileno() on it returns -1. Don't want to croak()
3231 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3232 trying to close an already closed handle which somehow it still has
3233 a reference to. (via.xs, I'm looking at you). */
3234 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3235 /* File descriptor still in use */
3239 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3240 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3242 if (stdio == stdout || stdio == stderr)
3243 return PerlIO_flush(f);
3246 MUTEX_LOCK(&PL_perlio_mutex);
3247 /* Right. We need a mutex here because for a brief while we
3248 will have the situation that fd is actually closed. Hence if
3249 a second thread were to get into this block, its dup() would
3250 likely return our fd as its dupfd. (after all, it is closed)
3251 Then if we get to the dup2() first, we blat the fd back
3252 (messing up its temporary as a side effect) only for it to
3253 then close its dupfd (== our fd) in its close(dupfd) */
3255 /* There is, of course, a race condition, that any other thread
3256 trying to input/output/whatever on this fd will be stuffed
3257 for the duration of this little manoeuvrer. Perhaps we
3258 should hold an IO mutex for the duration of every IO
3259 operation if we know that invalidate doesn't work on this
3260 platform, but that would suck, and could kill performance.
3262 Except that correctness trumps speed.
3263 Advice from klortho #11912. */
3266 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3267 Use Sarathy's trick from maint-5.6 to invalidate the
3268 fileno slot of the FILE *
3270 result = PerlIO_flush(f);
3272 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3274 dupfd = PerlLIO_dup(fd);
3277 /* Oh cXap. This isn't going to go well. Not sure if we can
3278 recover from here, or if closing this particular FILE *
3279 is a good idea now. */
3284 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3286 result = PerlSIO_fclose(stdio);
3287 /* We treat error from stdio as success if we invalidated
3288 errno may NOT be expected EBADF
3290 if (invalidate && result != 0) {
3294 #ifdef SOCKS5_VERSION_NAME
3295 /* in SOCKS' case, let close() determine return value */
3299 PerlLIO_dup2(dupfd,fd);
3300 PerlLIO_close(dupfd);
3303 MUTEX_UNLOCK(&PL_perlio_mutex);
3310 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3314 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3316 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3319 STDCHAR *buf = (STDCHAR *) vbuf;
3321 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3322 * stdio does not do that for fread()
3324 const int ch = PerlSIO_fgetc(s);
3331 got = PerlSIO_fread(vbuf, 1, count, s);
3332 if (got == 0 && PerlSIO_ferror(s))
3334 if (got >= 0 || errno != EINTR)
3336 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3338 SETERRNO(0,0); /* just in case */
3341 /* Under some circumstances IRIX stdio fgetc() and fread()
3342 * set the errno to ENOENT, which makes no sense according
3343 * to either IRIX or POSIX. [rt.perl.org #123977] */
3344 if (errno == ENOENT) SETERRNO(0,0);
3350 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3353 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3355 #ifdef STDIO_BUFFER_WRITABLE
3356 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3357 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3358 STDCHAR *base = PerlIO_get_base(f);
3359 SSize_t cnt = PerlIO_get_cnt(f);
3360 STDCHAR *ptr = PerlIO_get_ptr(f);
3361 SSize_t avail = ptr - base;
3363 if (avail > count) {
3367 Move(buf-avail,ptr,avail,STDCHAR);
3370 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3371 if (PerlSIO_feof(s) && unread >= 0)
3372 PerlSIO_clearerr(s);
3377 if (PerlIO_has_cntptr(f)) {
3378 /* We can get pointer to buffer but not its base
3379 Do ungetc() but check chars are ending up in the
3382 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3383 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3385 const int ch = *--buf & 0xFF;
3386 if (ungetc(ch,s) != ch) {
3387 /* ungetc did not work */
3390 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3391 /* Did not change pointer as expected */
3392 if (fgetc(s) != EOF) /* get char back again */
3402 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3408 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3411 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3414 got = PerlSIO_fwrite(vbuf, 1, count,
3415 PerlIOSelf(f, PerlIOStdio)->stdio);
3416 if (got >= 0 || errno != EINTR)
3418 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3420 SETERRNO(0,0); /* just in case */
3426 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3428 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3429 PERL_UNUSED_CONTEXT;
3431 return PerlSIO_fseek(stdio, offset, whence);
3435 PerlIOStdio_tell(pTHX_ PerlIO *f)
3437 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3438 PERL_UNUSED_CONTEXT;
3440 return PerlSIO_ftell(stdio);
3444 PerlIOStdio_flush(pTHX_ PerlIO *f)
3446 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3447 PERL_UNUSED_CONTEXT;
3449 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3450 return PerlSIO_fflush(stdio);
3456 * FIXME: This discards ungetc() and pre-read stuff which is not
3457 * right if this is just a "sync" from a layer above Suspect right
3458 * design is to do _this_ but not have layer above flush this
3459 * layer read-to-read
3462 * Not writeable - sync by attempting a seek
3465 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3473 PerlIOStdio_eof(pTHX_ PerlIO *f)
3475 PERL_UNUSED_CONTEXT;
3477 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3481 PerlIOStdio_error(pTHX_ PerlIO *f)
3483 PERL_UNUSED_CONTEXT;
3485 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3489 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3491 PERL_UNUSED_CONTEXT;
3493 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3497 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3499 PERL_UNUSED_CONTEXT;
3501 #ifdef HAS_SETLINEBUF
3502 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3504 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3510 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3512 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3513 return (STDCHAR*)PerlSIO_get_base(stdio);
3517 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3519 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3520 return PerlSIO_get_bufsiz(stdio);
3524 #ifdef USE_STDIO_PTR
3526 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3528 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3529 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3533 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3535 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3536 return PerlSIO_get_cnt(stdio);
3540 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3542 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3544 #ifdef STDIO_PTR_LVALUE
3545 /* This is a long-standing infamous mess. The root of the
3546 * problem is that one cannot know the signedness of char, and
3547 * more precisely the signedness of FILE._ptr. The following
3548 * things have been tried, and they have all failed (across
3549 * different compilers (remember that core needs to to build
3550 * also with c++) and compiler options:
3552 * - casting the RHS to (void*) -- works in *some* places
3553 * - casting the LHS to (void*) -- totally unportable
3555 * So let's try silencing the warning at least for gcc. */
3556 GCC_DIAG_IGNORE(-Wpointer-sign);
3557 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3559 #ifdef STDIO_PTR_LVAL_SETS_CNT
3560 assert(PerlSIO_get_cnt(stdio) == (cnt));
3562 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3564 * Setting ptr _does_ change cnt - we are done
3568 #else /* STDIO_PTR_LVALUE */
3570 #endif /* STDIO_PTR_LVALUE */
3573 * Now (or only) set cnt
3575 #ifdef STDIO_CNT_LVALUE
3576 PerlSIO_set_cnt(stdio, cnt);
3577 #else /* STDIO_CNT_LVALUE */
3578 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3579 PerlSIO_set_ptr(stdio,
3580 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3582 #else /* STDIO_PTR_LVAL_SETS_CNT */
3584 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3585 #endif /* STDIO_CNT_LVALUE */
3592 PerlIOStdio_fill(pTHX_ PerlIO *f)
3596 PERL_UNUSED_CONTEXT;
3597 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3599 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3602 * fflush()ing read-only streams can cause trouble on some stdio-s
3604 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3605 if (PerlSIO_fflush(stdio) != 0)
3609 c = PerlSIO_fgetc(stdio);
3612 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3614 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3619 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3621 #ifdef STDIO_BUFFER_WRITABLE
3622 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3623 /* Fake ungetc() to the real buffer in case system's ungetc
3626 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3627 SSize_t cnt = PerlSIO_get_cnt(stdio);
3628 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3629 if (ptr == base+1) {
3630 *--ptr = (STDCHAR) c;
3631 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3632 if (PerlSIO_feof(stdio))
3633 PerlSIO_clearerr(stdio);
3639 if (PerlIO_has_cntptr(f)) {
3641 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3647 /* If buffer snoop scheme above fails fall back to
3650 if (PerlSIO_ungetc(c, stdio) != c)
3658 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3659 sizeof(PerlIO_funcs),
3661 sizeof(PerlIOStdio),
3662 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3666 PerlIOBase_binmode, /* binmode */
3680 PerlIOStdio_clearerr,
3681 PerlIOStdio_setlinebuf,
3683 PerlIOStdio_get_base,
3684 PerlIOStdio_get_bufsiz,
3689 #ifdef USE_STDIO_PTR
3690 PerlIOStdio_get_ptr,
3691 PerlIOStdio_get_cnt,
3692 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3693 PerlIOStdio_set_ptrcnt,
3696 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3701 #endif /* USE_STDIO_PTR */
3704 /* Note that calls to PerlIO_exportFILE() are reversed using
3705 * PerlIO_releaseFILE(), not importFILE. */
3707 PerlIO_exportFILE(PerlIO * f, const char *mode)
3711 if (PerlIOValid(f)) {
3713 int fd = PerlIO_fileno(f);
3718 if (!mode || !*mode) {
3719 mode = PerlIO_modestr(f, buf);
3721 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3725 /* De-link any lower layers so new :stdio sticks */
3727 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3728 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3730 PerlIOUnix_refcnt_inc(fileno(stdio));
3731 /* Link previous lower layers under new one */
3735 /* restore layers list */
3745 PerlIO_findFILE(PerlIO *f)
3750 if (l->tab == &PerlIO_stdio) {
3751 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3754 l = *PerlIONext(&l);
3756 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3757 /* However, we're not really exporting a FILE * to someone else (who
3758 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3759 So we need to undo its reference count increase on the underlying file
3760 descriptor. We have to do this, because if the loop above returns you
3761 the FILE *, then *it* didn't increase any reference count. So there's
3762 only one way to be consistent. */
3763 stdio = PerlIO_exportFILE(f, NULL);
3765 const int fd = fileno(stdio);
3767 PerlIOUnix_refcnt_dec(fd);
3772 /* Use this to reverse PerlIO_exportFILE calls. */
3774 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3778 if (l->tab == &PerlIO_stdio) {
3779 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3780 if (s->stdio == f) { /* not in a loop */
3781 const int fd = fileno(f);
3783 PerlIOUnix_refcnt_dec(fd);
3786 PerlIO_pop(aTHX_ p);
3796 /*--------------------------------------------------------------------------------------*/
3798 * perlio buffer layer
3802 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3804 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3805 const int fd = PerlIO_fileno(f);
3806 if (fd >= 0 && PerlLIO_isatty(fd)) {
3807 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3809 if (*PerlIONext(f)) {
3810 const Off_t posn = PerlIO_tell(PerlIONext(f));
3811 if (posn != (Off_t) - 1) {
3815 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3819 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3820 IV n, const char *mode, int fd, int imode, int perm,
3821 PerlIO *f, int narg, SV **args)
3823 if (PerlIOValid(f)) {
3824 PerlIO *next = PerlIONext(f);
3826 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3827 if (tab && tab->Open)
3829 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3831 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3836 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3838 if (*mode == IoTYPE_IMPLICIT) {
3844 if (tab && tab->Open)
3845 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3848 SETERRNO(EINVAL, LIB_INVARG);
3850 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3852 * if push fails during open, open fails. close will pop us.
3857 fd = PerlIO_fileno(f);
3858 if (init && fd == 2) {
3860 * Initial stderr is unbuffered
3862 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3864 #ifdef PERLIO_USING_CRLF
3865 # ifdef PERLIO_IS_BINMODE_FD
3866 if (PERLIO_IS_BINMODE_FD(fd))
3867 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3871 * do something about failing setmode()? --jhi
3873 PerlLIO_setmode(fd, O_BINARY);
3876 /* Enable line buffering with record-oriented regular files
3877 * so we don't introduce an extraneous record boundary when
3878 * the buffer fills up.
3880 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3882 if (PerlLIO_fstat(fd, &st) == 0
3883 && S_ISREG(st.st_mode)
3884 && (st.st_fab_rfm == FAB$C_VAR
3885 || st.st_fab_rfm == FAB$C_VFC)) {
3886 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3897 * This "flush" is akin to sfio's sync in that it handles files in either
3898 * read or write state. For write state, we put the postponed data through
3899 * the next layers. For read state, we seek() the next layers to the
3900 * offset given by current position in the buffer, and discard the buffer
3901 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3902 * in any case?). Then the pass the stick further in chain.
3905 PerlIOBuf_flush(pTHX_ PerlIO *f)
3907 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3909 PerlIO *n = PerlIONext(f);
3910 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3912 * write() the buffer
3914 const STDCHAR *buf = b->buf;
3915 const STDCHAR *p = buf;
3916 while (p < b->ptr) {
3917 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3921 else if (count < 0 || PerlIO_error(n)) {
3922 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3923 PerlIO_save_errno(f);
3928 b->posn += (p - buf);
3930 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3931 STDCHAR *buf = PerlIO_get_base(f);
3933 * Note position change
3935 b->posn += (b->ptr - buf);
3936 if (b->ptr < b->end) {
3937 /* We did not consume all of it - try and seek downstream to
3938 our logical position
3940 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3941 /* Reload n as some layers may pop themselves on seek */
3942 b->posn = PerlIO_tell(n = PerlIONext(f));
3945 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3946 data is lost for good - so return saying "ok" having undone
3949 b->posn -= (b->ptr - buf);
3954 b->ptr = b->end = b->buf;
3955 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3956 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3957 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3962 /* This discards the content of the buffer after b->ptr, and rereads
3963 * the buffer from the position off in the layer downstream; here off
3964 * is at offset corresponding to b->ptr - b->buf.
3967 PerlIOBuf_fill(pTHX_ PerlIO *f)
3969 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3970 PerlIO *n = PerlIONext(f);
3973 * Down-stream flush is defined not to loose read data so is harmless.
3974 * we would not normally be fill'ing if there was data left in anycase.
3976 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3978 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3979 PerlIOBase_flush_linebuf(aTHX);
3982 PerlIO_get_base(f); /* allocate via vtable */
3984 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3986 b->ptr = b->end = b->buf;
3988 if (!PerlIOValid(n)) {
3989 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3993 if (PerlIO_fast_gets(n)) {
3995 * Layer below is also buffered. We do _NOT_ want to call its
3996 * ->Read() because that will loop till it gets what we asked for
3997 * which may hang on a pipe etc. Instead take anything it has to
3998 * hand, or ask it to fill _once_.
4000 avail = PerlIO_get_cnt(n);
4002 avail = PerlIO_fill(n);
4004 avail = PerlIO_get_cnt(n);
4006 if (!PerlIO_error(n) && PerlIO_eof(n))
4011 STDCHAR *ptr = PerlIO_get_ptr(n);
4012 const SSize_t cnt = avail;
4013 if (avail > (SSize_t)b->bufsiz)
4015 Copy(ptr, b->buf, avail, STDCHAR);
4016 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4020 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4024 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4027 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4028 PerlIO_save_errno(f);
4032 b->end = b->buf + avail;
4033 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4038 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4040 if (PerlIOValid(f)) {
4041 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4044 return PerlIOBase_read(aTHX_ f, vbuf, count);
4050 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4052 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4053 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4056 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4061 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4063 * Buffer is already a read buffer, we can overwrite any chars
4064 * which have been read back to buffer start
4066 avail = (b->ptr - b->buf);
4070 * Buffer is idle, set it up so whole buffer is available for
4074 b->end = b->buf + avail;
4076 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4078 * Buffer extends _back_ from where we are now
4080 b->posn -= b->bufsiz;
4082 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4084 * If we have space for more than count, just move count
4092 * In simple stdio-like ungetc() case chars will be already
4095 if (buf != b->ptr) {
4096 Copy(buf, b->ptr, avail, STDCHAR);
4100 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4104 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4110 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4112 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4113 const STDCHAR *buf = (const STDCHAR *) vbuf;
4114 const STDCHAR *flushptr = buf;
4118 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4120 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4121 if (PerlIO_flush(f) != 0) {
4125 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4126 flushptr = buf + count;
4127 while (flushptr > buf && *(flushptr - 1) != '\n')
4131 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4132 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4134 if (flushptr > buf && flushptr <= buf + avail)
4135 avail = flushptr - buf;
4136 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4138 Copy(buf, b->ptr, avail, STDCHAR);
4143 if (buf == flushptr)
4146 if (b->ptr >= (b->buf + b->bufsiz))
4147 if (PerlIO_flush(f) == -1)
4150 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4156 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4159 if ((code = PerlIO_flush(f)) == 0) {
4160 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4161 code = PerlIO_seek(PerlIONext(f), offset, whence);
4163 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4164 b->posn = PerlIO_tell(PerlIONext(f));
4171 PerlIOBuf_tell(pTHX_ PerlIO *f)
4173 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4175 * b->posn is file position where b->buf was read, or will be written
4177 Off_t posn = b->posn;
4178 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4179 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4181 /* As O_APPEND files are normally shared in some sense it is better
4186 /* when file is NOT shared then this is sufficient */
4187 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4189 posn = b->posn = PerlIO_tell(PerlIONext(f));
4193 * If buffer is valid adjust position by amount in buffer
4195 posn += (b->ptr - b->buf);
4201 PerlIOBuf_popped(pTHX_ PerlIO *f)
4203 const IV code = PerlIOBase_popped(aTHX_ f);
4204 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4205 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4208 b->ptr = b->end = b->buf = NULL;
4209 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4214 PerlIOBuf_close(pTHX_ PerlIO *f)
4216 const IV code = PerlIOBase_close(aTHX_ f);
4217 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4218 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4221 b->ptr = b->end = b->buf = NULL;
4222 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4227 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4229 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4236 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4238 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4241 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4242 return (b->end - b->ptr);
4247 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4249 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4250 PERL_UNUSED_CONTEXT;
4254 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4255 Newxz(b->buf,b->bufsiz, STDCHAR);
4257 b->buf = (STDCHAR *) & b->oneword;
4258 b->bufsiz = sizeof(b->oneword);
4260 b->end = b->ptr = b->buf;
4266 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4268 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4271 return (b->end - b->buf);
4275 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4277 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4279 PERL_UNUSED_ARG(cnt);
4284 assert(PerlIO_get_cnt(f) == cnt);
4285 assert(b->ptr >= b->buf);
4286 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4290 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4292 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4297 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4298 sizeof(PerlIO_funcs),
4301 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4305 PerlIOBase_binmode, /* binmode */
4319 PerlIOBase_clearerr,
4320 PerlIOBase_setlinebuf,
4325 PerlIOBuf_set_ptrcnt,
4328 /*--------------------------------------------------------------------------------------*/
4330 * Temp layer to hold unread chars when cannot do it any other way
4334 PerlIOPending_fill(pTHX_ PerlIO *f)
4337 * Should never happen
4344 PerlIOPending_close(pTHX_ PerlIO *f)
4347 * A tad tricky - flush pops us, then we close new top
4350 return PerlIO_close(f);
4354 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4357 * A tad tricky - flush pops us, then we seek new top
4360 return PerlIO_seek(f, offset, whence);
4365 PerlIOPending_flush(pTHX_ PerlIO *f)
4367 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4368 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4372 PerlIO_pop(aTHX_ f);
4377 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4383 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4388 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4390 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4391 PerlIOl * const l = PerlIOBase(f);
4393 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4394 * etc. get muddled when it changes mid-string when we auto-pop.
4396 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4397 (PerlIOBase(PerlIONext(f))->
4398 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4403 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4405 SSize_t avail = PerlIO_get_cnt(f);
4407 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4410 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4411 if (got >= 0 && got < (SSize_t)count) {
4412 const SSize_t more =
4413 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4414 if (more >= 0 || got == 0)
4420 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4421 sizeof(PerlIO_funcs),
4424 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4425 PerlIOPending_pushed,
4428 PerlIOBase_binmode, /* binmode */
4437 PerlIOPending_close,
4438 PerlIOPending_flush,
4442 PerlIOBase_clearerr,
4443 PerlIOBase_setlinebuf,
4448 PerlIOPending_set_ptrcnt,
4453 /*--------------------------------------------------------------------------------------*/
4455 * crlf - translation On read translate CR,LF to "\n" we do this by
4456 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4457 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4459 * c->nl points on the first byte of CR LF pair when it is temporarily
4460 * replaced by LF, or to the last CR of the buffer. In the former case
4461 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4462 * that it ends at c->nl; these two cases can be distinguished by
4463 * *c->nl. c->nl is set during _getcnt() call, and unset during
4464 * _unread() and _flush() calls.
4465 * It only matters for read operations.
4469 PerlIOBuf base; /* PerlIOBuf stuff */
4470 STDCHAR *nl; /* Position of crlf we "lied" about in the
4474 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4475 * Otherwise the :crlf layer would always revert back to
4479 S_inherit_utf8_flag(PerlIO *f)
4481 PerlIO *g = PerlIONext(f);
4482 if (PerlIOValid(g)) {
4483 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4484 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4490 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4493 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4494 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4496 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4497 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4498 PerlIOBase(f)->flags);
4501 /* If the old top layer is a CRLF layer, reactivate it (if
4502 * necessary) and remove this new layer from the stack */
4503 PerlIO *g = PerlIONext(f);
4504 if (PerlIOValid(g)) {
4505 PerlIOl *b = PerlIOBase(g);
4506 if (b && b->tab == &PerlIO_crlf) {
4507 if (!(b->flags & PERLIO_F_CRLF))
4508 b->flags |= PERLIO_F_CRLF;
4509 S_inherit_utf8_flag(g);
4510 PerlIO_pop(aTHX_ f);
4515 S_inherit_utf8_flag(f);
4521 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4523 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4524 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4525 *(c->nl) = NATIVE_0xd;
4528 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4529 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4531 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4532 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4534 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4539 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4540 b->end = b->ptr = b->buf + b->bufsiz;
4541 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4542 b->posn -= b->bufsiz;
4544 while (count > 0 && b->ptr > b->buf) {
4545 const int ch = *--buf;
4547 if (b->ptr - 2 >= b->buf) {
4548 *--(b->ptr) = NATIVE_0xa;
4549 *--(b->ptr) = NATIVE_0xd;
4554 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4555 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4569 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4574 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4576 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4578 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4581 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4582 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4583 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4584 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4586 while (nl < b->end && *nl != NATIVE_0xd)
4588 if (nl < b->end && *nl == NATIVE_0xd) {
4590 if (nl + 1 < b->end) {
4591 if (nl[1] == NATIVE_0xa) {
4597 * Not CR,LF but just CR
4605 * Blast - found CR as last char in buffer
4610 * They may not care, defer work as long as
4614 return (nl - b->ptr);
4618 b->ptr++; /* say we have read it as far as
4619 * flush() is concerned */
4620 b->buf++; /* Leave space in front of buffer */
4621 /* Note as we have moved buf up flush's
4623 will naturally make posn point at CR
4625 b->bufsiz--; /* Buffer is thus smaller */
4626 code = PerlIO_fill(f); /* Fetch some more */
4627 b->bufsiz++; /* Restore size for next time */
4628 b->buf--; /* Point at space */
4629 b->ptr = nl = b->buf; /* Which is what we hand
4631 *nl = NATIVE_0xd; /* Fill in the CR */
4633 goto test; /* fill() call worked */
4635 * CR at EOF - just fall through
4637 /* Should we clear EOF though ??? */
4642 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4648 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4650 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4651 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4657 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4658 /* Deferred CR at end of buffer case - we lied about count */
4671 * Test code - delete when it works ...
4673 IV flags = PerlIOBase(f)->flags;
4674 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4675 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4676 /* Deferred CR at end of buffer case - we lied about count */
4682 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4683 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4684 flags, c->nl, b->end, cnt);
4691 * They have taken what we lied about
4693 *(c->nl) = NATIVE_0xd;
4699 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4703 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4705 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4706 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4708 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4709 const STDCHAR *buf = (const STDCHAR *) vbuf;
4710 const STDCHAR * const ebuf = buf + count;
4713 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4715 while (buf < ebuf) {
4716 const STDCHAR * const eptr = b->buf + b->bufsiz;
4717 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4718 while (buf < ebuf && b->ptr < eptr) {
4720 if ((b->ptr + 2) > eptr) {
4728 *(b->ptr)++ = NATIVE_0xd; /* CR */
4729 *(b->ptr)++ = NATIVE_0xa; /* LF */
4731 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4738 *(b->ptr)++ = *buf++;
4740 if (b->ptr >= eptr) {
4746 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4748 return (buf - (STDCHAR *) vbuf);
4753 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4755 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4757 *(c->nl) = NATIVE_0xd;
4760 return PerlIOBuf_flush(aTHX_ f);
4764 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4766 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4767 /* In text mode - flush any pending stuff and flip it */
4768 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4769 #ifndef PERLIO_USING_CRLF
4770 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4771 PerlIO_pop(aTHX_ f);
4777 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4778 sizeof(PerlIO_funcs),
4781 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4783 PerlIOBuf_popped, /* popped */
4785 PerlIOCrlf_binmode, /* binmode */
4789 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4790 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4791 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4799 PerlIOBase_clearerr,
4800 PerlIOBase_setlinebuf,
4805 PerlIOCrlf_set_ptrcnt,
4809 Perl_PerlIO_stdin(pTHX)
4812 PerlIO_stdstreams(aTHX);
4814 return (PerlIO*)&PL_perlio[1];
4818 Perl_PerlIO_stdout(pTHX)
4821 PerlIO_stdstreams(aTHX);
4823 return (PerlIO*)&PL_perlio[2];
4827 Perl_PerlIO_stderr(pTHX)
4830 PerlIO_stdstreams(aTHX);
4832 return (PerlIO*)&PL_perlio[3];
4835 /*--------------------------------------------------------------------------------------*/
4838 PerlIO_getname(PerlIO *f, char *buf)
4843 bool exported = FALSE;
4844 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4846 stdio = PerlIO_exportFILE(f,0);
4850 name = fgetname(stdio, buf);
4851 if (exported) PerlIO_releaseFILE(f,stdio);
4856 PERL_UNUSED_ARG(buf);
4857 Perl_croak_nocontext("Don't know how to get file name");
4863 /*--------------------------------------------------------------------------------------*/
4865 * Functions which can be called on any kind of PerlIO implemented in
4869 #undef PerlIO_fdopen
4871 PerlIO_fdopen(int fd, const char *mode)
4874 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4879 PerlIO_open(const char *path, const char *mode)
4882 SV *name = sv_2mortal(newSVpv(path, 0));
4883 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4886 #undef Perlio_reopen
4888 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4891 SV *name = sv_2mortal(newSVpv(path,0));
4892 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4897 PerlIO_getc(PerlIO *f)
4901 if ( 1 == PerlIO_read(f, buf, 1) ) {
4902 return (unsigned char) buf[0];
4907 #undef PerlIO_ungetc
4909 PerlIO_ungetc(PerlIO *f, int ch)
4914 if (PerlIO_unread(f, &buf, 1) == 1)
4922 PerlIO_putc(PerlIO *f, int ch)
4926 return PerlIO_write(f, &buf, 1);
4931 PerlIO_puts(PerlIO *f, const char *s)
4934 return PerlIO_write(f, s, strlen(s));
4937 #undef PerlIO_rewind
4939 PerlIO_rewind(PerlIO *f)
4942 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4946 #undef PerlIO_vprintf
4948 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4957 Perl_va_copy(ap, apc);
4958 sv = vnewSVpvf(fmt, &apc);
4961 sv = vnewSVpvf(fmt, &ap);
4963 s = SvPV_const(sv, len);
4964 wrote = PerlIO_write(f, s, len);
4969 #undef PerlIO_printf
4971 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4976 result = PerlIO_vprintf(f, fmt, ap);
4981 #undef PerlIO_stdoutf
4983 PerlIO_stdoutf(const char *fmt, ...)
4989 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4994 #undef PerlIO_tmpfile
4996 PerlIO_tmpfile(void)
5003 const int fd = win32_tmpfd();
5005 f = PerlIO_fdopen(fd, "w+b");
5007 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5009 char tempname[] = "/tmp/PerlIO_XXXXXX";
5010 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5012 int old_umask = umask(0177);
5014 * I have no idea how portable mkstemp() is ... NI-S
5016 if (tmpdir && *tmpdir) {
5017 /* if TMPDIR is set and not empty, we try that first */
5018 sv = newSVpv(tmpdir, 0);
5019 sv_catpv(sv, tempname + 4);
5020 fd = mkstemp(SvPVX(sv));
5025 /* else we try /tmp */
5026 fd = mkstemp(tempname);
5031 sv_catpv(sv, tempname + 4);
5032 fd = mkstemp(SvPVX(sv));
5036 f = PerlIO_fdopen(fd, "w+");
5038 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5039 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5042 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5043 FILE * const stdio = PerlSIO_tmpfile();
5046 f = PerlIO_fdopen(fileno(stdio), "w+");
5048 # endif /* else HAS_MKSTEMP */
5049 #endif /* else WIN32 */
5054 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5056 if (!PerlIOValid(f))
5058 PerlIOBase(f)->err = errno;
5060 PerlIOBase(f)->os_err = vaxc$errno;
5062 PerlIOBase(f)->os_err = Perl_rc;
5063 #elif defined(WIN32)
5064 PerlIOBase(f)->os_err = GetLastError();
5069 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5071 if (!PerlIOValid(f))
5073 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5075 Perl_rc = PerlIOBase(f)->os_err);
5076 #elif defined(WIN32)
5077 SetLastError(PerlIOBase(f)->os_err);
5085 /*======================================================================================*/
5087 * Now some functions in terms of above which may be needed even if we are
5088 * not in true PerlIO mode
5091 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5093 const char *direction = NULL;
5096 * Need to supply default layer info from open.pm
5102 if (mode && mode[0] != 'r') {
5103 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5104 direction = "open>";
5106 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5107 direction = "open<";
5112 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5115 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5120 #undef PerlIO_setpos
5122 PerlIO_setpos(PerlIO *f, SV *pos)
5128 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5129 if(len == sizeof(Off_t))
5130 return PerlIO_seek(f, *posn, SEEK_SET);
5133 SETERRNO(EINVAL, SS_IVCHAN);
5137 #undef PerlIO_setpos
5139 PerlIO_setpos(PerlIO *f, SV *pos)
5145 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5146 if(len == sizeof(Fpos_t))
5147 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5148 return fsetpos64(f, fpos);
5150 return fsetpos(f, fpos);
5154 SETERRNO(EINVAL, SS_IVCHAN);
5160 #undef PerlIO_getpos
5162 PerlIO_getpos(PerlIO *f, SV *pos)
5165 Off_t posn = PerlIO_tell(f);
5166 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5167 return (posn == (Off_t) - 1) ? -1 : 0;
5170 #undef PerlIO_getpos
5172 PerlIO_getpos(PerlIO *f, SV *pos)
5177 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5178 code = fgetpos64(f, &fpos);
5180 code = fgetpos(f, &fpos);
5182 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5187 #if !defined(HAS_VPRINTF)
5190 vprintf(char *pat, char *args)
5192 _doprnt(pat, args, stdout);
5193 return 0; /* wrong, but perl doesn't use the return
5198 vfprintf(FILE *fd, char *pat, char *args)
5200 _doprnt(pat, args, fd);
5201 return 0; /* wrong, but perl doesn't use the return
5207 /* print a failure format string message to stderr and fail exit the process
5208 using only libc without depending on any perl data structures being
5213 Perl_noperl_die(const char* pat, ...)
5216 PERL_ARGS_ASSERT_NOPERL_DIE;
5217 va_start(arglist, pat);
5218 vfprintf(stderr, pat, arglist);
5224 * ex: set ts=8 sts=4 sw=4 et: