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 #ifdef PERLIO_IS_STDIO
348 * Does nothing (yet) except force this file to be included in perl
349 * binary. That allows this file to force inclusion of other functions
350 * that may be required by loadable extensions e.g. for
351 * FileHandle::tmpfile
355 #undef PerlIO_tmpfile
362 #else /* PERLIO_IS_STDIO */
364 /*======================================================================================*/
366 * Implement all the PerlIO interface ourselves.
372 PerlIO_debug(const char *fmt, ...)
377 if (!PL_perlio_debug_fd) {
379 PerlProc_getuid() == PerlProc_geteuid() &&
380 PerlProc_getgid() == PerlProc_getegid()) {
381 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
384 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
386 PL_perlio_debug_fd = -1;
388 /* tainting or set*id, so ignore the environment, and ensure we
389 skip these tests next time through. */
390 PL_perlio_debug_fd = -1;
393 if (PL_perlio_debug_fd > 0) {
395 const char * const s = CopFILE(PL_curcop);
396 /* Use fixed buffer as sv_catpvf etc. needs SVs */
398 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
399 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
400 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
402 const char *s = CopFILE(PL_curcop);
404 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
405 (IV) CopLINE(PL_curcop));
406 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
408 s = SvPV_const(sv, len);
409 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
416 /*--------------------------------------------------------------------------------------*/
419 * Inner level routines
422 /* check that the head field of each layer points back to the head */
425 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
427 PerlIO_verify_head(pTHX_ PerlIO *f)
431 #ifndef PERL_IMPLICIT_SYS
436 p = head = PerlIOBase(f)->head;
439 assert(p->head == head);
440 if (p == (PerlIOl*)f)
447 # define VERIFY_HEAD(f)
452 * Table of pointers to the PerlIO structs (malloc'ed)
454 #define PERLIO_TABLE_SIZE 64
457 PerlIO_init_table(pTHX)
461 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
467 PerlIO_allocate(pTHX)
470 * Find a free slot in the table, allocating new table as necessary
475 while ((f = *last)) {
477 last = (PerlIOl **) (f);
478 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
479 if (!((++f)->next)) {
484 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
488 *last = (PerlIOl*) f++;
491 f->flags = 0; /* lockcnt */
497 #undef PerlIO_fdupopen
499 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
501 if (PerlIOValid(f)) {
502 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
503 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
505 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
507 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
511 SETERRNO(EBADF, SS_IVCHAN);
517 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
519 PerlIOl * const table = *tablep;
522 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
523 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
524 PerlIOl * const f = table + i;
526 PerlIO_close(&(f->next));
536 PerlIO_list_alloc(pTHX)
540 Newxz(list, 1, PerlIO_list_t);
546 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
549 if (--list->refcnt == 0) {
552 for (i = 0; i < list->cur; i++)
553 SvREFCNT_dec(list->array[i].arg);
554 Safefree(list->array);
562 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
567 if (list->cur >= list->len) {
570 Renew(list->array, list->len, PerlIO_pair_t);
572 Newx(list->array, list->len, PerlIO_pair_t);
574 p = &(list->array[list->cur++]);
576 if ((p->arg = arg)) {
577 SvREFCNT_inc_simple_void_NN(arg);
582 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
584 PerlIO_list_t *list = NULL;
587 list = PerlIO_list_alloc(aTHX);
588 for (i=0; i < proto->cur; i++) {
589 SV *arg = proto->array[i].arg;
592 arg = sv_dup(arg, param);
594 PERL_UNUSED_ARG(param);
596 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
603 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
606 PerlIOl **table = &proto->Iperlio;
609 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
610 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
611 PerlIO_init_table(aTHX);
612 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
613 while ((f = *table)) {
615 table = (PerlIOl **) (f++);
616 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
618 (void) fp_dup(&(f->next), 0, param);
625 PERL_UNUSED_ARG(proto);
626 PERL_UNUSED_ARG(param);
631 PerlIO_destruct(pTHX)
633 PerlIOl **table = &PL_perlio;
636 PerlIO_debug("Destruct %p\n",(void*)aTHX);
638 while ((f = *table)) {
640 table = (PerlIOl **) (f++);
641 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
642 PerlIO *x = &(f->next);
645 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
646 PerlIO_debug("Destruct popping %s\n", l->tab->name);
660 PerlIO_pop(pTHX_ PerlIO *f)
662 const PerlIOl *l = *f;
665 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
666 l->tab ? l->tab->name : "(Null)");
667 if (l->tab && l->tab->Popped) {
669 * If popped returns non-zero do not free its layer structure
670 * it has either done so itself, or it is shared and still in
673 if ((*l->tab->Popped) (aTHX_ f) != 0)
676 if (PerlIO_lockcnt(f)) {
677 /* we're in use; defer freeing the structure */
678 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
679 PerlIOBase(f)->tab = NULL;
689 /* Return as an array the stack of layers on a filehandle. Note that
690 * the stack is returned top-first in the array, and there are three
691 * times as many array elements as there are layers in the stack: the
692 * first element of a layer triplet is the name, the second one is the
693 * arguments, and the third one is the flags. */
696 PerlIO_get_layers(pTHX_ PerlIO *f)
698 AV * const av = newAV();
700 if (PerlIOValid(f)) {
701 PerlIOl *l = PerlIOBase(f);
704 /* There is some collusion in the implementation of
705 XS_PerlIO_get_layers - it knows that name and flags are
706 generated as fresh SVs here, and takes advantage of that to
707 "copy" them by taking a reference. If it changes here, it needs
708 to change there too. */
709 SV * const name = l->tab && l->tab->name ?
710 newSVpv(l->tab->name, 0) : &PL_sv_undef;
711 SV * const arg = l->tab && l->tab->Getarg ?
712 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
715 av_push(av, newSViv((IV)l->flags));
723 /*--------------------------------------------------------------------------------------*/
725 * XS Interface for perl code
729 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
733 if ((SSize_t) len <= 0)
735 for (i = 0; i < PL_known_layers->cur; i++) {
736 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
737 const STRLEN this_len = strlen(f->name);
738 if (this_len == len && memEQ(f->name, name, len)) {
739 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
743 if (load && PL_subname && PL_def_layerlist
744 && PL_def_layerlist->cur >= 2) {
745 if (PL_in_load_module) {
746 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
749 SV * const pkgsv = newSVpvs("PerlIO");
750 SV * const layer = newSVpvn(name, len);
751 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
753 SAVEBOOL(PL_in_load_module);
755 SAVEGENERICSV(PL_warnhook);
756 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
758 PL_in_load_module = TRUE;
760 * The two SVs are magically freed by load_module
762 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
764 return PerlIO_find_layer(aTHX_ name, len, 0);
767 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
771 #ifdef USE_ATTRIBUTES_FOR_PERLIO
774 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
777 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
778 PerlIO * const ifp = IoIFP(io);
779 PerlIO * const ofp = IoOFP(io);
780 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
781 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
787 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
790 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
791 PerlIO * const ifp = IoIFP(io);
792 PerlIO * const ofp = IoOFP(io);
793 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
794 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
800 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
802 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
807 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
809 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
813 MGVTBL perlio_vtab = {
821 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
822 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
825 SV * const sv = SvRV(ST(1));
826 AV * const av = newAV();
830 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
832 mg = mg_find(sv, PERL_MAGIC_ext);
833 mg->mg_virtual = &perlio_vtab;
835 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
836 for (i = 2; i < items; i++) {
838 const char * const name = SvPV_const(ST(i), len);
839 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
841 av_push(av, SvREFCNT_inc_simple_NN(layer));
852 #endif /* USE_ATTIBUTES_FOR_PERLIO */
855 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
857 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
858 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
862 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
863 XS(XS_PerlIO__Layer__NoWarnings)
865 /* This is used as a %SIG{__WARN__} handler to suppress warnings
866 during loading of layers.
871 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
875 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
876 XS(XS_PerlIO__Layer__find)
881 Perl_croak(aTHX_ "Usage class->find(name[,load])");
884 const char * const name = SvPV_const(ST(1), len);
885 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
886 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
888 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
895 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
897 if (!PL_known_layers)
898 PL_known_layers = PerlIO_list_alloc(aTHX);
899 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
900 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
904 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
907 const char *s = names;
909 while (isSPACE(*s) || *s == ':')
914 const char *as = NULL;
916 if (!isIDFIRST(*s)) {
918 * Message is consistent with how attribute lists are
919 * passed. Even though this means "foo : : bar" is
920 * seen as an invalid separator character.
922 const char q = ((*s == '\'') ? '"' : '\'');
923 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
924 "Invalid separator character %c%c%c in PerlIO layer specification %s",
926 SETERRNO(EINVAL, LIB_INVARG);
931 } while (isWORDCHAR(*e));
947 * It's a nul terminated string, not allowed
948 * to \ the terminating null. Anything other
949 * character is passed over.
959 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
960 "Argument list not closed for PerlIO layer \"%.*s\"",
972 PerlIO_funcs * const layer =
973 PerlIO_find_layer(aTHX_ s, llen, 1);
977 arg = newSVpvn(as, alen);
978 PerlIO_list_push(aTHX_ av, layer,
979 (arg) ? arg : &PL_sv_undef);
983 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
996 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
998 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
999 #ifdef PERLIO_USING_CRLF
1002 if (PerlIO_stdio.Set_ptrcnt)
1003 tab = &PerlIO_stdio;
1005 PerlIO_debug("Pushing %s\n", tab->name);
1006 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
1010 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1012 return av->array[n].arg;
1016 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1018 if (n >= 0 && n < av->cur) {
1019 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1020 av->array[n].funcs->name);
1021 return av->array[n].funcs;
1024 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1029 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1031 PERL_UNUSED_ARG(mode);
1032 PERL_UNUSED_ARG(arg);
1033 PERL_UNUSED_ARG(tab);
1034 if (PerlIOValid(f)) {
1036 PerlIO_pop(aTHX_ f);
1042 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1043 sizeof(PerlIO_funcs),
1046 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1066 NULL, /* get_base */
1067 NULL, /* get_bufsiz */
1070 NULL, /* set_ptrcnt */
1074 PerlIO_default_layers(pTHX)
1076 if (!PL_def_layerlist) {
1077 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1078 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1079 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1080 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1082 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1084 osLayer = &PerlIO_win32;
1087 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1088 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1089 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1090 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1091 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1092 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1093 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1094 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1097 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1100 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1103 if (PL_def_layerlist->cur < 2) {
1104 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1106 return PL_def_layerlist;
1110 Perl_boot_core_PerlIO(pTHX)
1112 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1113 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1116 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1117 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1121 PerlIO_default_layer(pTHX_ I32 n)
1123 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1126 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1129 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1130 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1133 PerlIO_stdstreams(pTHX)
1136 PerlIO_init_table(aTHX);
1137 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1138 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1139 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1144 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1147 if (tab->fsize != sizeof(PerlIO_funcs)) {
1149 "%s (%"UVuf") does not match %s (%"UVuf")",
1150 "PerlIO layer function table size", (UV)tab->fsize,
1151 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1155 if (tab->size < sizeof(PerlIOl)) {
1157 "%s (%"UVuf") smaller than %s (%"UVuf")",
1158 "PerlIO layer instance size", (UV)tab->size,
1159 "size expected by this perl", (UV)sizeof(PerlIOl) );
1161 /* Real layer with a data area */
1164 Newxz(temp, tab->size, char);
1168 l->tab = (PerlIO_funcs*) tab;
1169 l->head = ((PerlIOl*)f)->head;
1171 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1172 (void*)f, tab->name,
1173 (mode) ? mode : "(Null)", (void*)arg);
1174 if (*l->tab->Pushed &&
1176 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1177 PerlIO_pop(aTHX_ f);
1186 /* Pseudo-layer where push does its own stack adjust */
1187 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1188 (mode) ? mode : "(Null)", (void*)arg);
1190 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1198 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1199 IV n, const char *mode, int fd, int imode, int perm,
1200 PerlIO *old, int narg, SV **args)
1202 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1203 if (tab && tab->Open) {
1204 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1205 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1211 SETERRNO(EINVAL, LIB_INVARG);
1216 PerlIOBase_binmode(pTHX_ PerlIO *f)
1218 if (PerlIOValid(f)) {
1219 /* Is layer suitable for raw stream ? */
1220 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1221 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1222 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1225 /* Not suitable - pop it */
1226 PerlIO_pop(aTHX_ f);
1234 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1236 PERL_UNUSED_ARG(mode);
1237 PERL_UNUSED_ARG(arg);
1238 PERL_UNUSED_ARG(tab);
1240 if (PerlIOValid(f)) {
1245 * Strip all layers that are not suitable for a raw stream
1248 while (t && (l = *t)) {
1249 if (l->tab && l->tab->Binmode) {
1250 /* Has a handler - normal case */
1251 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1253 /* Layer still there - move down a layer */
1262 /* No handler - pop it */
1263 PerlIO_pop(aTHX_ t);
1266 if (PerlIOValid(f)) {
1267 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1268 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1276 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1277 PerlIO_list_t *layers, IV n, IV max)
1281 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1283 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1294 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1298 save_scalar(PL_errgv);
1300 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1301 code = PerlIO_parse_layers(aTHX_ layers, names);
1303 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1305 PerlIO_list_free(aTHX_ layers);
1312 /*--------------------------------------------------------------------------------------*/
1314 * Given the abstraction above the public API functions
1318 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1320 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1321 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1322 PerlIOBase(f)->tab->name : "(Null)",
1323 iotype, mode, (names) ? names : "(Null)");
1326 /* Do not flush etc. if (e.g.) switching encodings.
1327 if a pushed layer knows it needs to flush lower layers
1328 (for example :unix which is never going to call them)
1329 it can do the flush when it is pushed.
1331 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1334 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1335 #ifdef PERLIO_USING_CRLF
1336 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1337 O_BINARY so we can look for it in mode.
1339 if (!(mode & O_BINARY)) {
1341 /* FIXME?: Looking down the layer stack seems wrong,
1342 but is a way of reaching past (say) an encoding layer
1343 to flip CRLF-ness of the layer(s) below
1346 /* Perhaps we should turn on bottom-most aware layer
1347 e.g. Ilya's idea that UNIX TTY could serve
1349 if (PerlIOBase(f)->tab &&
1350 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1352 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1353 /* Not in text mode - flush any pending stuff and flip it */
1355 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1357 /* Only need to turn it on in one layer so we are done */
1362 /* Not finding a CRLF aware layer presumably means we are binary
1363 which is not what was requested - so we failed
1364 We _could_ push :crlf layer but so could caller
1369 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1370 So code that used to be here is now in PerlIORaw_pushed().
1372 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1377 PerlIO__close(pTHX_ PerlIO *f)
1379 if (PerlIOValid(f)) {
1380 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1381 if (tab && tab->Close)
1382 return (*tab->Close)(aTHX_ f);
1384 return PerlIOBase_close(aTHX_ f);
1387 SETERRNO(EBADF, SS_IVCHAN);
1393 Perl_PerlIO_close(pTHX_ PerlIO *f)
1395 const int code = PerlIO__close(aTHX_ f);
1396 while (PerlIOValid(f)) {
1397 PerlIO_pop(aTHX_ f);
1398 if (PerlIO_lockcnt(f))
1399 /* we're in use; the 'pop' deferred freeing the structure */
1406 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1408 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1412 static PerlIO_funcs *
1413 PerlIO_layer_from_ref(pTHX_ SV *sv)
1416 * For any scalar type load the handler which is bundled with perl
1418 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1419 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1420 /* This isn't supposed to happen, since PerlIO::scalar is core,
1421 * but could happen anyway in smaller installs or with PAR */
1423 /* diag_listed_as: Unknown PerlIO layer "%s" */
1424 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1429 * For other types allow if layer is known but don't try and load it
1431 switch (SvTYPE(sv)) {
1433 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1435 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1437 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1439 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1446 PerlIO_resolve_layers(pTHX_ const char *layers,
1447 const char *mode, int narg, SV **args)
1449 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1452 PerlIO_stdstreams(aTHX);
1454 SV * const arg = *args;
1456 * If it is a reference but not an object see if we have a handler
1459 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1460 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1462 def = PerlIO_list_alloc(aTHX);
1463 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1467 * Don't fail if handler cannot be found :via(...) etc. may do
1468 * something sensible else we will just stringfy and open
1473 if (!layers || !*layers)
1474 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1475 if (layers && *layers) {
1478 av = PerlIO_clone_list(aTHX_ def, NULL);
1483 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1487 PerlIO_list_free(aTHX_ av);
1499 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1500 int imode, int perm, PerlIO *f, int narg, SV **args)
1502 if (!f && narg == 1 && *args == &PL_sv_undef) {
1503 if ((f = PerlIO_tmpfile())) {
1504 if (!layers || !*layers)
1505 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1506 if (layers && *layers)
1507 PerlIO_apply_layers(aTHX_ f, mode, layers);
1511 PerlIO_list_t *layera;
1513 PerlIO_funcs *tab = NULL;
1514 if (PerlIOValid(f)) {
1516 * This is "reopen" - it is not tested as perl does not use it
1520 layera = PerlIO_list_alloc(aTHX);
1523 if (l->tab && l->tab->Getarg)
1524 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1525 PerlIO_list_push(aTHX_ layera, l->tab,
1526 (arg) ? arg : &PL_sv_undef);
1528 l = *PerlIONext(&l);
1532 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1538 * Start at "top" of layer stack
1540 n = layera->cur - 1;
1542 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1551 * Found that layer 'n' can do opens - call it
1553 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1554 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1556 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1557 tab->name, layers ? layers : "(Null)", mode, fd,
1558 imode, perm, (void*)f, narg, (void*)args);
1560 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1563 SETERRNO(EINVAL, LIB_INVARG);
1567 if (n + 1 < layera->cur) {
1569 * More layers above the one that we used to open -
1572 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1573 /* If pushing layers fails close the file */
1580 PerlIO_list_free(aTHX_ layera);
1587 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1589 PERL_ARGS_ASSERT_PERLIO_READ;
1591 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1595 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1597 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1599 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1603 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1605 PERL_ARGS_ASSERT_PERLIO_WRITE;
1607 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1611 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1613 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1617 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1619 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1623 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1627 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1629 if (tab && tab->Flush)
1630 return (*tab->Flush) (aTHX_ f);
1632 return 0; /* If no Flush defined, silently succeed. */
1635 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1636 SETERRNO(EBADF, SS_IVCHAN);
1642 * Is it good API design to do flush-all on NULL, a potentially
1643 * erroneous input? Maybe some magical value (PerlIO*
1644 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1645 * things on fflush(NULL), but should we be bound by their design
1648 PerlIOl **table = &PL_perlio;
1651 while ((ff = *table)) {
1653 table = (PerlIOl **) (ff++);
1654 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1655 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1665 PerlIOBase_flush_linebuf(pTHX)
1667 PerlIOl **table = &PL_perlio;
1669 while ((f = *table)) {
1671 table = (PerlIOl **) (f++);
1672 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1674 && (PerlIOBase(&(f->next))->
1675 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1676 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1677 PerlIO_flush(&(f->next));
1684 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1686 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1690 PerlIO_isutf8(PerlIO *f)
1693 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1695 SETERRNO(EBADF, SS_IVCHAN);
1701 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1703 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1707 Perl_PerlIO_error(pTHX_ PerlIO *f)
1709 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1713 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1715 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1719 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1721 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1725 PerlIO_has_base(PerlIO *f)
1727 if (PerlIOValid(f)) {
1728 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1731 return (tab->Get_base != NULL);
1738 PerlIO_fast_gets(PerlIO *f)
1740 if (PerlIOValid(f)) {
1741 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1742 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1745 return (tab->Set_ptrcnt != NULL);
1753 PerlIO_has_cntptr(PerlIO *f)
1755 if (PerlIOValid(f)) {
1756 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1759 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1766 PerlIO_canset_cnt(PerlIO *f)
1768 if (PerlIOValid(f)) {
1769 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1772 return (tab->Set_ptrcnt != NULL);
1779 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1781 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1785 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1787 /* Note that Get_bufsiz returns a Size_t */
1788 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1792 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1794 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1798 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1800 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1804 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1806 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1810 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1812 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1816 /*--------------------------------------------------------------------------------------*/
1818 * utf8 and raw dummy layers
1822 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1824 PERL_UNUSED_CONTEXT;
1825 PERL_UNUSED_ARG(mode);
1826 PERL_UNUSED_ARG(arg);
1827 if (PerlIOValid(f)) {
1828 if (tab && tab->kind & PERLIO_K_UTF8)
1829 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1831 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1837 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1838 sizeof(PerlIO_funcs),
1841 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1861 NULL, /* get_base */
1862 NULL, /* get_bufsiz */
1865 NULL, /* set_ptrcnt */
1868 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1869 sizeof(PerlIO_funcs),
1872 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1892 NULL, /* get_base */
1893 NULL, /* get_bufsiz */
1896 NULL, /* set_ptrcnt */
1899 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1900 sizeof(PerlIO_funcs),
1923 NULL, /* get_base */
1924 NULL, /* get_bufsiz */
1927 NULL, /* set_ptrcnt */
1929 /*--------------------------------------------------------------------------------------*/
1930 /*--------------------------------------------------------------------------------------*/
1932 * "Methods" of the "base class"
1936 PerlIOBase_fileno(pTHX_ PerlIO *f)
1938 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1942 PerlIO_modestr(PerlIO * f, char *buf)
1945 if (PerlIOValid(f)) {
1946 const IV flags = PerlIOBase(f)->flags;
1947 if (flags & PERLIO_F_APPEND) {
1949 if (flags & PERLIO_F_CANREAD) {
1953 else if (flags & PERLIO_F_CANREAD) {
1955 if (flags & PERLIO_F_CANWRITE)
1958 else if (flags & PERLIO_F_CANWRITE) {
1960 if (flags & PERLIO_F_CANREAD) {
1964 #ifdef PERLIO_USING_CRLF
1965 if (!(flags & PERLIO_F_CRLF))
1975 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1977 PerlIOl * const l = PerlIOBase(f);
1978 PERL_UNUSED_CONTEXT;
1979 PERL_UNUSED_ARG(arg);
1981 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1982 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1983 if (tab && tab->Set_ptrcnt != NULL)
1984 l->flags |= PERLIO_F_FASTGETS;
1986 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1990 l->flags |= PERLIO_F_CANREAD;
1993 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1996 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1999 SETERRNO(EINVAL, LIB_INVARG);
2005 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2008 l->flags &= ~PERLIO_F_CRLF;
2011 l->flags |= PERLIO_F_CRLF;
2014 SETERRNO(EINVAL, LIB_INVARG);
2021 l->flags |= l->next->flags &
2022 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2027 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2028 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2029 l->flags, PerlIO_modestr(f, temp));
2035 PerlIOBase_popped(pTHX_ PerlIO *f)
2037 PERL_UNUSED_CONTEXT;
2043 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2046 * Save the position as current head considers it
2048 const Off_t old = PerlIO_tell(f);
2049 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2050 PerlIOSelf(f, PerlIOBuf)->posn = old;
2051 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2055 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2057 STDCHAR *buf = (STDCHAR *) vbuf;
2059 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2060 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2061 SETERRNO(EBADF, SS_IVCHAN);
2062 PerlIO_save_errno(f);
2068 SSize_t avail = PerlIO_get_cnt(f);
2071 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2073 STDCHAR *ptr = PerlIO_get_ptr(f);
2074 Copy(ptr, buf, take, STDCHAR);
2075 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2078 if (avail == 0) /* set_ptrcnt could have reset avail */
2081 if (count > 0 && avail <= 0) {
2082 if (PerlIO_fill(f) != 0)
2087 return (buf - (STDCHAR *) vbuf);
2093 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2095 PERL_UNUSED_CONTEXT;
2101 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2103 PERL_UNUSED_CONTEXT;
2109 PerlIOBase_close(pTHX_ PerlIO *f)
2112 if (PerlIOValid(f)) {
2113 PerlIO *n = PerlIONext(f);
2114 code = PerlIO_flush(f);
2115 PerlIOBase(f)->flags &=
2116 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2117 while (PerlIOValid(n)) {
2118 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2119 if (tab && tab->Close) {
2120 if ((*tab->Close)(aTHX_ n) != 0)
2125 PerlIOBase(n)->flags &=
2126 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2132 SETERRNO(EBADF, SS_IVCHAN);
2138 PerlIOBase_eof(pTHX_ PerlIO *f)
2140 PERL_UNUSED_CONTEXT;
2141 if (PerlIOValid(f)) {
2142 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2148 PerlIOBase_error(pTHX_ PerlIO *f)
2150 PERL_UNUSED_CONTEXT;
2151 if (PerlIOValid(f)) {
2152 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2158 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2160 if (PerlIOValid(f)) {
2161 PerlIO * const n = PerlIONext(f);
2162 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2169 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2171 PERL_UNUSED_CONTEXT;
2172 if (PerlIOValid(f)) {
2173 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2178 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2184 arg = sv_dup(arg, param);
2185 SvREFCNT_inc_simple_void_NN(arg);
2189 return newSVsv(arg);
2192 PERL_UNUSED_ARG(param);
2193 return newSVsv(arg);
2198 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2200 PerlIO * const nexto = PerlIONext(o);
2201 if (PerlIOValid(nexto)) {
2202 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2203 if (tab && tab->Dup)
2204 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2206 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2209 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2213 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2214 self ? self->name : "(Null)",
2215 (void*)f, (void*)o, (void*)param);
2216 if (self && self->Getarg)
2217 arg = (*self->Getarg)(aTHX_ o, param, flags);
2218 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2219 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2220 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2226 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2228 /* Must be called with PL_perlio_mutex locked. */
2230 S_more_refcounted_fds(pTHX_ const int new_fd) {
2232 const int old_max = PL_perlio_fd_refcnt_size;
2233 const int new_max = 16 + (new_fd & ~15);
2236 #ifndef PERL_IMPLICIT_SYS
2237 PERL_UNUSED_CONTEXT;
2240 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2241 old_max, new_fd, new_max);
2243 if (new_fd < old_max) {
2247 assert (new_max > new_fd);
2249 /* Use plain realloc() since we need this memory to be really
2250 * global and visible to all the interpreters and/or threads. */
2251 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2255 MUTEX_UNLOCK(&PL_perlio_mutex);
2260 PL_perlio_fd_refcnt_size = new_max;
2261 PL_perlio_fd_refcnt = new_array;
2263 PerlIO_debug("Zeroing %p, %d\n",
2264 (void*)(new_array + old_max),
2267 Zero(new_array + old_max, new_max - old_max, int);
2274 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2275 PERL_UNUSED_CONTEXT;
2279 PerlIOUnix_refcnt_inc(int fd)
2286 MUTEX_LOCK(&PL_perlio_mutex);
2288 if (fd >= PL_perlio_fd_refcnt_size)
2289 S_more_refcounted_fds(aTHX_ fd);
2291 PL_perlio_fd_refcnt[fd]++;
2292 if (PL_perlio_fd_refcnt[fd] <= 0) {
2293 /* diag_listed_as: refcnt_inc: fd %d%s */
2294 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2295 fd, PL_perlio_fd_refcnt[fd]);
2297 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2298 fd, PL_perlio_fd_refcnt[fd]);
2301 MUTEX_UNLOCK(&PL_perlio_mutex);
2304 /* diag_listed_as: refcnt_inc: fd %d%s */
2305 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2310 PerlIOUnix_refcnt_dec(int fd)
2316 MUTEX_LOCK(&PL_perlio_mutex);
2318 if (fd >= PL_perlio_fd_refcnt_size) {
2319 /* diag_listed_as: refcnt_dec: fd %d%s */
2320 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2321 fd, PL_perlio_fd_refcnt_size);
2323 if (PL_perlio_fd_refcnt[fd] <= 0) {
2324 /* diag_listed_as: refcnt_dec: fd %d%s */
2325 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2326 fd, PL_perlio_fd_refcnt[fd]);
2328 cnt = --PL_perlio_fd_refcnt[fd];
2329 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2331 MUTEX_UNLOCK(&PL_perlio_mutex);
2334 /* diag_listed_as: refcnt_dec: fd %d%s */
2335 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2341 PerlIOUnix_refcnt(int fd)
2348 MUTEX_LOCK(&PL_perlio_mutex);
2350 if (fd >= PL_perlio_fd_refcnt_size) {
2351 /* diag_listed_as: refcnt: fd %d%s */
2352 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2353 fd, PL_perlio_fd_refcnt_size);
2355 if (PL_perlio_fd_refcnt[fd] <= 0) {
2356 /* diag_listed_as: refcnt: fd %d%s */
2357 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2358 fd, PL_perlio_fd_refcnt[fd]);
2360 cnt = PL_perlio_fd_refcnt[fd];
2362 MUTEX_UNLOCK(&PL_perlio_mutex);
2365 /* diag_listed_as: refcnt: fd %d%s */
2366 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2372 PerlIO_cleanup(pTHX)
2376 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2378 PerlIO_debug("Cleanup layers\n");
2381 /* Raise STDIN..STDERR refcount so we don't close them */
2382 for (i=0; i < 3; i++)
2383 PerlIOUnix_refcnt_inc(i);
2384 PerlIO_cleantable(aTHX_ &PL_perlio);
2385 /* Restore STDIN..STDERR refcount */
2386 for (i=0; i < 3; i++)
2387 PerlIOUnix_refcnt_dec(i);
2389 if (PL_known_layers) {
2390 PerlIO_list_free(aTHX_ PL_known_layers);
2391 PL_known_layers = NULL;
2393 if (PL_def_layerlist) {
2394 PerlIO_list_free(aTHX_ PL_def_layerlist);
2395 PL_def_layerlist = NULL;
2399 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2403 /* XXX we can't rely on an interpreter being present at this late stage,
2404 XXX so we can't use a function like PerlLIO_write that relies on one
2405 being present (at least in win32) :-(.
2410 /* By now all filehandles should have been closed, so any
2411 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2413 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2414 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2415 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2417 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2418 if (PL_perlio_fd_refcnt[i]) {
2420 my_snprintf(buf, sizeof(buf),
2421 "PerlIO_teardown: fd %d refcnt=%d\n",
2422 i, PL_perlio_fd_refcnt[i]);
2423 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2429 /* Not bothering with PL_perlio_mutex since by now
2430 * all the interpreters are gone. */
2431 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2432 && PL_perlio_fd_refcnt) {
2433 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2434 PL_perlio_fd_refcnt = NULL;
2435 PL_perlio_fd_refcnt_size = 0;
2439 /*--------------------------------------------------------------------------------------*/
2441 * Bottom-most level for UNIX-like case
2445 struct _PerlIO base; /* The generic part */
2446 int fd; /* UNIX like file descriptor */
2447 int oflags; /* open/fcntl flags */
2451 S_lockcnt_dec(pTHX_ const void* f)
2453 #ifndef PERL_IMPLICIT_SYS
2454 PERL_UNUSED_CONTEXT;
2456 PerlIO_lockcnt((PerlIO*)f)--;
2460 /* call the signal handler, and if that handler happens to clear
2461 * this handle, free what we can and return true */
2464 S_perlio_async_run(pTHX_ PerlIO* f) {
2466 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2467 PerlIO_lockcnt(f)++;
2469 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2473 /* we've just run some perl-level code that could have done
2474 * anything, including closing the file or clearing this layer.
2475 * If so, free any lower layers that have already been
2476 * cleared, then return an error. */
2477 while (PerlIOValid(f) &&
2478 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2480 const PerlIOl *l = *f;
2489 PerlIOUnix_oflags(const char *mode)
2492 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2497 if (*++mode == '+') {
2504 oflags = O_CREAT | O_TRUNC;
2505 if (*++mode == '+') {
2514 oflags = O_CREAT | O_APPEND;
2515 if (*++mode == '+') {
2524 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2526 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2527 * of them in, and then bit-and-masking the other them away, won't
2528 * have much of an effect. */
2531 #if O_TEXT != O_BINARY
2538 #if O_TEXT != O_BINARY
2540 oflags &= ~O_BINARY;
2546 /* bit-or:ing with zero O_BINARY would be useless. */
2548 * If neither "t" nor "b" was specified, open the file
2551 * Note that if something else than the zero byte was seen
2552 * here (e.g. bogus mode "rx"), just few lines later we will
2553 * set the errno and invalidate the flags.
2559 if (*mode || oflags == -1) {
2560 SETERRNO(EINVAL, LIB_INVARG);
2567 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2569 PERL_UNUSED_CONTEXT;
2570 return PerlIOSelf(f, PerlIOUnix)->fd;
2574 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2576 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2579 if (PerlLIO_fstat(fd, &st) == 0) {
2580 if (!S_ISREG(st.st_mode)) {
2581 PerlIO_debug("%d is not regular file\n",fd);
2582 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2585 PerlIO_debug("%d _is_ a regular file\n",fd);
2591 PerlIOUnix_refcnt_inc(fd);
2592 PERL_UNUSED_CONTEXT;
2596 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2598 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2599 if (*PerlIONext(f)) {
2600 /* We never call down so do any pending stuff now */
2601 PerlIO_flush(PerlIONext(f));
2603 * XXX could (or should) we retrieve the oflags from the open file
2604 * handle rather than believing the "mode" we are passed in? XXX
2605 * Should the value on NULL mode be 0 or -1?
2607 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2608 mode ? PerlIOUnix_oflags(mode) : -1);
2610 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2616 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2618 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2620 PERL_UNUSED_CONTEXT;
2621 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2623 SETERRNO(ESPIPE, LIB_INVARG);
2625 SETERRNO(EINVAL, LIB_INVARG);
2629 new_loc = PerlLIO_lseek(fd, offset, whence);
2630 if (new_loc == (Off_t) - 1)
2632 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2637 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2638 IV n, const char *mode, int fd, int imode,
2639 int perm, PerlIO *f, int narg, SV **args)
2641 if (PerlIOValid(f)) {
2642 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2643 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2646 if (*mode == IoTYPE_NUMERIC)
2649 imode = PerlIOUnix_oflags(mode);
2651 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2658 const char *path = SvPV_const(*args, len);
2659 if (!IS_SAFE_PATHNAME(path, len, "open"))
2661 fd = PerlLIO_open3(path, imode, perm);
2665 if (*mode == IoTYPE_IMPLICIT)
2668 f = PerlIO_allocate(aTHX);
2670 if (!PerlIOValid(f)) {
2671 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2676 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2677 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2678 if (*mode == IoTYPE_APPEND)
2679 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2686 * FIXME: pop layers ???
2694 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2696 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2698 if (flags & PERLIO_DUP_FD) {
2699 fd = PerlLIO_dup(fd);
2702 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2704 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2705 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2715 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2718 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2720 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2721 #ifdef PERLIO_STD_SPECIAL
2723 return PERLIO_STD_IN(fd, vbuf, count);
2725 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2726 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2730 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2731 if (len >= 0 || errno != EINTR) {
2733 if (errno != EAGAIN) {
2734 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2735 PerlIO_save_errno(f);
2738 else if (len == 0 && count != 0) {
2739 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2745 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2748 NOT_REACHED; /*NOTREACHED*/
2752 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2755 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2757 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2758 #ifdef PERLIO_STD_SPECIAL
2759 if (fd == 1 || fd == 2)
2760 return PERLIO_STD_OUT(fd, vbuf, count);
2763 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2764 if (len >= 0 || errno != EINTR) {
2766 if (errno != EAGAIN) {
2767 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2768 PerlIO_save_errno(f);
2774 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2777 NOT_REACHED; /*NOTREACHED*/
2781 PerlIOUnix_tell(pTHX_ PerlIO *f)
2783 PERL_UNUSED_CONTEXT;
2785 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2790 PerlIOUnix_close(pTHX_ PerlIO *f)
2792 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2794 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2795 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2796 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2801 SETERRNO(EBADF,SS_IVCHAN);
2804 while (PerlLIO_close(fd) != 0) {
2805 if (errno != EINTR) {
2810 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2814 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2819 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2820 sizeof(PerlIO_funcs),
2827 PerlIOBase_binmode, /* binmode */
2837 PerlIOBase_noop_ok, /* flush */
2838 PerlIOBase_noop_fail, /* fill */
2841 PerlIOBase_clearerr,
2842 PerlIOBase_setlinebuf,
2843 NULL, /* get_base */
2844 NULL, /* get_bufsiz */
2847 NULL, /* set_ptrcnt */
2850 /*--------------------------------------------------------------------------------------*/
2855 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2856 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2857 broken by the last second glibc 2.3 fix
2859 #define STDIO_BUFFER_WRITABLE
2864 struct _PerlIO base;
2865 FILE *stdio; /* The stream */
2869 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2871 PERL_UNUSED_CONTEXT;
2873 if (PerlIOValid(f)) {
2874 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2876 return PerlSIO_fileno(s);
2883 PerlIOStdio_mode(const char *mode, char *tmode)
2885 char * const ret = tmode;
2891 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2899 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2902 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2903 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2904 if (toptab == tab) {
2905 /* Top is already stdio - pop self (duplicate) and use original */
2906 PerlIO_pop(aTHX_ f);
2909 const int fd = PerlIO_fileno(n);
2912 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2913 mode = PerlIOStdio_mode(mode, tmode)))) {
2914 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2915 /* We never call down so do any pending stuff now */
2916 PerlIO_flush(PerlIONext(f));
2917 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2924 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2929 PerlIO_importFILE(FILE *stdio, const char *mode)
2935 char filename[FILENAME_MAX];
2940 int fd0 = fileno(stdio);
2943 rc = fldata(stdio,filename,&fileinfo);
2947 if(fileinfo.__dsorgHFS){
2950 /*This MVS dataset , OK!*/
2955 if (!mode || !*mode) {
2956 /* We need to probe to see how we can open the stream
2957 so start with read/write and then try write and read
2958 we dup() so that we can fclose without loosing the fd.
2960 Note that the errno value set by a failing fdopen
2961 varies between stdio implementations.
2963 const int fd = PerlLIO_dup(fd0);
2968 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2970 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2973 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2976 /* Don't seem to be able to open */
2982 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2983 s = PerlIOSelf(f, PerlIOStdio);
2986 fd0 = fileno(stdio);
2988 PerlIOUnix_refcnt_inc(fd0);
2991 rc = fldata(stdio,filename,&fileinfo);
2993 PerlIOUnix_refcnt_inc(fd0);
2995 if(fileinfo.__dsorgHFS){
2996 PerlIOUnix_refcnt_inc(fd0);
2998 /*This MVS dataset , OK!*/
3001 PerlIOUnix_refcnt_inc(fileno(stdio));
3009 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3010 IV n, const char *mode, int fd, int imode,
3011 int perm, PerlIO *f, int narg, SV **args)
3014 if (PerlIOValid(f)) {
3016 const char * const path = SvPV_const(*args, len);
3017 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3019 if (!IS_SAFE_PATHNAME(path, len, "open"))
3021 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3022 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3027 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3033 const char * const path = SvPV_const(*args, len);
3034 if (!IS_SAFE_PATHNAME(path, len, "open"))
3036 if (*mode == IoTYPE_NUMERIC) {
3038 fd = PerlLIO_open3(path, imode, perm);
3042 bool appended = FALSE;
3044 /* Cygwin wants its 'b' early. */
3046 mode = PerlIOStdio_mode(mode, tmode);
3048 stdio = PerlSIO_fopen(path, mode);
3051 f = PerlIO_allocate(aTHX);
3054 mode = PerlIOStdio_mode(mode, tmode);
3055 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3057 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3058 PerlIOUnix_refcnt_inc(fileno(stdio));
3060 PerlSIO_fclose(stdio);
3072 if (*mode == IoTYPE_IMPLICIT) {
3079 stdio = PerlSIO_stdin;
3082 stdio = PerlSIO_stdout;
3085 stdio = PerlSIO_stderr;
3090 stdio = PerlSIO_fdopen(fd, mode =
3091 PerlIOStdio_mode(mode, tmode));
3095 f = PerlIO_allocate(aTHX);
3097 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3098 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3099 PerlIOUnix_refcnt_inc(fileno(stdio));
3110 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3112 /* This assumes no layers underneath - which is what
3113 happens, but is not how I remember it. NI-S 2001/10/16
3115 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3116 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3117 const int fd = fileno(stdio);
3119 if (flags & PERLIO_DUP_FD) {
3120 const int dfd = PerlLIO_dup(fileno(stdio));
3122 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3127 /* FIXME: To avoid messy error recovery if dup fails
3128 re-use the existing stdio as though flag was not set
3132 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3134 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3136 PerlIOUnix_refcnt_inc(fileno(stdio));
3143 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3145 PERL_UNUSED_CONTEXT;
3147 /* XXX this could use PerlIO_canset_fileno() and
3148 * PerlIO_set_fileno() support from Configure
3150 # if defined(__UCLIBC__)
3151 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3154 # elif defined(__GLIBC__)
3155 /* There may be a better way for GLIBC:
3156 - libio.h defines a flag to not close() on cleanup
3160 # elif defined(__sun)
3163 # elif defined(__hpux)
3167 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3168 your platform does not have special entry try this one.
3169 [For OSF only have confirmation for Tru64 (alpha)
3170 but assume other OSFs will be similar.]
3172 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3175 # elif defined(__FreeBSD__)
3176 /* There may be a better way on FreeBSD:
3177 - we could insert a dummy func in the _close function entry
3178 f->_close = (int (*)(void *)) dummy_close;
3182 # elif defined(__OpenBSD__)
3183 /* There may be a better way on OpenBSD:
3184 - we could insert a dummy func in the _close function entry
3185 f->_close = (int (*)(void *)) dummy_close;
3189 # elif defined(__EMX__)
3190 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3193 # elif defined(__CYGWIN__)
3194 /* There may be a better way on CYGWIN:
3195 - we could insert a dummy func in the _close function entry
3196 f->_close = (int (*)(void *)) dummy_close;
3200 # elif defined(WIN32)
3201 # if defined(UNDER_CE)
3202 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3211 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3212 (which isn't thread safe) instead
3214 # error "Don't know how to set FILE.fileno on your platform"
3222 PerlIOStdio_close(pTHX_ PerlIO *f)
3224 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3230 const int fd = fileno(stdio);
3238 #ifdef SOCKS5_VERSION_NAME
3239 /* Socks lib overrides close() but stdio isn't linked to
3240 that library (though we are) - so we must call close()
3241 on sockets on stdio's behalf.
3244 Sock_size_t optlen = sizeof(int);
3245 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3248 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3249 that a subsequent fileno() on it returns -1. Don't want to croak()
3250 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3251 trying to close an already closed handle which somehow it still has
3252 a reference to. (via.xs, I'm looking at you). */
3253 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3254 /* File descriptor still in use */
3258 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3259 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3261 if (stdio == stdout || stdio == stderr)
3262 return PerlIO_flush(f);
3263 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3264 Use Sarathy's trick from maint-5.6 to invalidate the
3265 fileno slot of the FILE *
3267 result = PerlIO_flush(f);
3269 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3272 MUTEX_LOCK(&PL_perlio_mutex);
3273 /* Right. We need a mutex here because for a brief while we
3274 will have the situation that fd is actually closed. Hence if
3275 a second thread were to get into this block, its dup() would
3276 likely return our fd as its dupfd. (after all, it is closed)
3277 Then if we get to the dup2() first, we blat the fd back
3278 (messing up its temporary as a side effect) only for it to
3279 then close its dupfd (== our fd) in its close(dupfd) */
3281 /* There is, of course, a race condition, that any other thread
3282 trying to input/output/whatever on this fd will be stuffed
3283 for the duration of this little manoeuvrer. Perhaps we
3284 should hold an IO mutex for the duration of every IO
3285 operation if we know that invalidate doesn't work on this
3286 platform, but that would suck, and could kill performance.
3288 Except that correctness trumps speed.
3289 Advice from klortho #11912. */
3291 dupfd = PerlLIO_dup(fd);
3294 MUTEX_UNLOCK(&PL_perlio_mutex);
3295 /* Oh cXap. This isn't going to go well. Not sure if we can
3296 recover from here, or if closing this particular FILE *
3297 is a good idea now. */
3302 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3304 result = PerlSIO_fclose(stdio);
3305 /* We treat error from stdio as success if we invalidated
3306 errno may NOT be expected EBADF
3308 if (invalidate && result != 0) {
3312 #ifdef SOCKS5_VERSION_NAME
3313 /* in SOCKS' case, let close() determine return value */
3317 PerlLIO_dup2(dupfd,fd);
3318 PerlLIO_close(dupfd);
3320 MUTEX_UNLOCK(&PL_perlio_mutex);
3328 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3332 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3334 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3337 STDCHAR *buf = (STDCHAR *) vbuf;
3339 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3340 * stdio does not do that for fread()
3342 const int ch = PerlSIO_fgetc(s);
3349 got = PerlSIO_fread(vbuf, 1, count, s);
3350 if (got == 0 && PerlSIO_ferror(s))
3352 if (got >= 0 || errno != EINTR)
3354 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3356 SETERRNO(0,0); /* just in case */
3362 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3365 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3367 #ifdef STDIO_BUFFER_WRITABLE
3368 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3369 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3370 STDCHAR *base = PerlIO_get_base(f);
3371 SSize_t cnt = PerlIO_get_cnt(f);
3372 STDCHAR *ptr = PerlIO_get_ptr(f);
3373 SSize_t avail = ptr - base;
3375 if (avail > count) {
3379 Move(buf-avail,ptr,avail,STDCHAR);
3382 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3383 if (PerlSIO_feof(s) && unread >= 0)
3384 PerlSIO_clearerr(s);
3389 if (PerlIO_has_cntptr(f)) {
3390 /* We can get pointer to buffer but not its base
3391 Do ungetc() but check chars are ending up in the
3394 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3395 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3397 const int ch = *--buf & 0xFF;
3398 if (ungetc(ch,s) != ch) {
3399 /* ungetc did not work */
3402 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3403 /* Did not change pointer as expected */
3404 if (fgetc(s) != EOF) /* get char back again */
3414 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3420 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3423 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3426 got = PerlSIO_fwrite(vbuf, 1, count,
3427 PerlIOSelf(f, PerlIOStdio)->stdio);
3428 if (got >= 0 || errno != EINTR)
3430 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3432 SETERRNO(0,0); /* just in case */
3438 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3440 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3441 PERL_UNUSED_CONTEXT;
3443 return PerlSIO_fseek(stdio, offset, whence);
3447 PerlIOStdio_tell(pTHX_ PerlIO *f)
3449 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3450 PERL_UNUSED_CONTEXT;
3452 return PerlSIO_ftell(stdio);
3456 PerlIOStdio_flush(pTHX_ PerlIO *f)
3458 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3459 PERL_UNUSED_CONTEXT;
3461 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3462 return PerlSIO_fflush(stdio);
3468 * FIXME: This discards ungetc() and pre-read stuff which is not
3469 * right if this is just a "sync" from a layer above Suspect right
3470 * design is to do _this_ but not have layer above flush this
3471 * layer read-to-read
3474 * Not writeable - sync by attempting a seek
3477 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3485 PerlIOStdio_eof(pTHX_ PerlIO *f)
3487 PERL_UNUSED_CONTEXT;
3489 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3493 PerlIOStdio_error(pTHX_ PerlIO *f)
3495 PERL_UNUSED_CONTEXT;
3497 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3501 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3503 PERL_UNUSED_CONTEXT;
3505 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3509 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3511 PERL_UNUSED_CONTEXT;
3513 #ifdef HAS_SETLINEBUF
3514 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3516 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3522 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3524 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3525 return (STDCHAR*)PerlSIO_get_base(stdio);
3529 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3531 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3532 return PerlSIO_get_bufsiz(stdio);
3536 #ifdef USE_STDIO_PTR
3538 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3540 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3541 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3545 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3547 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3548 return PerlSIO_get_cnt(stdio);
3552 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3554 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3556 #ifdef STDIO_PTR_LVALUE
3557 /* This is a long-standing infamous mess. The root of the
3558 * problem is that one cannot know the signedness of char, and
3559 * more precisely the signedness of FILE._ptr. The following
3560 * things have been tried, and they have all failed (across
3561 * different compilers (remember that core needs to to build
3562 * also with c++) and compiler options:
3564 * - casting the RHS to (void*) -- works in *some* places
3565 * - casting the LHS to (void*) -- totally unportable
3567 * So let's try silencing the warning at least for gcc. */
3568 GCC_DIAG_IGNORE(-Wpointer-sign);
3569 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3571 #ifdef STDIO_PTR_LVAL_SETS_CNT
3572 assert(PerlSIO_get_cnt(stdio) == (cnt));
3574 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3576 * Setting ptr _does_ change cnt - we are done
3580 #else /* STDIO_PTR_LVALUE */
3582 #endif /* STDIO_PTR_LVALUE */
3585 * Now (or only) set cnt
3587 #ifdef STDIO_CNT_LVALUE
3588 PerlSIO_set_cnt(stdio, cnt);
3589 #else /* STDIO_CNT_LVALUE */
3590 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3591 PerlSIO_set_ptr(stdio,
3592 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3594 #else /* STDIO_PTR_LVAL_SETS_CNT */
3596 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3597 #endif /* STDIO_CNT_LVALUE */
3604 PerlIOStdio_fill(pTHX_ PerlIO *f)
3608 PERL_UNUSED_CONTEXT;
3609 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3611 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3614 * fflush()ing read-only streams can cause trouble on some stdio-s
3616 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3617 if (PerlSIO_fflush(stdio) != 0)
3621 c = PerlSIO_fgetc(stdio);
3624 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3626 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3631 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3633 #ifdef STDIO_BUFFER_WRITABLE
3634 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3635 /* Fake ungetc() to the real buffer in case system's ungetc
3638 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3639 SSize_t cnt = PerlSIO_get_cnt(stdio);
3640 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3641 if (ptr == base+1) {
3642 *--ptr = (STDCHAR) c;
3643 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3644 if (PerlSIO_feof(stdio))
3645 PerlSIO_clearerr(stdio);
3651 if (PerlIO_has_cntptr(f)) {
3653 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3659 /* If buffer snoop scheme above fails fall back to
3662 if (PerlSIO_ungetc(c, stdio) != c)
3670 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3671 sizeof(PerlIO_funcs),
3673 sizeof(PerlIOStdio),
3674 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3678 PerlIOBase_binmode, /* binmode */
3692 PerlIOStdio_clearerr,
3693 PerlIOStdio_setlinebuf,
3695 PerlIOStdio_get_base,
3696 PerlIOStdio_get_bufsiz,
3701 #ifdef USE_STDIO_PTR
3702 PerlIOStdio_get_ptr,
3703 PerlIOStdio_get_cnt,
3704 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3705 PerlIOStdio_set_ptrcnt,
3708 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3713 #endif /* USE_STDIO_PTR */
3716 /* Note that calls to PerlIO_exportFILE() are reversed using
3717 * PerlIO_releaseFILE(), not importFILE. */
3719 PerlIO_exportFILE(PerlIO * f, const char *mode)
3723 if (PerlIOValid(f)) {
3725 int fd = PerlIO_fileno(f);
3730 if (!mode || !*mode) {
3731 mode = PerlIO_modestr(f, buf);
3733 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3737 /* De-link any lower layers so new :stdio sticks */
3739 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3740 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3742 PerlIOUnix_refcnt_inc(fileno(stdio));
3743 /* Link previous lower layers under new one */
3747 /* restore layers list */
3757 PerlIO_findFILE(PerlIO *f)
3762 if (l->tab == &PerlIO_stdio) {
3763 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3766 l = *PerlIONext(&l);
3768 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3769 /* However, we're not really exporting a FILE * to someone else (who
3770 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3771 So we need to undo its reference count increase on the underlying file
3772 descriptor. We have to do this, because if the loop above returns you
3773 the FILE *, then *it* didn't increase any reference count. So there's
3774 only one way to be consistent. */
3775 stdio = PerlIO_exportFILE(f, NULL);
3777 const int fd = fileno(stdio);
3779 PerlIOUnix_refcnt_dec(fd);
3784 /* Use this to reverse PerlIO_exportFILE calls. */
3786 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3790 if (l->tab == &PerlIO_stdio) {
3791 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3792 if (s->stdio == f) { /* not in a loop */
3793 const int fd = fileno(f);
3795 PerlIOUnix_refcnt_dec(fd);
3798 PerlIO_pop(aTHX_ p);
3808 /*--------------------------------------------------------------------------------------*/
3810 * perlio buffer layer
3814 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3816 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3817 const int fd = PerlIO_fileno(f);
3818 if (fd >= 0 && PerlLIO_isatty(fd)) {
3819 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3821 if (*PerlIONext(f)) {
3822 const Off_t posn = PerlIO_tell(PerlIONext(f));
3823 if (posn != (Off_t) - 1) {
3827 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3831 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3832 IV n, const char *mode, int fd, int imode, int perm,
3833 PerlIO *f, int narg, SV **args)
3835 if (PerlIOValid(f)) {
3836 PerlIO *next = PerlIONext(f);
3838 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3839 if (tab && tab->Open)
3841 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3843 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3848 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3850 if (*mode == IoTYPE_IMPLICIT) {
3856 if (tab && tab->Open)
3857 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3860 SETERRNO(EINVAL, LIB_INVARG);
3862 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3864 * if push fails during open, open fails. close will pop us.
3869 fd = PerlIO_fileno(f);
3870 if (init && fd == 2) {
3872 * Initial stderr is unbuffered
3874 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3876 #ifdef PERLIO_USING_CRLF
3877 # ifdef PERLIO_IS_BINMODE_FD
3878 if (PERLIO_IS_BINMODE_FD(fd))
3879 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3883 * do something about failing setmode()? --jhi
3885 PerlLIO_setmode(fd, O_BINARY);
3888 /* Enable line buffering with record-oriented regular files
3889 * so we don't introduce an extraneous record boundary when
3890 * the buffer fills up.
3892 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3894 if (PerlLIO_fstat(fd, &st) == 0
3895 && S_ISREG(st.st_mode)
3896 && (st.st_fab_rfm == FAB$C_VAR
3897 || st.st_fab_rfm == FAB$C_VFC)) {
3898 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3909 * This "flush" is akin to sfio's sync in that it handles files in either
3910 * read or write state. For write state, we put the postponed data through
3911 * the next layers. For read state, we seek() the next layers to the
3912 * offset given by current position in the buffer, and discard the buffer
3913 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3914 * in any case?). Then the pass the stick further in chain.
3917 PerlIOBuf_flush(pTHX_ PerlIO *f)
3919 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3921 PerlIO *n = PerlIONext(f);
3922 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3924 * write() the buffer
3926 const STDCHAR *buf = b->buf;
3927 const STDCHAR *p = buf;
3928 while (p < b->ptr) {
3929 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3933 else if (count < 0 || PerlIO_error(n)) {
3934 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3935 PerlIO_save_errno(f);
3940 b->posn += (p - buf);
3942 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3943 STDCHAR *buf = PerlIO_get_base(f);
3945 * Note position change
3947 b->posn += (b->ptr - buf);
3948 if (b->ptr < b->end) {
3949 /* We did not consume all of it - try and seek downstream to
3950 our logical position
3952 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3953 /* Reload n as some layers may pop themselves on seek */
3954 b->posn = PerlIO_tell(n = PerlIONext(f));
3957 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3958 data is lost for good - so return saying "ok" having undone
3961 b->posn -= (b->ptr - buf);
3966 b->ptr = b->end = b->buf;
3967 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3968 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3969 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3974 /* This discards the content of the buffer after b->ptr, and rereads
3975 * the buffer from the position off in the layer downstream; here off
3976 * is at offset corresponding to b->ptr - b->buf.
3979 PerlIOBuf_fill(pTHX_ PerlIO *f)
3981 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3982 PerlIO *n = PerlIONext(f);
3985 * Down-stream flush is defined not to loose read data so is harmless.
3986 * we would not normally be fill'ing if there was data left in anycase.
3988 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3990 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3991 PerlIOBase_flush_linebuf(aTHX);
3994 PerlIO_get_base(f); /* allocate via vtable */
3996 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3998 b->ptr = b->end = b->buf;
4000 if (!PerlIOValid(n)) {
4001 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4005 if (PerlIO_fast_gets(n)) {
4007 * Layer below is also buffered. We do _NOT_ want to call its
4008 * ->Read() because that will loop till it gets what we asked for
4009 * which may hang on a pipe etc. Instead take anything it has to
4010 * hand, or ask it to fill _once_.
4012 avail = PerlIO_get_cnt(n);
4014 avail = PerlIO_fill(n);
4016 avail = PerlIO_get_cnt(n);
4018 if (!PerlIO_error(n) && PerlIO_eof(n))
4023 STDCHAR *ptr = PerlIO_get_ptr(n);
4024 const SSize_t cnt = avail;
4025 if (avail > (SSize_t)b->bufsiz)
4027 Copy(ptr, b->buf, avail, STDCHAR);
4028 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4032 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4036 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4039 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4040 PerlIO_save_errno(f);
4044 b->end = b->buf + avail;
4045 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4050 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4052 if (PerlIOValid(f)) {
4053 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4056 return PerlIOBase_read(aTHX_ f, vbuf, count);
4062 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4064 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4065 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4068 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4073 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4075 * Buffer is already a read buffer, we can overwrite any chars
4076 * which have been read back to buffer start
4078 avail = (b->ptr - b->buf);
4082 * Buffer is idle, set it up so whole buffer is available for
4086 b->end = b->buf + avail;
4088 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4090 * Buffer extends _back_ from where we are now
4092 b->posn -= b->bufsiz;
4094 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4096 * If we have space for more than count, just move count
4104 * In simple stdio-like ungetc() case chars will be already
4107 if (buf != b->ptr) {
4108 Copy(buf, b->ptr, avail, STDCHAR);
4112 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4116 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4122 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4124 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4125 const STDCHAR *buf = (const STDCHAR *) vbuf;
4126 const STDCHAR *flushptr = buf;
4130 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4132 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4133 if (PerlIO_flush(f) != 0) {
4137 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4138 flushptr = buf + count;
4139 while (flushptr > buf && *(flushptr - 1) != '\n')
4143 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4144 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4146 if (flushptr > buf && flushptr <= buf + avail)
4147 avail = flushptr - buf;
4148 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4150 Copy(buf, b->ptr, avail, STDCHAR);
4155 if (buf == flushptr)
4158 if (b->ptr >= (b->buf + b->bufsiz))
4159 if (PerlIO_flush(f) == -1)
4162 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4168 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4171 if ((code = PerlIO_flush(f)) == 0) {
4172 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4173 code = PerlIO_seek(PerlIONext(f), offset, whence);
4175 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4176 b->posn = PerlIO_tell(PerlIONext(f));
4183 PerlIOBuf_tell(pTHX_ PerlIO *f)
4185 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4187 * b->posn is file position where b->buf was read, or will be written
4189 Off_t posn = b->posn;
4190 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4191 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4193 /* As O_APPEND files are normally shared in some sense it is better
4198 /* when file is NOT shared then this is sufficient */
4199 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4201 posn = b->posn = PerlIO_tell(PerlIONext(f));
4205 * If buffer is valid adjust position by amount in buffer
4207 posn += (b->ptr - b->buf);
4213 PerlIOBuf_popped(pTHX_ PerlIO *f)
4215 const IV code = PerlIOBase_popped(aTHX_ f);
4216 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4217 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4220 b->ptr = b->end = b->buf = NULL;
4221 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4226 PerlIOBuf_close(pTHX_ PerlIO *f)
4228 const IV code = PerlIOBase_close(aTHX_ f);
4229 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4230 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4233 b->ptr = b->end = b->buf = NULL;
4234 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4239 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4241 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4248 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4250 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4253 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4254 return (b->end - b->ptr);
4259 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4261 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4262 PERL_UNUSED_CONTEXT;
4266 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4267 Newxz(b->buf,b->bufsiz, STDCHAR);
4269 b->buf = (STDCHAR *) & b->oneword;
4270 b->bufsiz = sizeof(b->oneword);
4272 b->end = b->ptr = b->buf;
4278 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4280 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4283 return (b->end - b->buf);
4287 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4289 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4291 PERL_UNUSED_ARG(cnt);
4296 assert(PerlIO_get_cnt(f) == cnt);
4297 assert(b->ptr >= b->buf);
4298 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4302 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4304 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4309 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4310 sizeof(PerlIO_funcs),
4313 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4317 PerlIOBase_binmode, /* binmode */
4331 PerlIOBase_clearerr,
4332 PerlIOBase_setlinebuf,
4337 PerlIOBuf_set_ptrcnt,
4340 /*--------------------------------------------------------------------------------------*/
4342 * Temp layer to hold unread chars when cannot do it any other way
4346 PerlIOPending_fill(pTHX_ PerlIO *f)
4349 * Should never happen
4356 PerlIOPending_close(pTHX_ PerlIO *f)
4359 * A tad tricky - flush pops us, then we close new top
4362 return PerlIO_close(f);
4366 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4369 * A tad tricky - flush pops us, then we seek new top
4372 return PerlIO_seek(f, offset, whence);
4377 PerlIOPending_flush(pTHX_ PerlIO *f)
4379 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4380 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4384 PerlIO_pop(aTHX_ f);
4389 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4395 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4400 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4402 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4403 PerlIOl * const l = PerlIOBase(f);
4405 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4406 * etc. get muddled when it changes mid-string when we auto-pop.
4408 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4409 (PerlIOBase(PerlIONext(f))->
4410 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4415 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4417 SSize_t avail = PerlIO_get_cnt(f);
4419 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4422 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4423 if (got >= 0 && got < (SSize_t)count) {
4424 const SSize_t more =
4425 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4426 if (more >= 0 || got == 0)
4432 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4433 sizeof(PerlIO_funcs),
4436 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4437 PerlIOPending_pushed,
4440 PerlIOBase_binmode, /* binmode */
4449 PerlIOPending_close,
4450 PerlIOPending_flush,
4454 PerlIOBase_clearerr,
4455 PerlIOBase_setlinebuf,
4460 PerlIOPending_set_ptrcnt,
4465 /*--------------------------------------------------------------------------------------*/
4467 * crlf - translation On read translate CR,LF to "\n" we do this by
4468 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4469 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4471 * c->nl points on the first byte of CR LF pair when it is temporarily
4472 * replaced by LF, or to the last CR of the buffer. In the former case
4473 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4474 * that it ends at c->nl; these two cases can be distinguished by
4475 * *c->nl. c->nl is set during _getcnt() call, and unset during
4476 * _unread() and _flush() calls.
4477 * It only matters for read operations.
4481 PerlIOBuf base; /* PerlIOBuf stuff */
4482 STDCHAR *nl; /* Position of crlf we "lied" about in the
4486 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4487 * Otherwise the :crlf layer would always revert back to
4491 S_inherit_utf8_flag(PerlIO *f)
4493 PerlIO *g = PerlIONext(f);
4494 if (PerlIOValid(g)) {
4495 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4496 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4502 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4505 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4506 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4508 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4509 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4510 PerlIOBase(f)->flags);
4513 /* If the old top layer is a CRLF layer, reactivate it (if
4514 * necessary) and remove this new layer from the stack */
4515 PerlIO *g = PerlIONext(f);
4516 if (PerlIOValid(g)) {
4517 PerlIOl *b = PerlIOBase(g);
4518 if (b && b->tab == &PerlIO_crlf) {
4519 if (!(b->flags & PERLIO_F_CRLF))
4520 b->flags |= PERLIO_F_CRLF;
4521 S_inherit_utf8_flag(g);
4522 PerlIO_pop(aTHX_ f);
4527 S_inherit_utf8_flag(f);
4533 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4535 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4536 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4537 *(c->nl) = NATIVE_0xd;
4540 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4541 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4543 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4544 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4546 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4551 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4552 b->end = b->ptr = b->buf + b->bufsiz;
4553 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4554 b->posn -= b->bufsiz;
4556 while (count > 0 && b->ptr > b->buf) {
4557 const int ch = *--buf;
4559 if (b->ptr - 2 >= b->buf) {
4560 *--(b->ptr) = NATIVE_0xa;
4561 *--(b->ptr) = NATIVE_0xd;
4566 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4567 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4581 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4586 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4588 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4590 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4593 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4594 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4595 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4596 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4598 while (nl < b->end && *nl != NATIVE_0xd)
4600 if (nl < b->end && *nl == NATIVE_0xd) {
4602 if (nl + 1 < b->end) {
4603 if (nl[1] == NATIVE_0xa) {
4609 * Not CR,LF but just CR
4617 * Blast - found CR as last char in buffer
4622 * They may not care, defer work as long as
4626 return (nl - b->ptr);
4630 b->ptr++; /* say we have read it as far as
4631 * flush() is concerned */
4632 b->buf++; /* Leave space in front of buffer */
4633 /* Note as we have moved buf up flush's
4635 will naturally make posn point at CR
4637 b->bufsiz--; /* Buffer is thus smaller */
4638 code = PerlIO_fill(f); /* Fetch some more */
4639 b->bufsiz++; /* Restore size for next time */
4640 b->buf--; /* Point at space */
4641 b->ptr = nl = b->buf; /* Which is what we hand
4643 *nl = NATIVE_0xd; /* Fill in the CR */
4645 goto test; /* fill() call worked */
4647 * CR at EOF - just fall through
4649 /* Should we clear EOF though ??? */
4654 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4660 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4662 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4663 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4669 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4670 /* Deferred CR at end of buffer case - we lied about count */
4683 * Test code - delete when it works ...
4685 IV flags = PerlIOBase(f)->flags;
4686 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4687 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4688 /* Deferred CR at end of buffer case - we lied about count */
4694 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4695 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4696 flags, c->nl, b->end, cnt);
4703 * They have taken what we lied about
4705 *(c->nl) = NATIVE_0xd;
4711 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4715 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4717 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4718 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4720 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4721 const STDCHAR *buf = (const STDCHAR *) vbuf;
4722 const STDCHAR * const ebuf = buf + count;
4725 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4727 while (buf < ebuf) {
4728 const STDCHAR * const eptr = b->buf + b->bufsiz;
4729 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4730 while (buf < ebuf && b->ptr < eptr) {
4732 if ((b->ptr + 2) > eptr) {
4740 *(b->ptr)++ = NATIVE_0xd; /* CR */
4741 *(b->ptr)++ = NATIVE_0xa; /* LF */
4743 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4750 *(b->ptr)++ = *buf++;
4752 if (b->ptr >= eptr) {
4758 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4760 return (buf - (STDCHAR *) vbuf);
4765 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4767 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4769 *(c->nl) = NATIVE_0xd;
4772 return PerlIOBuf_flush(aTHX_ f);
4776 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4778 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4779 /* In text mode - flush any pending stuff and flip it */
4780 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4781 #ifndef PERLIO_USING_CRLF
4782 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4783 PerlIO_pop(aTHX_ f);
4789 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4790 sizeof(PerlIO_funcs),
4793 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4795 PerlIOBuf_popped, /* popped */
4797 PerlIOCrlf_binmode, /* binmode */
4801 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4802 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4803 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4811 PerlIOBase_clearerr,
4812 PerlIOBase_setlinebuf,
4817 PerlIOCrlf_set_ptrcnt,
4821 Perl_PerlIO_stdin(pTHX)
4824 PerlIO_stdstreams(aTHX);
4826 return (PerlIO*)&PL_perlio[1];
4830 Perl_PerlIO_stdout(pTHX)
4833 PerlIO_stdstreams(aTHX);
4835 return (PerlIO*)&PL_perlio[2];
4839 Perl_PerlIO_stderr(pTHX)
4842 PerlIO_stdstreams(aTHX);
4844 return (PerlIO*)&PL_perlio[3];
4847 /*--------------------------------------------------------------------------------------*/
4850 PerlIO_getname(PerlIO *f, char *buf)
4855 bool exported = FALSE;
4856 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4858 stdio = PerlIO_exportFILE(f,0);
4862 name = fgetname(stdio, buf);
4863 if (exported) PerlIO_releaseFILE(f,stdio);
4868 PERL_UNUSED_ARG(buf);
4869 Perl_croak_nocontext("Don't know how to get file name");
4875 /*--------------------------------------------------------------------------------------*/
4877 * Functions which can be called on any kind of PerlIO implemented in
4881 #undef PerlIO_fdopen
4883 PerlIO_fdopen(int fd, const char *mode)
4886 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4891 PerlIO_open(const char *path, const char *mode)
4894 SV *name = sv_2mortal(newSVpv(path, 0));
4895 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4898 #undef Perlio_reopen
4900 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4903 SV *name = sv_2mortal(newSVpv(path,0));
4904 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4909 PerlIO_getc(PerlIO *f)
4913 if ( 1 == PerlIO_read(f, buf, 1) ) {
4914 return (unsigned char) buf[0];
4919 #undef PerlIO_ungetc
4921 PerlIO_ungetc(PerlIO *f, int ch)
4926 if (PerlIO_unread(f, &buf, 1) == 1)
4934 PerlIO_putc(PerlIO *f, int ch)
4938 return PerlIO_write(f, &buf, 1);
4943 PerlIO_puts(PerlIO *f, const char *s)
4946 return PerlIO_write(f, s, strlen(s));
4949 #undef PerlIO_rewind
4951 PerlIO_rewind(PerlIO *f)
4954 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4958 #undef PerlIO_vprintf
4960 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4969 Perl_va_copy(ap, apc);
4970 sv = vnewSVpvf(fmt, &apc);
4973 sv = vnewSVpvf(fmt, &ap);
4975 s = SvPV_const(sv, len);
4976 wrote = PerlIO_write(f, s, len);
4981 #undef PerlIO_printf
4983 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4988 result = PerlIO_vprintf(f, fmt, ap);
4993 #undef PerlIO_stdoutf
4995 PerlIO_stdoutf(const char *fmt, ...)
5001 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5006 #undef PerlIO_tmpfile
5008 PerlIO_tmpfile(void)
5015 const int fd = win32_tmpfd();
5017 f = PerlIO_fdopen(fd, "w+b");
5019 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5021 char tempname[] = "/tmp/PerlIO_XXXXXX";
5022 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5024 int old_umask = umask(0600);
5026 * I have no idea how portable mkstemp() is ... NI-S
5028 if (tmpdir && *tmpdir) {
5029 /* if TMPDIR is set and not empty, we try that first */
5030 sv = newSVpv(tmpdir, 0);
5031 sv_catpv(sv, tempname + 4);
5032 fd = mkstemp(SvPVX(sv));
5037 /* else we try /tmp */
5038 fd = mkstemp(tempname);
5043 sv_catpv(sv, tempname + 4);
5044 fd = mkstemp(SvPVX(sv));
5048 f = PerlIO_fdopen(fd, "w+");
5050 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5051 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5054 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5055 FILE * const stdio = PerlSIO_tmpfile();
5058 f = PerlIO_fdopen(fileno(stdio), "w+");
5060 # endif /* else HAS_MKSTEMP */
5061 #endif /* else WIN32 */
5066 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5068 if (!PerlIOValid(f))
5070 PerlIOBase(f)->err = errno;
5072 PerlIOBase(f)->os_err = vaxc$errno;
5074 PerlIOBase(f)->os_err = Perl_rc;
5075 #elif defined(WIN32)
5076 PerlIOBase(f)->os_err = GetLastError();
5081 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5083 if (!PerlIOValid(f))
5085 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5087 Perl_rc = PerlIOBase(f)->os_err);
5088 #elif defined(WIN32)
5089 SetLastError(PerlIOBase(f)->os_err);
5096 #endif /* PERLIO_IS_STDIO */
5098 /*======================================================================================*/
5100 * Now some functions in terms of above which may be needed even if we are
5101 * not in true PerlIO mode
5104 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5106 const char *direction = NULL;
5109 * Need to supply default layer info from open.pm
5115 if (mode && mode[0] != 'r') {
5116 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5117 direction = "open>";
5119 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5120 direction = "open<";
5125 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5128 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5133 #undef PerlIO_setpos
5135 PerlIO_setpos(PerlIO *f, SV *pos)
5141 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5142 if(len == sizeof(Off_t))
5143 return PerlIO_seek(f, *posn, SEEK_SET);
5146 SETERRNO(EINVAL, SS_IVCHAN);
5150 #undef PerlIO_setpos
5152 PerlIO_setpos(PerlIO *f, SV *pos)
5158 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5159 if(len == sizeof(Fpos_t))
5160 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5161 return fsetpos64(f, fpos);
5163 return fsetpos(f, fpos);
5167 SETERRNO(EINVAL, SS_IVCHAN);
5173 #undef PerlIO_getpos
5175 PerlIO_getpos(PerlIO *f, SV *pos)
5178 Off_t posn = PerlIO_tell(f);
5179 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5180 return (posn == (Off_t) - 1) ? -1 : 0;
5183 #undef PerlIO_getpos
5185 PerlIO_getpos(PerlIO *f, SV *pos)
5190 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5191 code = fgetpos64(f, &fpos);
5193 code = fgetpos(f, &fpos);
5195 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5200 #if !defined(HAS_VPRINTF)
5203 vprintf(char *pat, char *args)
5205 _doprnt(pat, args, stdout);
5206 return 0; /* wrong, but perl doesn't use the return
5211 vfprintf(FILE *fd, char *pat, char *args)
5213 _doprnt(pat, args, fd);
5214 return 0; /* wrong, but perl doesn't use the return
5220 /* print a failure format string message to stderr and fail exit the process
5221 using only libc without depending on any perl data structures being
5226 Perl_noperl_die(const char* pat, ...)
5229 PERL_ARGS_ASSERT_NOPERL_DIE;
5230 va_start(arglist, pat);
5231 vfprintf(stderr, pat, arglist);
5238 * c-indentation-style: bsd
5240 * indent-tabs-mode: nil
5243 * ex: set ts=8 sts=4 sw=4 et: