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)
433 p = head = PerlIOBase(f)->head;
436 assert(p->head == head);
437 if (p == (PerlIOl*)f)
444 # define VERIFY_HEAD(f)
449 * Table of pointers to the PerlIO structs (malloc'ed)
451 #define PERLIO_TABLE_SIZE 64
454 PerlIO_init_table(pTHX)
458 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
464 PerlIO_allocate(pTHX)
468 * Find a free slot in the table, allocating new table as necessary
473 while ((f = *last)) {
475 last = (PerlIOl **) (f);
476 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
477 if (!((++f)->next)) {
478 f->flags = 0; /* lockcnt */
485 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
489 *last = (PerlIOl*) f++;
490 f->flags = 0; /* lockcnt */
496 #undef PerlIO_fdupopen
498 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
500 if (PerlIOValid(f)) {
501 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
502 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
504 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
506 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
510 SETERRNO(EBADF, SS_IVCHAN);
516 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
518 PerlIOl * const table = *tablep;
521 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
522 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
523 PerlIOl * const f = table + i;
525 PerlIO_close(&(f->next));
535 PerlIO_list_alloc(pTHX)
539 Newxz(list, 1, PerlIO_list_t);
545 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
548 if (--list->refcnt == 0) {
551 for (i = 0; i < list->cur; i++)
552 SvREFCNT_dec(list->array[i].arg);
553 Safefree(list->array);
561 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)
634 PerlIOl **table = &PL_perlio;
637 PerlIO_debug("Destruct %p\n",(void*)aTHX);
639 while ((f = *table)) {
641 table = (PerlIOl **) (f++);
642 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
643 PerlIO *x = &(f->next);
646 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
647 PerlIO_debug("Destruct popping %s\n", l->tab->name);
661 PerlIO_pop(pTHX_ PerlIO *f)
663 const PerlIOl *l = *f;
666 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
667 l->tab ? l->tab->name : "(Null)");
668 if (l->tab && l->tab->Popped) {
670 * If popped returns non-zero do not free its layer structure
671 * it has either done so itself, or it is shared and still in
674 if ((*l->tab->Popped) (aTHX_ f) != 0)
677 if (PerlIO_lockcnt(f)) {
678 /* we're in use; defer freeing the structure */
679 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
680 PerlIOBase(f)->tab = NULL;
690 /* Return as an array the stack of layers on a filehandle. Note that
691 * the stack is returned top-first in the array, and there are three
692 * times as many array elements as there are layers in the stack: the
693 * first element of a layer triplet is the name, the second one is the
694 * arguments, and the third one is the flags. */
697 PerlIO_get_layers(pTHX_ PerlIO *f)
700 AV * const av = newAV();
702 if (PerlIOValid(f)) {
703 PerlIOl *l = PerlIOBase(f);
706 /* There is some collusion in the implementation of
707 XS_PerlIO_get_layers - it knows that name and flags are
708 generated as fresh SVs here, and takes advantage of that to
709 "copy" them by taking a reference. If it changes here, it needs
710 to change there too. */
711 SV * const name = l->tab && l->tab->name ?
712 newSVpv(l->tab->name, 0) : &PL_sv_undef;
713 SV * const arg = l->tab && l->tab->Getarg ?
714 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
717 av_push(av, newSViv((IV)l->flags));
725 /*--------------------------------------------------------------------------------------*/
727 * XS Interface for perl code
731 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
735 if ((SSize_t) len <= 0)
737 for (i = 0; i < PL_known_layers->cur; i++) {
738 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
739 const STRLEN this_len = strlen(f->name);
740 if (this_len == len && memEQ(f->name, name, len)) {
741 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
745 if (load && PL_subname && PL_def_layerlist
746 && PL_def_layerlist->cur >= 2) {
747 if (PL_in_load_module) {
748 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
751 SV * const pkgsv = newSVpvs("PerlIO");
752 SV * const layer = newSVpvn(name, len);
753 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
755 SAVEBOOL(PL_in_load_module);
757 SAVEGENERICSV(PL_warnhook);
758 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
760 PL_in_load_module = TRUE;
762 * The two SVs are magically freed by load_module
764 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
766 return PerlIO_find_layer(aTHX_ name, len, 0);
769 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
773 #ifdef USE_ATTRIBUTES_FOR_PERLIO
776 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
779 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
780 PerlIO * const ifp = IoIFP(io);
781 PerlIO * const ofp = IoOFP(io);
782 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
783 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
789 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
792 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
793 PerlIO * const ifp = IoIFP(io);
794 PerlIO * const ofp = IoOFP(io);
795 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
796 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
802 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
804 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
809 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
811 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
815 MGVTBL perlio_vtab = {
823 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
824 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
827 SV * const sv = SvRV(ST(1));
828 AV * const av = newAV();
832 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
834 mg = mg_find(sv, PERL_MAGIC_ext);
835 mg->mg_virtual = &perlio_vtab;
837 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
838 for (i = 2; i < items; i++) {
840 const char * const name = SvPV_const(ST(i), len);
841 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
843 av_push(av, SvREFCNT_inc_simple_NN(layer));
854 #endif /* USE_ATTIBUTES_FOR_PERLIO */
857 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
859 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
860 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
864 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
865 XS(XS_PerlIO__Layer__NoWarnings)
867 /* This is used as a %SIG{__WARN__} handler to suppress warnings
868 during loading of layers.
874 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
878 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
879 XS(XS_PerlIO__Layer__find)
885 Perl_croak(aTHX_ "Usage class->find(name[,load])");
888 const char * const name = SvPV_const(ST(1), len);
889 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
890 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
892 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
899 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
902 if (!PL_known_layers)
903 PL_known_layers = PerlIO_list_alloc(aTHX);
904 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
905 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
909 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
913 const char *s = names;
915 while (isSPACE(*s) || *s == ':')
920 const char *as = NULL;
922 if (!isIDFIRST(*s)) {
924 * Message is consistent with how attribute lists are
925 * passed. Even though this means "foo : : bar" is
926 * seen as an invalid separator character.
928 const char q = ((*s == '\'') ? '"' : '\'');
929 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
930 "Invalid separator character %c%c%c in PerlIO layer specification %s",
932 SETERRNO(EINVAL, LIB_INVARG);
937 } while (isWORDCHAR(*e));
953 * It's a nul terminated string, not allowed
954 * to \ the terminating null. Anything other
955 * character is passed over.
965 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
966 "Argument list not closed for PerlIO layer \"%.*s\"",
978 PerlIO_funcs * const layer =
979 PerlIO_find_layer(aTHX_ s, llen, 1);
983 arg = newSVpvn(as, alen);
984 PerlIO_list_push(aTHX_ av, layer,
985 (arg) ? arg : &PL_sv_undef);
989 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1002 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1005 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1006 #ifdef PERLIO_USING_CRLF
1009 if (PerlIO_stdio.Set_ptrcnt)
1010 tab = &PerlIO_stdio;
1012 PerlIO_debug("Pushing %s\n", tab->name);
1013 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1018 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1020 return av->array[n].arg;
1024 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1026 if (n >= 0 && n < av->cur) {
1027 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1028 av->array[n].funcs->name);
1029 return av->array[n].funcs;
1032 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1037 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1039 PERL_UNUSED_ARG(mode);
1040 PERL_UNUSED_ARG(arg);
1041 PERL_UNUSED_ARG(tab);
1042 if (PerlIOValid(f)) {
1044 PerlIO_pop(aTHX_ f);
1050 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1051 sizeof(PerlIO_funcs),
1054 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1074 NULL, /* get_base */
1075 NULL, /* get_bufsiz */
1078 NULL, /* set_ptrcnt */
1082 PerlIO_default_layers(pTHX)
1085 if (!PL_def_layerlist) {
1086 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1087 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1088 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1089 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1091 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1093 osLayer = &PerlIO_win32;
1096 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1097 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1098 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1099 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1100 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1101 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1102 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1103 PerlIO_list_push(aTHX_ PL_def_layerlist,
1104 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1107 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1110 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1113 if (PL_def_layerlist->cur < 2) {
1114 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1116 return PL_def_layerlist;
1120 Perl_boot_core_PerlIO(pTHX)
1122 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1123 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1126 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1127 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1131 PerlIO_default_layer(pTHX_ I32 n)
1134 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1137 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1140 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1141 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1144 PerlIO_stdstreams(pTHX)
1148 PerlIO_init_table(aTHX);
1149 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1150 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1151 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1156 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1159 if (tab->fsize != sizeof(PerlIO_funcs)) {
1161 "%s (%"UVuf") does not match %s (%"UVuf")",
1162 "PerlIO layer function table size", (UV)tab->fsize,
1163 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1167 if (tab->size < sizeof(PerlIOl)) {
1169 "%s (%"UVuf") smaller than %s (%"UVuf")",
1170 "PerlIO layer instance size", (UV)tab->size,
1171 "size expected by this perl", (UV)sizeof(PerlIOl) );
1173 /* Real layer with a data area */
1176 Newxz(temp, tab->size, char);
1180 l->tab = (PerlIO_funcs*) tab;
1181 l->head = ((PerlIOl*)f)->head;
1183 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1184 (void*)f, tab->name,
1185 (mode) ? mode : "(Null)", (void*)arg);
1186 if (*l->tab->Pushed &&
1188 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1189 PerlIO_pop(aTHX_ f);
1198 /* Pseudo-layer where push does its own stack adjust */
1199 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1200 (mode) ? mode : "(Null)", (void*)arg);
1202 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1210 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1211 IV n, const char *mode, int fd, int imode, int perm,
1212 PerlIO *old, int narg, SV **args)
1214 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1215 if (tab && tab->Open) {
1216 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1217 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1223 SETERRNO(EINVAL, LIB_INVARG);
1228 PerlIOBase_binmode(pTHX_ PerlIO *f)
1230 if (PerlIOValid(f)) {
1231 /* Is layer suitable for raw stream ? */
1232 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1233 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1234 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1237 /* Not suitable - pop it */
1238 PerlIO_pop(aTHX_ f);
1246 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1248 PERL_UNUSED_ARG(mode);
1249 PERL_UNUSED_ARG(arg);
1250 PERL_UNUSED_ARG(tab);
1252 if (PerlIOValid(f)) {
1257 * Strip all layers that are not suitable for a raw stream
1260 while (t && (l = *t)) {
1261 if (l->tab && l->tab->Binmode) {
1262 /* Has a handler - normal case */
1263 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1265 /* Layer still there - move down a layer */
1274 /* No handler - pop it */
1275 PerlIO_pop(aTHX_ t);
1278 if (PerlIOValid(f)) {
1279 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1280 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1288 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1289 PerlIO_list_t *layers, IV n, IV max)
1293 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1295 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1306 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1310 save_scalar(PL_errgv);
1312 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1313 code = PerlIO_parse_layers(aTHX_ layers, names);
1315 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1317 PerlIO_list_free(aTHX_ layers);
1324 /*--------------------------------------------------------------------------------------*/
1326 * Given the abstraction above the public API functions
1330 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1332 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1333 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1334 PerlIOBase(f)->tab->name : "(Null)",
1335 iotype, mode, (names) ? names : "(Null)");
1338 /* Do not flush etc. if (e.g.) switching encodings.
1339 if a pushed layer knows it needs to flush lower layers
1340 (for example :unix which is never going to call them)
1341 it can do the flush when it is pushed.
1343 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1346 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1347 #ifdef PERLIO_USING_CRLF
1348 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1349 O_BINARY so we can look for it in mode.
1351 if (!(mode & O_BINARY)) {
1353 /* FIXME?: Looking down the layer stack seems wrong,
1354 but is a way of reaching past (say) an encoding layer
1355 to flip CRLF-ness of the layer(s) below
1358 /* Perhaps we should turn on bottom-most aware layer
1359 e.g. Ilya's idea that UNIX TTY could serve
1361 if (PerlIOBase(f)->tab &&
1362 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1364 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1365 /* Not in text mode - flush any pending stuff and flip it */
1367 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1369 /* Only need to turn it on in one layer so we are done */
1374 /* Not finding a CRLF aware layer presumably means we are binary
1375 which is not what was requested - so we failed
1376 We _could_ push :crlf layer but so could caller
1381 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1382 So code that used to be here is now in PerlIORaw_pushed().
1384 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1389 PerlIO__close(pTHX_ PerlIO *f)
1391 if (PerlIOValid(f)) {
1392 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1393 if (tab && tab->Close)
1394 return (*tab->Close)(aTHX_ f);
1396 return PerlIOBase_close(aTHX_ f);
1399 SETERRNO(EBADF, SS_IVCHAN);
1405 Perl_PerlIO_close(pTHX_ PerlIO *f)
1407 const int code = PerlIO__close(aTHX_ f);
1408 while (PerlIOValid(f)) {
1409 PerlIO_pop(aTHX_ f);
1410 if (PerlIO_lockcnt(f))
1411 /* we're in use; the 'pop' deferred freeing the structure */
1418 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1421 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1425 static PerlIO_funcs *
1426 PerlIO_layer_from_ref(pTHX_ SV *sv)
1430 * For any scalar type load the handler which is bundled with perl
1432 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1433 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1434 /* This isn't supposed to happen, since PerlIO::scalar is core,
1435 * but could happen anyway in smaller installs or with PAR */
1437 /* diag_listed_as: Unknown PerlIO layer "%s" */
1438 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1443 * For other types allow if layer is known but don't try and load it
1445 switch (SvTYPE(sv)) {
1447 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1449 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1451 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1453 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1460 PerlIO_resolve_layers(pTHX_ const char *layers,
1461 const char *mode, int narg, SV **args)
1464 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1467 PerlIO_stdstreams(aTHX);
1469 SV * const arg = *args;
1471 * If it is a reference but not an object see if we have a handler
1474 if (SvROK(arg) && !sv_isobject(arg)) {
1475 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1477 def = PerlIO_list_alloc(aTHX);
1478 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1482 * Don't fail if handler cannot be found :via(...) etc. may do
1483 * something sensible else we will just stringfy and open
1488 if (!layers || !*layers)
1489 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1490 if (layers && *layers) {
1493 av = PerlIO_clone_list(aTHX_ def, NULL);
1498 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1502 PerlIO_list_free(aTHX_ av);
1514 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1515 int imode, int perm, PerlIO *f, int narg, SV **args)
1518 if (!f && narg == 1 && *args == &PL_sv_undef) {
1519 if ((f = PerlIO_tmpfile())) {
1520 if (!layers || !*layers)
1521 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1522 if (layers && *layers)
1523 PerlIO_apply_layers(aTHX_ f, mode, layers);
1527 PerlIO_list_t *layera;
1529 PerlIO_funcs *tab = NULL;
1530 if (PerlIOValid(f)) {
1532 * This is "reopen" - it is not tested as perl does not use it
1536 layera = PerlIO_list_alloc(aTHX);
1539 if (l->tab && l->tab->Getarg)
1540 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1541 PerlIO_list_push(aTHX_ layera, l->tab,
1542 (arg) ? arg : &PL_sv_undef);
1544 l = *PerlIONext(&l);
1548 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1554 * Start at "top" of layer stack
1556 n = layera->cur - 1;
1558 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1567 * Found that layer 'n' can do opens - call it
1569 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1570 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1572 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1573 tab->name, layers ? layers : "(Null)", mode, fd,
1574 imode, perm, (void*)f, narg, (void*)args);
1576 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1579 SETERRNO(EINVAL, LIB_INVARG);
1583 if (n + 1 < layera->cur) {
1585 * More layers above the one that we used to open -
1588 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1589 /* If pushing layers fails close the file */
1596 PerlIO_list_free(aTHX_ layera);
1603 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1605 PERL_ARGS_ASSERT_PERLIO_READ;
1607 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1611 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1613 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1615 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1619 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1621 PERL_ARGS_ASSERT_PERLIO_WRITE;
1623 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1627 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1629 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1633 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1635 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1639 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1644 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1646 if (tab && tab->Flush)
1647 return (*tab->Flush) (aTHX_ f);
1649 return 0; /* If no Flush defined, silently succeed. */
1652 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1653 SETERRNO(EBADF, SS_IVCHAN);
1659 * Is it good API design to do flush-all on NULL, a potentially
1660 * erroneous input? Maybe some magical value (PerlIO*
1661 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1662 * things on fflush(NULL), but should we be bound by their design
1665 PerlIOl **table = &PL_perlio;
1668 while ((ff = *table)) {
1670 table = (PerlIOl **) (ff++);
1671 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1672 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1682 PerlIOBase_flush_linebuf(pTHX)
1685 PerlIOl **table = &PL_perlio;
1687 while ((f = *table)) {
1689 table = (PerlIOl **) (f++);
1690 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1692 && (PerlIOBase(&(f->next))->
1693 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1694 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1695 PerlIO_flush(&(f->next));
1702 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1704 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1708 PerlIO_isutf8(PerlIO *f)
1711 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1713 SETERRNO(EBADF, SS_IVCHAN);
1719 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1721 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1725 Perl_PerlIO_error(pTHX_ PerlIO *f)
1727 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1731 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1733 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1737 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1739 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1743 PerlIO_has_base(PerlIO *f)
1745 if (PerlIOValid(f)) {
1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1749 return (tab->Get_base != NULL);
1756 PerlIO_fast_gets(PerlIO *f)
1758 if (PerlIOValid(f)) {
1759 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1760 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1763 return (tab->Set_ptrcnt != NULL);
1771 PerlIO_has_cntptr(PerlIO *f)
1773 if (PerlIOValid(f)) {
1774 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1777 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1784 PerlIO_canset_cnt(PerlIO *f)
1786 if (PerlIOValid(f)) {
1787 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1790 return (tab->Set_ptrcnt != NULL);
1797 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1799 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1803 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1805 /* Note that Get_bufsiz returns a Size_t */
1806 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1810 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1812 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1816 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1818 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1822 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1824 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1828 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1830 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1834 /*--------------------------------------------------------------------------------------*/
1836 * utf8 and raw dummy layers
1840 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1842 PERL_UNUSED_CONTEXT;
1843 PERL_UNUSED_ARG(mode);
1844 PERL_UNUSED_ARG(arg);
1845 if (PerlIOValid(f)) {
1846 if (tab && tab->kind & PERLIO_K_UTF8)
1847 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1849 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1855 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1856 sizeof(PerlIO_funcs),
1859 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1879 NULL, /* get_base */
1880 NULL, /* get_bufsiz */
1883 NULL, /* set_ptrcnt */
1886 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1887 sizeof(PerlIO_funcs),
1890 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1910 NULL, /* get_base */
1911 NULL, /* get_bufsiz */
1914 NULL, /* set_ptrcnt */
1917 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1918 sizeof(PerlIO_funcs),
1941 NULL, /* get_base */
1942 NULL, /* get_bufsiz */
1945 NULL, /* set_ptrcnt */
1947 /*--------------------------------------------------------------------------------------*/
1948 /*--------------------------------------------------------------------------------------*/
1950 * "Methods" of the "base class"
1954 PerlIOBase_fileno(pTHX_ PerlIO *f)
1956 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1960 PerlIO_modestr(PerlIO * f, char *buf)
1963 if (PerlIOValid(f)) {
1964 const IV flags = PerlIOBase(f)->flags;
1965 if (flags & PERLIO_F_APPEND) {
1967 if (flags & PERLIO_F_CANREAD) {
1971 else if (flags & PERLIO_F_CANREAD) {
1973 if (flags & PERLIO_F_CANWRITE)
1976 else if (flags & PERLIO_F_CANWRITE) {
1978 if (flags & PERLIO_F_CANREAD) {
1982 #ifdef PERLIO_USING_CRLF
1983 if (!(flags & PERLIO_F_CRLF))
1993 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1995 PerlIOl * const l = PerlIOBase(f);
1996 PERL_UNUSED_CONTEXT;
1997 PERL_UNUSED_ARG(arg);
1999 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2000 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2001 if (tab && tab->Set_ptrcnt != NULL)
2002 l->flags |= PERLIO_F_FASTGETS;
2004 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2008 l->flags |= PERLIO_F_CANREAD;
2011 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2014 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2017 SETERRNO(EINVAL, LIB_INVARG);
2023 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2026 l->flags &= ~PERLIO_F_CRLF;
2029 l->flags |= PERLIO_F_CRLF;
2032 SETERRNO(EINVAL, LIB_INVARG);
2039 l->flags |= l->next->flags &
2040 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2045 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2046 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2047 l->flags, PerlIO_modestr(f, temp));
2053 PerlIOBase_popped(pTHX_ PerlIO *f)
2055 PERL_UNUSED_CONTEXT;
2061 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2064 * Save the position as current head considers it
2066 const Off_t old = PerlIO_tell(f);
2067 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2068 PerlIOSelf(f, PerlIOBuf)->posn = old;
2069 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2073 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2075 STDCHAR *buf = (STDCHAR *) vbuf;
2077 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2078 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2079 SETERRNO(EBADF, SS_IVCHAN);
2085 SSize_t avail = PerlIO_get_cnt(f);
2088 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2090 STDCHAR *ptr = PerlIO_get_ptr(f);
2091 Copy(ptr, buf, take, STDCHAR);
2092 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2095 if (avail == 0) /* set_ptrcnt could have reset avail */
2098 if (count > 0 && avail <= 0) {
2099 if (PerlIO_fill(f) != 0)
2104 return (buf - (STDCHAR *) vbuf);
2110 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2112 PERL_UNUSED_CONTEXT;
2118 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2120 PERL_UNUSED_CONTEXT;
2126 PerlIOBase_close(pTHX_ PerlIO *f)
2129 if (PerlIOValid(f)) {
2130 PerlIO *n = PerlIONext(f);
2131 code = PerlIO_flush(f);
2132 PerlIOBase(f)->flags &=
2133 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2134 while (PerlIOValid(n)) {
2135 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2136 if (tab && tab->Close) {
2137 if ((*tab->Close)(aTHX_ n) != 0)
2142 PerlIOBase(n)->flags &=
2143 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2149 SETERRNO(EBADF, SS_IVCHAN);
2155 PerlIOBase_eof(pTHX_ PerlIO *f)
2157 PERL_UNUSED_CONTEXT;
2158 if (PerlIOValid(f)) {
2159 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2165 PerlIOBase_error(pTHX_ PerlIO *f)
2167 PERL_UNUSED_CONTEXT;
2168 if (PerlIOValid(f)) {
2169 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2175 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2177 if (PerlIOValid(f)) {
2178 PerlIO * const n = PerlIONext(f);
2179 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2186 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2188 PERL_UNUSED_CONTEXT;
2189 if (PerlIOValid(f)) {
2190 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2195 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2201 arg = sv_dup(arg, param);
2202 SvREFCNT_inc_simple_void_NN(arg);
2206 return newSVsv(arg);
2209 PERL_UNUSED_ARG(param);
2210 return newSVsv(arg);
2215 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2217 PerlIO * const nexto = PerlIONext(o);
2218 if (PerlIOValid(nexto)) {
2219 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2220 if (tab && tab->Dup)
2221 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2223 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2226 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2230 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2231 self ? self->name : "(Null)",
2232 (void*)f, (void*)o, (void*)param);
2233 if (self && self->Getarg)
2234 arg = (*self->Getarg)(aTHX_ o, param, flags);
2235 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2236 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2237 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2243 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2245 /* Must be called with PL_perlio_mutex locked. */
2247 S_more_refcounted_fds(pTHX_ const int new_fd) {
2249 const int old_max = PL_perlio_fd_refcnt_size;
2250 const int new_max = 16 + (new_fd & ~15);
2253 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2254 old_max, new_fd, new_max);
2256 if (new_fd < old_max) {
2260 assert (new_max > new_fd);
2262 /* Use plain realloc() since we need this memory to be really
2263 * global and visible to all the interpreters and/or threads. */
2264 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2268 MUTEX_UNLOCK(&PL_perlio_mutex);
2273 PL_perlio_fd_refcnt_size = new_max;
2274 PL_perlio_fd_refcnt = new_array;
2276 PerlIO_debug("Zeroing %p, %d\n",
2277 (void*)(new_array + old_max),
2280 Zero(new_array + old_max, new_max - old_max, int);
2287 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2288 PERL_UNUSED_CONTEXT;
2292 PerlIOUnix_refcnt_inc(int fd)
2299 MUTEX_LOCK(&PL_perlio_mutex);
2301 if (fd >= PL_perlio_fd_refcnt_size)
2302 S_more_refcounted_fds(aTHX_ fd);
2304 PL_perlio_fd_refcnt[fd]++;
2305 if (PL_perlio_fd_refcnt[fd] <= 0) {
2306 /* diag_listed_as: refcnt_inc: fd %d%s */
2307 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2308 fd, PL_perlio_fd_refcnt[fd]);
2310 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2311 fd, PL_perlio_fd_refcnt[fd]);
2314 MUTEX_UNLOCK(&PL_perlio_mutex);
2317 /* diag_listed_as: refcnt_inc: fd %d%s */
2318 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2323 PerlIOUnix_refcnt_dec(int fd)
2329 MUTEX_LOCK(&PL_perlio_mutex);
2331 if (fd >= PL_perlio_fd_refcnt_size) {
2332 /* diag_listed_as: refcnt_dec: fd %d%s */
2333 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2334 fd, PL_perlio_fd_refcnt_size);
2336 if (PL_perlio_fd_refcnt[fd] <= 0) {
2337 /* diag_listed_as: refcnt_dec: fd %d%s */
2338 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2339 fd, PL_perlio_fd_refcnt[fd]);
2341 cnt = --PL_perlio_fd_refcnt[fd];
2342 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2344 MUTEX_UNLOCK(&PL_perlio_mutex);
2347 /* diag_listed_as: refcnt_dec: fd %d%s */
2348 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2354 PerlIOUnix_refcnt(int fd)
2361 MUTEX_LOCK(&PL_perlio_mutex);
2363 if (fd >= PL_perlio_fd_refcnt_size) {
2364 /* diag_listed_as: refcnt: fd %d%s */
2365 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2366 fd, PL_perlio_fd_refcnt_size);
2368 if (PL_perlio_fd_refcnt[fd] <= 0) {
2369 /* diag_listed_as: refcnt: fd %d%s */
2370 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2371 fd, PL_perlio_fd_refcnt[fd]);
2373 cnt = PL_perlio_fd_refcnt[fd];
2375 MUTEX_UNLOCK(&PL_perlio_mutex);
2378 /* diag_listed_as: refcnt: fd %d%s */
2379 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2385 PerlIO_cleanup(pTHX)
2390 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2392 PerlIO_debug("Cleanup layers\n");
2395 /* Raise STDIN..STDERR refcount so we don't close them */
2396 for (i=0; i < 3; i++)
2397 PerlIOUnix_refcnt_inc(i);
2398 PerlIO_cleantable(aTHX_ &PL_perlio);
2399 /* Restore STDIN..STDERR refcount */
2400 for (i=0; i < 3; i++)
2401 PerlIOUnix_refcnt_dec(i);
2403 if (PL_known_layers) {
2404 PerlIO_list_free(aTHX_ PL_known_layers);
2405 PL_known_layers = NULL;
2407 if (PL_def_layerlist) {
2408 PerlIO_list_free(aTHX_ PL_def_layerlist);
2409 PL_def_layerlist = NULL;
2413 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2417 /* XXX we can't rely on an interpreter being present at this late stage,
2418 XXX so we can't use a function like PerlLIO_write that relies on one
2419 being present (at least in win32) :-(.
2424 /* By now all filehandles should have been closed, so any
2425 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2427 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2428 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2429 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2431 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2432 if (PL_perlio_fd_refcnt[i]) {
2434 my_snprintf(buf, sizeof(buf),
2435 "PerlIO_teardown: fd %d refcnt=%d\n",
2436 i, PL_perlio_fd_refcnt[i]);
2437 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2443 /* Not bothering with PL_perlio_mutex since by now
2444 * all the interpreters are gone. */
2445 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2446 && PL_perlio_fd_refcnt) {
2447 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2448 PL_perlio_fd_refcnt = NULL;
2449 PL_perlio_fd_refcnt_size = 0;
2453 /*--------------------------------------------------------------------------------------*/
2455 * Bottom-most level for UNIX-like case
2459 struct _PerlIO base; /* The generic part */
2460 int fd; /* UNIX like file descriptor */
2461 int oflags; /* open/fcntl flags */
2465 S_lockcnt_dec(pTHX_ const void* f)
2467 PerlIO_lockcnt((PerlIO*)f)--;
2471 /* call the signal handler, and if that handler happens to clear
2472 * this handle, free what we can and return true */
2475 S_perlio_async_run(pTHX_ PerlIO* f) {
2477 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2478 PerlIO_lockcnt(f)++;
2480 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2484 /* we've just run some perl-level code that could have done
2485 * anything, including closing the file or clearing this layer.
2486 * If so, free any lower layers that have already been
2487 * cleared, then return an error. */
2488 while (PerlIOValid(f) &&
2489 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2491 const PerlIOl *l = *f;
2500 PerlIOUnix_oflags(const char *mode)
2503 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2508 if (*++mode == '+') {
2515 oflags = O_CREAT | O_TRUNC;
2516 if (*++mode == '+') {
2525 oflags = O_CREAT | O_APPEND;
2526 if (*++mode == '+') {
2535 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2537 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2538 * of them in, and then bit-and-masking the other them away, won't
2539 * have much of an effect. */
2542 #if O_TEXT != O_BINARY
2549 #if O_TEXT != O_BINARY
2551 oflags &= ~O_BINARY;
2557 /* bit-or:ing with zero O_BINARY would be useless. */
2559 * If neither "t" nor "b" was specified, open the file
2562 * Note that if something else than the zero byte was seen
2563 * here (e.g. bogus mode "rx"), just few lines later we will
2564 * set the errno and invalidate the flags.
2570 if (*mode || oflags == -1) {
2571 SETERRNO(EINVAL, LIB_INVARG);
2578 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2580 PERL_UNUSED_CONTEXT;
2581 return PerlIOSelf(f, PerlIOUnix)->fd;
2585 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2587 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2590 if (PerlLIO_fstat(fd, &st) == 0) {
2591 if (!S_ISREG(st.st_mode)) {
2592 PerlIO_debug("%d is not regular file\n",fd);
2593 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2596 PerlIO_debug("%d _is_ a regular file\n",fd);
2602 PerlIOUnix_refcnt_inc(fd);
2603 PERL_UNUSED_CONTEXT;
2607 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2609 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2610 if (*PerlIONext(f)) {
2611 /* We never call down so do any pending stuff now */
2612 PerlIO_flush(PerlIONext(f));
2614 * XXX could (or should) we retrieve the oflags from the open file
2615 * handle rather than believing the "mode" we are passed in? XXX
2616 * Should the value on NULL mode be 0 or -1?
2618 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2619 mode ? PerlIOUnix_oflags(mode) : -1);
2621 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2627 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2629 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2631 PERL_UNUSED_CONTEXT;
2632 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2634 SETERRNO(ESPIPE, LIB_INVARG);
2636 SETERRNO(EINVAL, LIB_INVARG);
2640 new_loc = PerlLIO_lseek(fd, offset, whence);
2641 if (new_loc == (Off_t) - 1)
2643 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2648 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2649 IV n, const char *mode, int fd, int imode,
2650 int perm, PerlIO *f, int narg, SV **args)
2652 if (PerlIOValid(f)) {
2653 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2654 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2657 if (*mode == IoTYPE_NUMERIC)
2660 imode = PerlIOUnix_oflags(mode);
2662 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2669 const char *path = SvPV_const(*args, len);
2670 if (!IS_SAFE_PATHNAME(path, len, "open"))
2672 fd = PerlLIO_open3(path, imode, perm);
2676 if (*mode == IoTYPE_IMPLICIT)
2679 f = PerlIO_allocate(aTHX);
2681 if (!PerlIOValid(f)) {
2682 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2687 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2688 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2689 if (*mode == IoTYPE_APPEND)
2690 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2697 * FIXME: pop layers ???
2705 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2707 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2709 if (flags & PERLIO_DUP_FD) {
2710 fd = PerlLIO_dup(fd);
2713 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2715 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2716 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2726 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2730 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2732 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2733 #ifdef PERLIO_STD_SPECIAL
2735 return PERLIO_STD_IN(fd, vbuf, count);
2737 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2738 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2742 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2743 if (len >= 0 || errno != EINTR) {
2745 if (errno != EAGAIN) {
2746 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2749 else if (len == 0 && count != 0) {
2750 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2756 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2763 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2767 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2769 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2770 #ifdef PERLIO_STD_SPECIAL
2771 if (fd == 1 || fd == 2)
2772 return PERLIO_STD_OUT(fd, vbuf, count);
2775 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2776 if (len >= 0 || errno != EINTR) {
2778 if (errno != EAGAIN) {
2779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2785 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2792 PerlIOUnix_tell(pTHX_ PerlIO *f)
2794 PERL_UNUSED_CONTEXT;
2796 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2801 PerlIOUnix_close(pTHX_ PerlIO *f)
2804 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2806 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2807 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2808 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2813 SETERRNO(EBADF,SS_IVCHAN);
2816 while (PerlLIO_close(fd) != 0) {
2817 if (errno != EINTR) {
2822 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2826 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2831 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2832 sizeof(PerlIO_funcs),
2839 PerlIOBase_binmode, /* binmode */
2849 PerlIOBase_noop_ok, /* flush */
2850 PerlIOBase_noop_fail, /* fill */
2853 PerlIOBase_clearerr,
2854 PerlIOBase_setlinebuf,
2855 NULL, /* get_base */
2856 NULL, /* get_bufsiz */
2859 NULL, /* set_ptrcnt */
2862 /*--------------------------------------------------------------------------------------*/
2867 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2868 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2869 broken by the last second glibc 2.3 fix
2871 #define STDIO_BUFFER_WRITABLE
2876 struct _PerlIO base;
2877 FILE *stdio; /* The stream */
2881 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2883 PERL_UNUSED_CONTEXT;
2885 if (PerlIOValid(f)) {
2886 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2888 return PerlSIO_fileno(s);
2895 PerlIOStdio_mode(const char *mode, char *tmode)
2897 char * const ret = tmode;
2903 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2911 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2914 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2915 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2916 if (toptab == tab) {
2917 /* Top is already stdio - pop self (duplicate) and use original */
2918 PerlIO_pop(aTHX_ f);
2921 const int fd = PerlIO_fileno(n);
2924 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2925 mode = PerlIOStdio_mode(mode, tmode)))) {
2926 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2927 /* We never call down so do any pending stuff now */
2928 PerlIO_flush(PerlIONext(f));
2929 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2936 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2941 PerlIO_importFILE(FILE *stdio, const char *mode)
2947 int fd0 = fileno(stdio);
2951 if (!mode || !*mode) {
2952 /* We need to probe to see how we can open the stream
2953 so start with read/write and then try write and read
2954 we dup() so that we can fclose without loosing the fd.
2956 Note that the errno value set by a failing fdopen
2957 varies between stdio implementations.
2959 const int fd = PerlLIO_dup(fd0);
2964 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2966 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2969 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2972 /* Don't seem to be able to open */
2978 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2979 s = PerlIOSelf(f, PerlIOStdio);
2981 PerlIOUnix_refcnt_inc(fileno(stdio));
2988 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2989 IV n, const char *mode, int fd, int imode,
2990 int perm, PerlIO *f, int narg, SV **args)
2993 if (PerlIOValid(f)) {
2995 const char * const path = SvPV_const(*args, len);
2996 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2998 if (!IS_SAFE_PATHNAME(path, len, "open"))
3000 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3001 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3006 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3012 const char * const path = SvPV_const(*args, len);
3013 if (!IS_SAFE_PATHNAME(path, len, "open"))
3015 if (*mode == IoTYPE_NUMERIC) {
3017 fd = PerlLIO_open3(path, imode, perm);
3021 bool appended = FALSE;
3023 /* Cygwin wants its 'b' early. */
3025 mode = PerlIOStdio_mode(mode, tmode);
3027 stdio = PerlSIO_fopen(path, mode);
3030 f = PerlIO_allocate(aTHX);
3033 mode = PerlIOStdio_mode(mode, tmode);
3034 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3036 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3037 PerlIOUnix_refcnt_inc(fileno(stdio));
3039 PerlSIO_fclose(stdio);
3051 if (*mode == IoTYPE_IMPLICIT) {
3058 stdio = PerlSIO_stdin;
3061 stdio = PerlSIO_stdout;
3064 stdio = PerlSIO_stderr;
3069 stdio = PerlSIO_fdopen(fd, mode =
3070 PerlIOStdio_mode(mode, tmode));
3074 f = PerlIO_allocate(aTHX);
3076 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3077 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3078 PerlIOUnix_refcnt_inc(fileno(stdio));
3089 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3091 /* This assumes no layers underneath - which is what
3092 happens, but is not how I remember it. NI-S 2001/10/16
3094 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3095 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3096 const int fd = fileno(stdio);
3098 if (flags & PERLIO_DUP_FD) {
3099 const int dfd = PerlLIO_dup(fileno(stdio));
3101 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3106 /* FIXME: To avoid messy error recovery if dup fails
3107 re-use the existing stdio as though flag was not set
3111 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3113 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3115 PerlIOUnix_refcnt_inc(fileno(stdio));
3122 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3124 PERL_UNUSED_CONTEXT;
3126 /* XXX this could use PerlIO_canset_fileno() and
3127 * PerlIO_set_fileno() support from Configure
3129 # if defined(__UCLIBC__)
3130 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3133 # elif defined(__GLIBC__)
3134 /* There may be a better way for GLIBC:
3135 - libio.h defines a flag to not close() on cleanup
3139 # elif defined(__sun)
3142 # elif defined(__hpux)
3146 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3147 your platform does not have special entry try this one.
3148 [For OSF only have confirmation for Tru64 (alpha)
3149 but assume other OSFs will be similar.]
3151 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3154 # elif defined(__FreeBSD__)
3155 /* There may be a better way on FreeBSD:
3156 - we could insert a dummy func in the _close function entry
3157 f->_close = (int (*)(void *)) dummy_close;
3161 # elif defined(__OpenBSD__)
3162 /* There may be a better way on OpenBSD:
3163 - we could insert a dummy func in the _close function entry
3164 f->_close = (int (*)(void *)) dummy_close;
3168 # elif defined(__EMX__)
3169 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3172 # elif defined(__CYGWIN__)
3173 /* There may be a better way on CYGWIN:
3174 - we could insert a dummy func in the _close function entry
3175 f->_close = (int (*)(void *)) dummy_close;
3179 # elif defined(WIN32)
3180 # if defined(UNDER_CE)
3181 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3190 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3191 (which isn't thread safe) instead
3193 # error "Don't know how to set FILE.fileno on your platform"
3201 PerlIOStdio_close(pTHX_ PerlIO *f)
3203 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3209 const int fd = fileno(stdio);
3217 #ifdef SOCKS5_VERSION_NAME
3218 /* Socks lib overrides close() but stdio isn't linked to
3219 that library (though we are) - so we must call close()
3220 on sockets on stdio's behalf.
3223 Sock_size_t optlen = sizeof(int);
3224 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3227 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3228 that a subsequent fileno() on it returns -1. Don't want to croak()
3229 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3230 trying to close an already closed handle which somehow it still has
3231 a reference to. (via.xs, I'm looking at you). */
3232 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3233 /* File descriptor still in use */
3237 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3238 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3240 if (stdio == stdout || stdio == stderr)
3241 return PerlIO_flush(f);
3242 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3243 Use Sarathy's trick from maint-5.6 to invalidate the
3244 fileno slot of the FILE *
3246 result = PerlIO_flush(f);
3248 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3251 MUTEX_LOCK(&PL_perlio_mutex);
3252 /* Right. We need a mutex here because for a brief while we
3253 will have the situation that fd is actually closed. Hence if
3254 a second thread were to get into this block, its dup() would
3255 likely return our fd as its dupfd. (after all, it is closed)
3256 Then if we get to the dup2() first, we blat the fd back
3257 (messing up its temporary as a side effect) only for it to
3258 then close its dupfd (== our fd) in its close(dupfd) */
3260 /* There is, of course, a race condition, that any other thread
3261 trying to input/output/whatever on this fd will be stuffed
3262 for the duration of this little manoeuvrer. Perhaps we
3263 should hold an IO mutex for the duration of every IO
3264 operation if we know that invalidate doesn't work on this
3265 platform, but that would suck, and could kill performance.
3267 Except that correctness trumps speed.
3268 Advice from klortho #11912. */
3270 dupfd = PerlLIO_dup(fd);
3273 MUTEX_UNLOCK(&PL_perlio_mutex);
3274 /* Oh cXap. This isn't going to go well. Not sure if we can
3275 recover from here, or if closing this particular FILE *
3276 is a good idea now. */
3281 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3283 result = PerlSIO_fclose(stdio);
3284 /* We treat error from stdio as success if we invalidated
3285 errno may NOT be expected EBADF
3287 if (invalidate && result != 0) {
3291 #ifdef SOCKS5_VERSION_NAME
3292 /* in SOCKS' case, let close() determine return value */
3296 PerlLIO_dup2(dupfd,fd);
3297 PerlLIO_close(dupfd);
3299 MUTEX_UNLOCK(&PL_perlio_mutex);
3307 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3312 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3314 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3317 STDCHAR *buf = (STDCHAR *) vbuf;
3319 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3320 * stdio does not do that for fread()
3322 const int ch = PerlSIO_fgetc(s);
3329 got = PerlSIO_fread(vbuf, 1, count, s);
3330 if (got == 0 && PerlSIO_ferror(s))
3332 if (got >= 0 || errno != EINTR)
3334 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3336 SETERRNO(0,0); /* just in case */
3342 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3345 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3347 #ifdef STDIO_BUFFER_WRITABLE
3348 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3349 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3350 STDCHAR *base = PerlIO_get_base(f);
3351 SSize_t cnt = PerlIO_get_cnt(f);
3352 STDCHAR *ptr = PerlIO_get_ptr(f);
3353 SSize_t avail = ptr - base;
3355 if (avail > count) {
3359 Move(buf-avail,ptr,avail,STDCHAR);
3362 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3363 if (PerlSIO_feof(s) && unread >= 0)
3364 PerlSIO_clearerr(s);
3369 if (PerlIO_has_cntptr(f)) {
3370 /* We can get pointer to buffer but not its base
3371 Do ungetc() but check chars are ending up in the
3374 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3375 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3377 const int ch = *--buf & 0xFF;
3378 if (ungetc(ch,s) != ch) {
3379 /* ungetc did not work */
3382 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3383 /* Did not change pointer as expected */
3384 if (fgetc(s) != EOF) /* get char back again */
3394 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3400 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3404 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3407 got = PerlSIO_fwrite(vbuf, 1, count,
3408 PerlIOSelf(f, PerlIOStdio)->stdio);
3409 if (got >= 0 || errno != EINTR)
3411 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3413 SETERRNO(0,0); /* just in case */
3419 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3421 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3422 PERL_UNUSED_CONTEXT;
3424 return PerlSIO_fseek(stdio, offset, whence);
3428 PerlIOStdio_tell(pTHX_ PerlIO *f)
3430 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3431 PERL_UNUSED_CONTEXT;
3433 return PerlSIO_ftell(stdio);
3437 PerlIOStdio_flush(pTHX_ PerlIO *f)
3439 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3440 PERL_UNUSED_CONTEXT;
3442 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3443 return PerlSIO_fflush(stdio);
3449 * FIXME: This discards ungetc() and pre-read stuff which is not
3450 * right if this is just a "sync" from a layer above Suspect right
3451 * design is to do _this_ but not have layer above flush this
3452 * layer read-to-read
3455 * Not writeable - sync by attempting a seek
3458 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3466 PerlIOStdio_eof(pTHX_ PerlIO *f)
3468 PERL_UNUSED_CONTEXT;
3470 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3474 PerlIOStdio_error(pTHX_ PerlIO *f)
3476 PERL_UNUSED_CONTEXT;
3478 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3482 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3484 PERL_UNUSED_CONTEXT;
3486 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3490 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3492 PERL_UNUSED_CONTEXT;
3494 #ifdef HAS_SETLINEBUF
3495 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3497 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3503 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3505 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3506 return (STDCHAR*)PerlSIO_get_base(stdio);
3510 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3512 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3513 return PerlSIO_get_bufsiz(stdio);
3517 #ifdef USE_STDIO_PTR
3519 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3521 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3522 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3526 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3528 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3529 return PerlSIO_get_cnt(stdio);
3533 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3535 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3537 #ifdef STDIO_PTR_LVALUE
3538 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3539 #ifdef STDIO_PTR_LVAL_SETS_CNT
3540 assert(PerlSIO_get_cnt(stdio) == (cnt));
3542 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3544 * Setting ptr _does_ change cnt - we are done
3548 #else /* STDIO_PTR_LVALUE */
3550 #endif /* STDIO_PTR_LVALUE */
3553 * Now (or only) set cnt
3555 #ifdef STDIO_CNT_LVALUE
3556 PerlSIO_set_cnt(stdio, cnt);
3557 #else /* STDIO_CNT_LVALUE */
3558 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3559 PerlSIO_set_ptr(stdio,
3560 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3562 #else /* STDIO_PTR_LVAL_SETS_CNT */
3564 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3565 #endif /* STDIO_CNT_LVALUE */
3572 PerlIOStdio_fill(pTHX_ PerlIO *f)
3576 PERL_UNUSED_CONTEXT;
3577 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3579 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3582 * fflush()ing read-only streams can cause trouble on some stdio-s
3584 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3585 if (PerlSIO_fflush(stdio) != 0)
3589 c = PerlSIO_fgetc(stdio);
3592 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3594 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3599 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3601 #ifdef STDIO_BUFFER_WRITABLE
3602 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3603 /* Fake ungetc() to the real buffer in case system's ungetc
3606 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3607 SSize_t cnt = PerlSIO_get_cnt(stdio);
3608 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3609 if (ptr == base+1) {
3610 *--ptr = (STDCHAR) c;
3611 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3612 if (PerlSIO_feof(stdio))
3613 PerlSIO_clearerr(stdio);
3619 if (PerlIO_has_cntptr(f)) {
3621 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3627 /* If buffer snoop scheme above fails fall back to
3630 if (PerlSIO_ungetc(c, stdio) != c)
3638 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3639 sizeof(PerlIO_funcs),
3641 sizeof(PerlIOStdio),
3642 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3646 PerlIOBase_binmode, /* binmode */
3660 PerlIOStdio_clearerr,
3661 PerlIOStdio_setlinebuf,
3663 PerlIOStdio_get_base,
3664 PerlIOStdio_get_bufsiz,
3669 #ifdef USE_STDIO_PTR
3670 PerlIOStdio_get_ptr,
3671 PerlIOStdio_get_cnt,
3672 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3673 PerlIOStdio_set_ptrcnt,
3676 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3681 #endif /* USE_STDIO_PTR */
3684 /* Note that calls to PerlIO_exportFILE() are reversed using
3685 * PerlIO_releaseFILE(), not importFILE. */
3687 PerlIO_exportFILE(PerlIO * f, const char *mode)
3691 if (PerlIOValid(f)) {
3693 int fd = PerlIO_fileno(f);
3698 if (!mode || !*mode) {
3699 mode = PerlIO_modestr(f, buf);
3701 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3705 /* De-link any lower layers so new :stdio sticks */
3707 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3708 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3710 PerlIOUnix_refcnt_inc(fileno(stdio));
3711 /* Link previous lower layers under new one */
3715 /* restore layers list */
3725 PerlIO_findFILE(PerlIO *f)
3730 if (l->tab == &PerlIO_stdio) {
3731 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3734 l = *PerlIONext(&l);
3736 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3737 /* However, we're not really exporting a FILE * to someone else (who
3738 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3739 So we need to undo its reference count increase on the underlying file
3740 descriptor. We have to do this, because if the loop above returns you
3741 the FILE *, then *it* didn't increase any reference count. So there's
3742 only one way to be consistent. */
3743 stdio = PerlIO_exportFILE(f, NULL);
3745 const int fd = fileno(stdio);
3747 PerlIOUnix_refcnt_dec(fd);
3752 /* Use this to reverse PerlIO_exportFILE calls. */
3754 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3759 if (l->tab == &PerlIO_stdio) {
3760 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3761 if (s->stdio == f) { /* not in a loop */
3762 const int fd = fileno(f);
3764 PerlIOUnix_refcnt_dec(fd);
3767 PerlIO_pop(aTHX_ p);
3777 /*--------------------------------------------------------------------------------------*/
3779 * perlio buffer layer
3783 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3785 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3786 const int fd = PerlIO_fileno(f);
3787 if (fd >= 0 && PerlLIO_isatty(fd)) {
3788 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3790 if (*PerlIONext(f)) {
3791 const Off_t posn = PerlIO_tell(PerlIONext(f));
3792 if (posn != (Off_t) - 1) {
3796 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3800 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3801 IV n, const char *mode, int fd, int imode, int perm,
3802 PerlIO *f, int narg, SV **args)
3804 if (PerlIOValid(f)) {
3805 PerlIO *next = PerlIONext(f);
3807 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3808 if (tab && tab->Open)
3810 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3812 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3817 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3819 if (*mode == IoTYPE_IMPLICIT) {
3825 if (tab && tab->Open)
3826 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3829 SETERRNO(EINVAL, LIB_INVARG);
3831 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3833 * if push fails during open, open fails. close will pop us.
3838 fd = PerlIO_fileno(f);
3839 if (init && fd == 2) {
3841 * Initial stderr is unbuffered
3843 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3845 #ifdef PERLIO_USING_CRLF
3846 # ifdef PERLIO_IS_BINMODE_FD
3847 if (PERLIO_IS_BINMODE_FD(fd))
3848 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3852 * do something about failing setmode()? --jhi
3854 PerlLIO_setmode(fd, O_BINARY);
3857 /* Enable line buffering with record-oriented regular files
3858 * so we don't introduce an extraneous record boundary when
3859 * the buffer fills up.
3861 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3863 if (PerlLIO_fstat(fd, &st) == 0
3864 && S_ISREG(st.st_mode)
3865 && (st.st_fab_rfm == FAB$C_VAR
3866 || st.st_fab_rfm == FAB$C_VFC)) {
3867 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3878 * This "flush" is akin to sfio's sync in that it handles files in either
3879 * read or write state. For write state, we put the postponed data through
3880 * the next layers. For read state, we seek() the next layers to the
3881 * offset given by current position in the buffer, and discard the buffer
3882 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3883 * in any case?). Then the pass the stick further in chain.
3886 PerlIOBuf_flush(pTHX_ PerlIO *f)
3888 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3890 PerlIO *n = PerlIONext(f);
3891 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3893 * write() the buffer
3895 const STDCHAR *buf = b->buf;
3896 const STDCHAR *p = buf;
3897 while (p < b->ptr) {
3898 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3902 else if (count < 0 || PerlIO_error(n)) {
3903 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3908 b->posn += (p - buf);
3910 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3911 STDCHAR *buf = PerlIO_get_base(f);
3913 * Note position change
3915 b->posn += (b->ptr - buf);
3916 if (b->ptr < b->end) {
3917 /* We did not consume all of it - try and seek downstream to
3918 our logical position
3920 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3921 /* Reload n as some layers may pop themselves on seek */
3922 b->posn = PerlIO_tell(n = PerlIONext(f));
3925 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3926 data is lost for good - so return saying "ok" having undone
3929 b->posn -= (b->ptr - buf);
3934 b->ptr = b->end = b->buf;
3935 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3936 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3937 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3942 /* This discards the content of the buffer after b->ptr, and rereads
3943 * the buffer from the position off in the layer downstream; here off
3944 * is at offset corresponding to b->ptr - b->buf.
3947 PerlIOBuf_fill(pTHX_ PerlIO *f)
3949 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3950 PerlIO *n = PerlIONext(f);
3953 * Down-stream flush is defined not to loose read data so is harmless.
3954 * we would not normally be fill'ing if there was data left in anycase.
3956 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3958 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3959 PerlIOBase_flush_linebuf(aTHX);
3962 PerlIO_get_base(f); /* allocate via vtable */
3964 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3966 b->ptr = b->end = b->buf;
3968 if (!PerlIOValid(n)) {
3969 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3973 if (PerlIO_fast_gets(n)) {
3975 * Layer below is also buffered. We do _NOT_ want to call its
3976 * ->Read() because that will loop till it gets what we asked for
3977 * which may hang on a pipe etc. Instead take anything it has to
3978 * hand, or ask it to fill _once_.
3980 avail = PerlIO_get_cnt(n);
3982 avail = PerlIO_fill(n);
3984 avail = PerlIO_get_cnt(n);
3986 if (!PerlIO_error(n) && PerlIO_eof(n))
3991 STDCHAR *ptr = PerlIO_get_ptr(n);
3992 const SSize_t cnt = avail;
3993 if (avail > (SSize_t)b->bufsiz)
3995 Copy(ptr, b->buf, avail, STDCHAR);
3996 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4000 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4004 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4006 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4009 b->end = b->buf + avail;
4010 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4015 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4017 if (PerlIOValid(f)) {
4018 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4021 return PerlIOBase_read(aTHX_ f, vbuf, count);
4027 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4029 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4030 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4033 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4038 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4040 * Buffer is already a read buffer, we can overwrite any chars
4041 * which have been read back to buffer start
4043 avail = (b->ptr - b->buf);
4047 * Buffer is idle, set it up so whole buffer is available for
4051 b->end = b->buf + avail;
4053 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4055 * Buffer extends _back_ from where we are now
4057 b->posn -= b->bufsiz;
4059 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4061 * If we have space for more than count, just move count
4069 * In simple stdio-like ungetc() case chars will be already
4072 if (buf != b->ptr) {
4073 Copy(buf, b->ptr, avail, STDCHAR);
4077 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4081 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4087 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4089 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4090 const STDCHAR *buf = (const STDCHAR *) vbuf;
4091 const STDCHAR *flushptr = buf;
4095 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4097 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4098 if (PerlIO_flush(f) != 0) {
4102 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4103 flushptr = buf + count;
4104 while (flushptr > buf && *(flushptr - 1) != '\n')
4108 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4109 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4111 if (flushptr > buf && flushptr <= buf + avail)
4112 avail = flushptr - buf;
4113 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4115 Copy(buf, b->ptr, avail, STDCHAR);
4120 if (buf == flushptr)
4123 if (b->ptr >= (b->buf + b->bufsiz))
4124 if (PerlIO_flush(f) == -1)
4127 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4133 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4136 if ((code = PerlIO_flush(f)) == 0) {
4137 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4138 code = PerlIO_seek(PerlIONext(f), offset, whence);
4140 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4141 b->posn = PerlIO_tell(PerlIONext(f));
4148 PerlIOBuf_tell(pTHX_ PerlIO *f)
4150 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4152 * b->posn is file position where b->buf was read, or will be written
4154 Off_t posn = b->posn;
4155 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4156 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4158 /* As O_APPEND files are normally shared in some sense it is better
4163 /* when file is NOT shared then this is sufficient */
4164 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4166 posn = b->posn = PerlIO_tell(PerlIONext(f));
4170 * If buffer is valid adjust position by amount in buffer
4172 posn += (b->ptr - b->buf);
4178 PerlIOBuf_popped(pTHX_ PerlIO *f)
4180 const IV code = PerlIOBase_popped(aTHX_ f);
4181 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4182 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4185 b->ptr = b->end = b->buf = NULL;
4186 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4191 PerlIOBuf_close(pTHX_ PerlIO *f)
4193 const IV code = PerlIOBase_close(aTHX_ f);
4194 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4195 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4198 b->ptr = b->end = b->buf = NULL;
4199 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4204 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4206 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4213 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4215 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4218 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4219 return (b->end - b->ptr);
4224 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4226 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4227 PERL_UNUSED_CONTEXT;
4231 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4232 Newxz(b->buf,b->bufsiz, STDCHAR);
4234 b->buf = (STDCHAR *) & b->oneword;
4235 b->bufsiz = sizeof(b->oneword);
4237 b->end = b->ptr = b->buf;
4243 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4245 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4248 return (b->end - b->buf);
4252 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4254 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4256 PERL_UNUSED_ARG(cnt);
4261 assert(PerlIO_get_cnt(f) == cnt);
4262 assert(b->ptr >= b->buf);
4263 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4267 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4269 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4274 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4275 sizeof(PerlIO_funcs),
4278 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4282 PerlIOBase_binmode, /* binmode */
4296 PerlIOBase_clearerr,
4297 PerlIOBase_setlinebuf,
4302 PerlIOBuf_set_ptrcnt,
4305 /*--------------------------------------------------------------------------------------*/
4307 * Temp layer to hold unread chars when cannot do it any other way
4311 PerlIOPending_fill(pTHX_ PerlIO *f)
4314 * Should never happen
4321 PerlIOPending_close(pTHX_ PerlIO *f)
4324 * A tad tricky - flush pops us, then we close new top
4327 return PerlIO_close(f);
4331 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4334 * A tad tricky - flush pops us, then we seek new top
4337 return PerlIO_seek(f, offset, whence);
4342 PerlIOPending_flush(pTHX_ PerlIO *f)
4344 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4345 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4349 PerlIO_pop(aTHX_ f);
4354 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4360 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4365 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4367 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4368 PerlIOl * const l = PerlIOBase(f);
4370 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4371 * etc. get muddled when it changes mid-string when we auto-pop.
4373 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4374 (PerlIOBase(PerlIONext(f))->
4375 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4380 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4382 SSize_t avail = PerlIO_get_cnt(f);
4384 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4387 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4388 if (got >= 0 && got < (SSize_t)count) {
4389 const SSize_t more =
4390 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4391 if (more >= 0 || got == 0)
4397 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4398 sizeof(PerlIO_funcs),
4401 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4402 PerlIOPending_pushed,
4405 PerlIOBase_binmode, /* binmode */
4414 PerlIOPending_close,
4415 PerlIOPending_flush,
4419 PerlIOBase_clearerr,
4420 PerlIOBase_setlinebuf,
4425 PerlIOPending_set_ptrcnt,
4430 /*--------------------------------------------------------------------------------------*/
4432 * crlf - translation On read translate CR,LF to "\n" we do this by
4433 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4434 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4436 * c->nl points on the first byte of CR LF pair when it is temporarily
4437 * replaced by LF, or to the last CR of the buffer. In the former case
4438 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4439 * that it ends at c->nl; these two cases can be distinguished by
4440 * *c->nl. c->nl is set during _getcnt() call, and unset during
4441 * _unread() and _flush() calls.
4442 * It only matters for read operations.
4446 PerlIOBuf base; /* PerlIOBuf stuff */
4447 STDCHAR *nl; /* Position of crlf we "lied" about in the
4451 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4452 * Otherwise the :crlf layer would always revert back to
4456 S_inherit_utf8_flag(PerlIO *f)
4458 PerlIO *g = PerlIONext(f);
4459 if (PerlIOValid(g)) {
4460 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4461 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4467 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4470 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4471 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4473 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4474 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4475 PerlIOBase(f)->flags);
4478 /* If the old top layer is a CRLF layer, reactivate it (if
4479 * necessary) and remove this new layer from the stack */
4480 PerlIO *g = PerlIONext(f);
4481 if (PerlIOValid(g)) {
4482 PerlIOl *b = PerlIOBase(g);
4483 if (b && b->tab == &PerlIO_crlf) {
4484 if (!(b->flags & PERLIO_F_CRLF))
4485 b->flags |= PERLIO_F_CRLF;
4486 S_inherit_utf8_flag(g);
4487 PerlIO_pop(aTHX_ f);
4492 S_inherit_utf8_flag(f);
4498 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4500 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4501 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4502 *(c->nl) = NATIVE_0xd;
4505 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4506 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4508 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4509 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4511 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4516 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4517 b->end = b->ptr = b->buf + b->bufsiz;
4518 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4519 b->posn -= b->bufsiz;
4521 while (count > 0 && b->ptr > b->buf) {
4522 const int ch = *--buf;
4524 if (b->ptr - 2 >= b->buf) {
4525 *--(b->ptr) = NATIVE_0xa;
4526 *--(b->ptr) = NATIVE_0xd;
4531 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4532 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4546 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4551 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4553 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4555 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4558 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4559 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4560 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4561 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4563 while (nl < b->end && *nl != NATIVE_0xd)
4565 if (nl < b->end && *nl == NATIVE_0xd) {
4567 if (nl + 1 < b->end) {
4568 if (nl[1] == NATIVE_0xa) {
4574 * Not CR,LF but just CR
4582 * Blast - found CR as last char in buffer
4587 * They may not care, defer work as long as
4591 return (nl - b->ptr);
4595 b->ptr++; /* say we have read it as far as
4596 * flush() is concerned */
4597 b->buf++; /* Leave space in front of buffer */
4598 /* Note as we have moved buf up flush's
4600 will naturally make posn point at CR
4602 b->bufsiz--; /* Buffer is thus smaller */
4603 code = PerlIO_fill(f); /* Fetch some more */
4604 b->bufsiz++; /* Restore size for next time */
4605 b->buf--; /* Point at space */
4606 b->ptr = nl = b->buf; /* Which is what we hand
4608 *nl = NATIVE_0xd; /* Fill in the CR */
4610 goto test; /* fill() call worked */
4612 * CR at EOF - just fall through
4614 /* Should we clear EOF though ??? */
4619 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4625 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4627 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4628 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4634 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4635 /* Deferred CR at end of buffer case - we lied about count */
4648 * Test code - delete when it works ...
4650 IV flags = PerlIOBase(f)->flags;
4651 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4652 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4653 /* Deferred CR at end of buffer case - we lied about count */
4659 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4660 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4661 flags, c->nl, b->end, cnt);
4668 * They have taken what we lied about
4670 *(c->nl) = NATIVE_0xd;
4676 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4680 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4682 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4683 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4685 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4686 const STDCHAR *buf = (const STDCHAR *) vbuf;
4687 const STDCHAR * const ebuf = buf + count;
4690 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4692 while (buf < ebuf) {
4693 const STDCHAR * const eptr = b->buf + b->bufsiz;
4694 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4695 while (buf < ebuf && b->ptr < eptr) {
4697 if ((b->ptr + 2) > eptr) {
4705 *(b->ptr)++ = NATIVE_0xd; /* CR */
4706 *(b->ptr)++ = NATIVE_0xa; /* LF */
4708 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4715 *(b->ptr)++ = *buf++;
4717 if (b->ptr >= eptr) {
4723 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4725 return (buf - (STDCHAR *) vbuf);
4730 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4732 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4734 *(c->nl) = NATIVE_0xd;
4737 return PerlIOBuf_flush(aTHX_ f);
4741 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4743 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4744 /* In text mode - flush any pending stuff and flip it */
4745 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4746 #ifndef PERLIO_USING_CRLF
4747 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4748 PerlIO_pop(aTHX_ f);
4754 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4755 sizeof(PerlIO_funcs),
4758 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4760 PerlIOBuf_popped, /* popped */
4762 PerlIOCrlf_binmode, /* binmode */
4766 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4767 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4768 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4776 PerlIOBase_clearerr,
4777 PerlIOBase_setlinebuf,
4782 PerlIOCrlf_set_ptrcnt,
4786 Perl_PerlIO_stdin(pTHX)
4790 PerlIO_stdstreams(aTHX);
4792 return (PerlIO*)&PL_perlio[1];
4796 Perl_PerlIO_stdout(pTHX)
4800 PerlIO_stdstreams(aTHX);
4802 return (PerlIO*)&PL_perlio[2];
4806 Perl_PerlIO_stderr(pTHX)
4810 PerlIO_stdstreams(aTHX);
4812 return (PerlIO*)&PL_perlio[3];
4815 /*--------------------------------------------------------------------------------------*/
4818 PerlIO_getname(PerlIO *f, char *buf)
4823 bool exported = FALSE;
4824 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4826 stdio = PerlIO_exportFILE(f,0);
4830 name = fgetname(stdio, buf);
4831 if (exported) PerlIO_releaseFILE(f,stdio);
4836 PERL_UNUSED_ARG(buf);
4837 Perl_croak_nocontext("Don't know how to get file name");
4843 /*--------------------------------------------------------------------------------------*/
4845 * Functions which can be called on any kind of PerlIO implemented in
4849 #undef PerlIO_fdopen
4851 PerlIO_fdopen(int fd, const char *mode)
4854 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4859 PerlIO_open(const char *path, const char *mode)
4862 SV *name = sv_2mortal(newSVpv(path, 0));
4863 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4866 #undef Perlio_reopen
4868 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4871 SV *name = sv_2mortal(newSVpv(path,0));
4872 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4877 PerlIO_getc(PerlIO *f)
4881 if ( 1 == PerlIO_read(f, buf, 1) ) {
4882 return (unsigned char) buf[0];
4887 #undef PerlIO_ungetc
4889 PerlIO_ungetc(PerlIO *f, int ch)
4894 if (PerlIO_unread(f, &buf, 1) == 1)
4902 PerlIO_putc(PerlIO *f, int ch)
4906 return PerlIO_write(f, &buf, 1);
4911 PerlIO_puts(PerlIO *f, const char *s)
4914 return PerlIO_write(f, s, strlen(s));
4917 #undef PerlIO_rewind
4919 PerlIO_rewind(PerlIO *f)
4922 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4926 #undef PerlIO_vprintf
4928 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4937 Perl_va_copy(ap, apc);
4938 sv = vnewSVpvf(fmt, &apc);
4941 sv = vnewSVpvf(fmt, &ap);
4943 s = SvPV_const(sv, len);
4944 wrote = PerlIO_write(f, s, len);
4949 #undef PerlIO_printf
4951 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4956 result = PerlIO_vprintf(f, fmt, ap);
4961 #undef PerlIO_stdoutf
4963 PerlIO_stdoutf(const char *fmt, ...)
4969 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4974 #undef PerlIO_tmpfile
4976 PerlIO_tmpfile(void)
4983 const int fd = win32_tmpfd();
4985 f = PerlIO_fdopen(fd, "w+b");
4987 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4989 char tempname[] = "/tmp/PerlIO_XXXXXX";
4990 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
4992 int old_umask = umask(0600);
4994 * I have no idea how portable mkstemp() is ... NI-S
4996 if (tmpdir && *tmpdir) {
4997 /* if TMPDIR is set and not empty, we try that first */
4998 sv = newSVpv(tmpdir, 0);
4999 sv_catpv(sv, tempname + 4);
5000 fd = mkstemp(SvPVX(sv));
5005 /* else we try /tmp */
5006 fd = mkstemp(tempname);
5011 sv_catpv(sv, tempname + 4);
5012 fd = mkstemp(SvPVX(sv));
5016 f = PerlIO_fdopen(fd, "w+");
5018 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5019 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5022 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5023 FILE * const stdio = PerlSIO_tmpfile();
5026 f = PerlIO_fdopen(fileno(stdio), "w+");
5028 # endif /* else HAS_MKSTEMP */
5029 #endif /* else WIN32 */
5036 #endif /* PERLIO_IS_STDIO */
5038 /*======================================================================================*/
5040 * Now some functions in terms of above which may be needed even if we are
5041 * not in true PerlIO mode
5044 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5047 const char *direction = NULL;
5050 * Need to supply default layer info from open.pm
5056 if (mode && mode[0] != 'r') {
5057 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5058 direction = "open>";
5060 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5061 direction = "open<";
5066 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5069 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5074 #undef PerlIO_setpos
5076 PerlIO_setpos(PerlIO *f, SV *pos)
5081 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5082 if (f && len == sizeof(Off_t))
5083 return PerlIO_seek(f, *posn, SEEK_SET);
5085 SETERRNO(EINVAL, SS_IVCHAN);
5089 #undef PerlIO_setpos
5091 PerlIO_setpos(PerlIO *f, SV *pos)
5096 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5097 if (f && len == sizeof(Fpos_t)) {
5098 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5099 return fsetpos64(f, fpos);
5101 return fsetpos(f, fpos);
5105 SETERRNO(EINVAL, SS_IVCHAN);
5111 #undef PerlIO_getpos
5113 PerlIO_getpos(PerlIO *f, SV *pos)
5116 Off_t posn = PerlIO_tell(f);
5117 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5118 return (posn == (Off_t) - 1) ? -1 : 0;
5121 #undef PerlIO_getpos
5123 PerlIO_getpos(PerlIO *f, SV *pos)
5128 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5129 code = fgetpos64(f, &fpos);
5131 code = fgetpos(f, &fpos);
5133 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5138 #if !defined(HAS_VPRINTF)
5141 vprintf(char *pat, char *args)
5143 _doprnt(pat, args, stdout);
5144 return 0; /* wrong, but perl doesn't use the return
5149 vfprintf(FILE *fd, char *pat, char *args)
5151 _doprnt(pat, args, fd);
5152 return 0; /* wrong, but perl doesn't use the return
5160 * c-indentation-style: bsd
5162 * indent-tabs-mode: nil
5165 * ex: set ts=8 sts=4 sw=4 et: