3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
17 /* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
28 #ifdef PERL_IMPLICIT_SYS
34 #define PERLIO_NOT_STDIO 0
36 * This file provides those parts of PerlIO abstraction
37 * which are not #defined in perlio.h.
38 * Which these are depends on various Configure #ifdef's
42 #define PERL_IN_PERLIO_C
45 #ifdef PERL_IMPLICIT_CONTEXT
53 /* Missing proto on LynxOS */
61 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
63 /* Call the callback or PerlIOBase, and return failure. */
64 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
65 if (PerlIOValid(f)) { \
66 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
67 if (tab && tab->callback) \
68 return (*tab->callback) args; \
70 return PerlIOBase_ ## base args; \
73 SETERRNO(EBADF, SS_IVCHAN); \
76 /* Call the callback or fail, and return failure. */
77 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
78 if (PerlIOValid(f)) { \
79 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
80 if (tab && tab->callback) \
81 return (*tab->callback) args; \
82 SETERRNO(EINVAL, LIB_INVARG); \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or PerlIOBase, and be void. */
89 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 (*tab->callback) args; \
95 PerlIOBase_ ## base args; \
98 SETERRNO(EBADF, SS_IVCHAN)
100 /* Call the callback or fail, and be void. */
101 #define Perl_PerlIO_or_fail_void(f, callback, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 SETERRNO(EINVAL, LIB_INVARG); \
110 SETERRNO(EBADF, SS_IVCHAN)
112 #if defined(__osf__) && _XOPEN_SOURCE < 500
113 extern int fseeko(FILE *, off_t, int);
114 extern off_t ftello(FILE *);
117 #define NATIVE_0xd CR_NATIVE
118 #define NATIVE_0xa LF_NATIVE
120 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
123 perlsio_binmode(FILE *fp, int iotype, int mode)
126 * This used to be contents of do_binmode in doio.c
130 PERL_UNUSED_ARG(iotype);
132 if (PerlLIO_setmode(fp, mode) != -1) {
134 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
141 # if defined(USEMYBINMODE)
143 # if defined(__CYGWIN__)
144 PERL_UNUSED_ARG(iotype);
146 if (my_binmode(fp, iotype, mode) != FALSE)
152 PERL_UNUSED_ARG(iotype);
153 PERL_UNUSED_ARG(mode);
160 #define O_ACCMODE 3 /* Assume traditional implementation */
164 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
166 const int result = rawmode & O_ACCMODE;
171 ptype = IoTYPE_RDONLY;
174 ptype = IoTYPE_WRONLY;
182 *writing = (result != O_RDONLY);
184 if (result == O_RDONLY) {
188 else if (rawmode & O_APPEND) {
190 if (result != O_WRONLY)
195 if (result == O_WRONLY)
203 /* Unless O_BINARY is different from zero, bit-and:ing
204 * with it won't do much good. */
205 if (rawmode & O_BINARY)
212 #ifndef PERLIO_LAYERS
214 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
216 if (!names || !*names
217 || strEQ(names, ":crlf")
218 || strEQ(names, ":raw")
219 || strEQ(names, ":bytes")
223 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
231 PerlIO_destruct(pTHX)
236 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
238 return perlsio_binmode(fp, iotype, mode);
242 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
244 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
247 #ifdef PERL_IMPLICIT_SYS
248 return PerlSIO_fdupopen(f);
251 return win32_fdupopen(f);
254 const int fd = PerlLIO_dup(PerlIO_fileno(f));
258 const int omode = djgpp_get_stream_mode(f);
260 const int omode = fcntl(fd, F_GETFL);
262 PerlIO_intmode2str(omode,mode,NULL);
263 /* the r+ is a hack */
264 return PerlIO_fdopen(fd, mode);
269 SETERRNO(EBADF, SS_IVCHAN);
279 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
283 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
284 int imode, int perm, PerlIO *old, int narg, SV **args)
288 Perl_croak(aTHX_ "More than one argument to open");
290 if (*args == &PL_sv_undef)
291 return PerlIO_tmpfile();
294 const char *name = SvPV_const(*args, len);
295 if (!IS_SAFE_PATHNAME(name, len, "open"))
298 if (*mode == IoTYPE_NUMERIC) {
299 fd = PerlLIO_open3(name, imode, perm);
301 return PerlIO_fdopen(fd, mode + 1);
304 return PerlIO_reopen(name, mode, old);
307 return PerlIO_open(name, mode);
312 return PerlIO_fdopen(fd, (char *) mode);
317 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
318 XS(XS_PerlIO__Layer__find)
322 Perl_croak(aTHX_ "Usage class->find(name[,load])");
324 const char * const name = SvPV_nolen_const(ST(1));
325 ST(0) = (strEQ(name, "crlf")
326 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
333 Perl_boot_core_PerlIO(pTHX)
335 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
341 /*======================================================================================*/
343 * Implement all the PerlIO interface ourselves.
349 PerlIO_debug(const char *fmt, ...)
358 if (!PL_perlio_debug_fd) {
360 PerlProc_getuid() == PerlProc_geteuid() &&
361 PerlProc_getgid() == PerlProc_getegid()) {
362 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
365 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
367 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
369 /* tainting or set*id, so ignore the environment and send the
370 debug output to stderr, like other -D switches. */
371 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
374 if (PL_perlio_debug_fd > 0) {
376 const char * const s = CopFILE(PL_curcop);
377 /* Use fixed buffer as sv_catpvf etc. needs SVs */
379 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
380 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
381 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
383 const char *s = CopFILE(PL_curcop);
385 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
386 (IV) CopLINE(PL_curcop));
387 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
389 s = SvPV_const(sv, len);
390 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
397 /*--------------------------------------------------------------------------------------*/
400 * Inner level routines
403 /* check that the head field of each layer points back to the head */
406 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
408 PerlIO_verify_head(pTHX_ PerlIO *f)
412 #ifndef PERL_IMPLICIT_SYS
417 p = head = PerlIOBase(f)->head;
420 assert(p->head == head);
421 if (p == (PerlIOl*)f)
428 # define VERIFY_HEAD(f)
433 * Table of pointers to the PerlIO structs (malloc'ed)
435 #define PERLIO_TABLE_SIZE 64
438 PerlIO_init_table(pTHX)
442 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
448 PerlIO_allocate(pTHX)
451 * Find a free slot in the table, allocating new table as necessary
456 while ((f = *last)) {
458 last = (PerlIOl **) (f);
459 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
460 if (!((++f)->next)) {
465 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
469 *last = (PerlIOl*) f++;
472 f->flags = 0; /* lockcnt */
478 #undef PerlIO_fdupopen
480 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
482 if (PerlIOValid(f)) {
483 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
484 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
486 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
488 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
492 SETERRNO(EBADF, SS_IVCHAN);
498 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
500 PerlIOl * const table = *tablep;
503 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
504 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
505 PerlIOl * const f = table + i;
507 PerlIO_close(&(f->next));
517 PerlIO_list_alloc(pTHX)
521 Newxz(list, 1, PerlIO_list_t);
527 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
530 if (--list->refcnt == 0) {
533 for (i = 0; i < list->cur; i++)
534 SvREFCNT_dec(list->array[i].arg);
535 Safefree(list->array);
543 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
548 if (list->cur >= list->len) {
551 Renew(list->array, list->len, PerlIO_pair_t);
553 Newx(list->array, list->len, PerlIO_pair_t);
555 p = &(list->array[list->cur++]);
557 if ((p->arg = arg)) {
558 SvREFCNT_inc_simple_void_NN(arg);
563 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
565 PerlIO_list_t *list = NULL;
568 list = PerlIO_list_alloc(aTHX);
569 for (i=0; i < proto->cur; i++) {
570 SV *arg = proto->array[i].arg;
573 arg = sv_dup(arg, param);
575 PERL_UNUSED_ARG(param);
577 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
584 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
587 PerlIOl **table = &proto->Iperlio;
590 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
591 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
592 PerlIO_init_table(aTHX);
593 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
594 while ((f = *table)) {
596 table = (PerlIOl **) (f++);
597 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
599 (void) fp_dup(&(f->next), 0, param);
606 PERL_UNUSED_ARG(proto);
607 PERL_UNUSED_ARG(param);
612 PerlIO_destruct(pTHX)
614 PerlIOl **table = &PL_perlio;
617 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
619 while ((f = *table)) {
621 table = (PerlIOl **) (f++);
622 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
623 PerlIO *x = &(f->next);
626 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
627 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
641 PerlIO_pop(pTHX_ PerlIO *f)
643 const PerlIOl *l = *f;
646 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
647 l->tab ? l->tab->name : "(Null)") );
648 if (l->tab && l->tab->Popped) {
650 * If popped returns non-zero do not free its layer structure
651 * it has either done so itself, or it is shared and still in
654 if ((*l->tab->Popped) (aTHX_ f) != 0)
657 if (PerlIO_lockcnt(f)) {
658 /* we're in use; defer freeing the structure */
659 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
660 PerlIOBase(f)->tab = NULL;
670 /* Return as an array the stack of layers on a filehandle. Note that
671 * the stack is returned top-first in the array, and there are three
672 * times as many array elements as there are layers in the stack: the
673 * first element of a layer triplet is the name, the second one is the
674 * arguments, and the third one is the flags. */
677 PerlIO_get_layers(pTHX_ PerlIO *f)
679 AV * const av = newAV();
681 if (PerlIOValid(f)) {
682 PerlIOl *l = PerlIOBase(f);
685 /* There is some collusion in the implementation of
686 XS_PerlIO_get_layers - it knows that name and flags are
687 generated as fresh SVs here, and takes advantage of that to
688 "copy" them by taking a reference. If it changes here, it needs
689 to change there too. */
690 SV * const name = l->tab && l->tab->name ?
691 newSVpv(l->tab->name, 0) : &PL_sv_undef;
692 SV * const arg = l->tab && l->tab->Getarg ?
693 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
696 av_push(av, newSViv((IV)l->flags));
704 /*--------------------------------------------------------------------------------------*/
706 * XS Interface for perl code
710 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
714 if ((SSize_t) len <= 0)
716 for (i = 0; i < PL_known_layers->cur; i++) {
717 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
718 const STRLEN this_len = strlen(f->name);
719 if (this_len == len && memEQ(f->name, name, len)) {
720 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
724 if (load && PL_subname && PL_def_layerlist
725 && PL_def_layerlist->cur >= 2) {
726 if (PL_in_load_module) {
727 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
730 SV * const pkgsv = newSVpvs("PerlIO");
731 SV * const layer = newSVpvn(name, len);
732 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
734 SAVEBOOL(PL_in_load_module);
736 SAVEGENERICSV(PL_warnhook);
737 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
739 PL_in_load_module = TRUE;
741 * The two SVs are magically freed by load_module
743 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
745 return PerlIO_find_layer(aTHX_ name, len, 0);
748 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
752 #ifdef USE_ATTRIBUTES_FOR_PERLIO
755 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
758 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
759 PerlIO * const ifp = IoIFP(io);
760 PerlIO * const ofp = IoOFP(io);
761 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
762 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
768 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
771 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
772 PerlIO * const ifp = IoIFP(io);
773 PerlIO * const ofp = IoOFP(io);
774 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
775 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
781 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
783 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
788 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
790 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
794 MGVTBL perlio_vtab = {
802 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
803 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
806 SV * const sv = SvRV(ST(1));
807 AV * const av = newAV();
811 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
813 mg = mg_find(sv, PERL_MAGIC_ext);
814 mg->mg_virtual = &perlio_vtab;
816 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
817 for (i = 2; i < items; i++) {
819 const char * const name = SvPV_const(ST(i), len);
820 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
822 av_push(av, SvREFCNT_inc_simple_NN(layer));
833 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
836 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
838 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
839 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
843 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
844 XS(XS_PerlIO__Layer__NoWarnings)
846 /* This is used as a %SIG{__WARN__} handler to suppress warnings
847 during loading of layers.
851 PERL_UNUSED_VAR(items);
854 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
858 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
859 XS(XS_PerlIO__Layer__find)
864 Perl_croak(aTHX_ "Usage class->find(name[,load])");
867 const char * const name = SvPV_const(ST(1), len);
868 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
869 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
871 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
878 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
880 if (!PL_known_layers)
881 PL_known_layers = PerlIO_list_alloc(aTHX);
882 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
883 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
887 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
890 const char *s = names;
892 while (isSPACE(*s) || *s == ':')
897 const char *as = NULL;
899 if (!isIDFIRST(*s)) {
901 * Message is consistent with how attribute lists are
902 * passed. Even though this means "foo : : bar" is
903 * seen as an invalid separator character.
905 const char q = ((*s == '\'') ? '"' : '\'');
906 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
907 "Invalid separator character %c%c%c in PerlIO layer specification %s",
909 SETERRNO(EINVAL, LIB_INVARG);
914 } while (isWORDCHAR(*e));
930 * It's a nul terminated string, not allowed
931 * to \ the terminating null. Anything other
932 * character is passed over.
942 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
943 "Argument list not closed for PerlIO layer \"%.*s\"",
955 PerlIO_funcs * const layer =
956 PerlIO_find_layer(aTHX_ s, llen, 1);
960 arg = newSVpvn(as, alen);
961 PerlIO_list_push(aTHX_ av, layer,
962 (arg) ? arg : &PL_sv_undef);
966 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
979 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
981 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
982 #ifdef PERLIO_USING_CRLF
985 if (PerlIO_stdio.Set_ptrcnt)
988 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
989 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
993 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
995 return av->array[n].arg;
999 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1001 if (n >= 0 && n < av->cur) {
1002 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1003 av->array[n].funcs->name) );
1004 return av->array[n].funcs;
1007 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1012 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1014 PERL_UNUSED_ARG(mode);
1015 PERL_UNUSED_ARG(arg);
1016 PERL_UNUSED_ARG(tab);
1017 if (PerlIOValid(f)) {
1019 PerlIO_pop(aTHX_ f);
1025 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1026 sizeof(PerlIO_funcs),
1029 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1049 NULL, /* get_base */
1050 NULL, /* get_bufsiz */
1053 NULL, /* set_ptrcnt */
1057 PerlIO_default_layers(pTHX)
1059 if (!PL_def_layerlist) {
1060 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1061 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1062 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1063 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1065 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1067 osLayer = &PerlIO_win32;
1070 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1071 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1072 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1077 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1080 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1083 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1086 if (PL_def_layerlist->cur < 2) {
1087 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1089 return PL_def_layerlist;
1093 Perl_boot_core_PerlIO(pTHX)
1095 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1096 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1099 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1100 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1104 PerlIO_default_layer(pTHX_ I32 n)
1106 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1109 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1112 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1113 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1116 PerlIO_stdstreams(pTHX)
1119 PerlIO_init_table(aTHX);
1120 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1121 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1122 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1127 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1130 if (tab->fsize != sizeof(PerlIO_funcs)) {
1132 "%s (%"UVuf") does not match %s (%"UVuf")",
1133 "PerlIO layer function table size", (UV)tab->fsize,
1134 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1138 if (tab->size < sizeof(PerlIOl)) {
1140 "%s (%"UVuf") smaller than %s (%"UVuf")",
1141 "PerlIO layer instance size", (UV)tab->size,
1142 "size expected by this perl", (UV)sizeof(PerlIOl) );
1144 /* Real layer with a data area */
1147 Newxz(temp, tab->size, char);
1151 l->tab = (PerlIO_funcs*) tab;
1152 l->head = ((PerlIOl*)f)->head;
1154 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1155 (void*)f, tab->name,
1156 (mode) ? mode : "(Null)", (void*)arg) );
1157 if (*l->tab->Pushed &&
1159 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1160 PerlIO_pop(aTHX_ f);
1169 /* Pseudo-layer where push does its own stack adjust */
1170 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1171 (mode) ? mode : "(Null)", (void*)arg) );
1173 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1181 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1182 IV n, const char *mode, int fd, int imode, int perm,
1183 PerlIO *old, int narg, SV **args)
1185 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1186 if (tab && tab->Open) {
1187 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1188 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1194 SETERRNO(EINVAL, LIB_INVARG);
1199 PerlIOBase_binmode(pTHX_ PerlIO *f)
1201 if (PerlIOValid(f)) {
1202 /* Is layer suitable for raw stream ? */
1203 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1204 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1205 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1208 /* Not suitable - pop it */
1209 PerlIO_pop(aTHX_ f);
1217 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1219 PERL_UNUSED_ARG(mode);
1220 PERL_UNUSED_ARG(arg);
1221 PERL_UNUSED_ARG(tab);
1223 if (PerlIOValid(f)) {
1228 * Strip all layers that are not suitable for a raw stream
1231 while (t && (l = *t)) {
1232 if (l->tab && l->tab->Binmode) {
1233 /* Has a handler - normal case */
1234 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1236 /* Layer still there - move down a layer */
1245 /* No handler - pop it */
1246 PerlIO_pop(aTHX_ t);
1249 if (PerlIOValid(f)) {
1250 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1251 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1259 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1260 PerlIO_list_t *layers, IV n, IV max)
1264 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1266 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1277 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1281 save_scalar(PL_errgv);
1283 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1284 code = PerlIO_parse_layers(aTHX_ layers, names);
1286 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1288 PerlIO_list_free(aTHX_ layers);
1295 /*--------------------------------------------------------------------------------------*/
1297 * Given the abstraction above the public API functions
1301 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1303 PERL_UNUSED_ARG(iotype);
1304 PERL_UNUSED_ARG(mode);
1307 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1308 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1309 PerlIOBase(f)->tab->name : "(Null)",
1310 iotype, mode, (names) ? names : "(Null)") );
1313 /* Do not flush etc. if (e.g.) switching encodings.
1314 if a pushed layer knows it needs to flush lower layers
1315 (for example :unix which is never going to call them)
1316 it can do the flush when it is pushed.
1318 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1321 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1322 #ifdef PERLIO_USING_CRLF
1323 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1324 O_BINARY so we can look for it in mode.
1326 if (!(mode & O_BINARY)) {
1328 /* FIXME?: Looking down the layer stack seems wrong,
1329 but is a way of reaching past (say) an encoding layer
1330 to flip CRLF-ness of the layer(s) below
1333 /* Perhaps we should turn on bottom-most aware layer
1334 e.g. Ilya's idea that UNIX TTY could serve
1336 if (PerlIOBase(f)->tab &&
1337 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1339 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1340 /* Not in text mode - flush any pending stuff and flip it */
1342 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1344 /* Only need to turn it on in one layer so we are done */
1349 /* Not finding a CRLF aware layer presumably means we are binary
1350 which is not what was requested - so we failed
1351 We _could_ push :crlf layer but so could caller
1356 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1357 So code that used to be here is now in PerlIORaw_pushed().
1359 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1364 PerlIO__close(pTHX_ PerlIO *f)
1366 if (PerlIOValid(f)) {
1367 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1368 if (tab && tab->Close)
1369 return (*tab->Close)(aTHX_ f);
1371 return PerlIOBase_close(aTHX_ f);
1374 SETERRNO(EBADF, SS_IVCHAN);
1380 Perl_PerlIO_close(pTHX_ PerlIO *f)
1382 const int code = PerlIO__close(aTHX_ f);
1383 while (PerlIOValid(f)) {
1384 PerlIO_pop(aTHX_ f);
1385 if (PerlIO_lockcnt(f))
1386 /* we're in use; the 'pop' deferred freeing the structure */
1393 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1395 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1399 static PerlIO_funcs *
1400 PerlIO_layer_from_ref(pTHX_ SV *sv)
1403 * For any scalar type load the handler which is bundled with perl
1405 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1406 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1407 /* This isn't supposed to happen, since PerlIO::scalar is core,
1408 * but could happen anyway in smaller installs or with PAR */
1410 /* diag_listed_as: Unknown PerlIO layer "%s" */
1411 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1416 * For other types allow if layer is known but don't try and load it
1418 switch (SvTYPE(sv)) {
1420 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1422 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1424 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1426 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1433 PerlIO_resolve_layers(pTHX_ const char *layers,
1434 const char *mode, int narg, SV **args)
1436 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1439 PerlIO_stdstreams(aTHX);
1441 SV * const arg = *args;
1443 * If it is a reference but not an object see if we have a handler
1446 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1447 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1449 def = PerlIO_list_alloc(aTHX);
1450 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1454 * Don't fail if handler cannot be found :via(...) etc. may do
1455 * something sensible else we will just stringfy and open
1460 if (!layers || !*layers)
1461 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1462 if (layers && *layers) {
1465 av = PerlIO_clone_list(aTHX_ def, NULL);
1470 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1474 PerlIO_list_free(aTHX_ av);
1486 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1487 int imode, int perm, PerlIO *f, int narg, SV **args)
1489 if (!f && narg == 1 && *args == &PL_sv_undef) {
1490 if ((f = PerlIO_tmpfile())) {
1491 if (!layers || !*layers)
1492 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1493 if (layers && *layers)
1494 PerlIO_apply_layers(aTHX_ f, mode, layers);
1498 PerlIO_list_t *layera;
1500 PerlIO_funcs *tab = NULL;
1501 if (PerlIOValid(f)) {
1503 * This is "reopen" - it is not tested as perl does not use it
1507 layera = PerlIO_list_alloc(aTHX);
1510 if (l->tab && l->tab->Getarg)
1511 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1512 PerlIO_list_push(aTHX_ layera, l->tab,
1513 (arg) ? arg : &PL_sv_undef);
1515 l = *PerlIONext(&l);
1519 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1525 * Start at "top" of layer stack
1527 n = layera->cur - 1;
1529 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1538 * Found that layer 'n' can do opens - call it
1540 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1541 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1543 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1544 tab->name, layers ? layers : "(Null)", mode, fd,
1545 imode, perm, (void*)f, narg, (void*)args) );
1547 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1550 SETERRNO(EINVAL, LIB_INVARG);
1554 if (n + 1 < layera->cur) {
1556 * More layers above the one that we used to open -
1559 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1560 /* If pushing layers fails close the file */
1567 PerlIO_list_free(aTHX_ layera);
1574 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1576 PERL_ARGS_ASSERT_PERLIO_READ;
1578 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1582 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1584 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1586 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1590 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1592 PERL_ARGS_ASSERT_PERLIO_WRITE;
1594 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1598 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1600 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1604 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1606 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1610 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1614 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1616 if (tab && tab->Flush)
1617 return (*tab->Flush) (aTHX_ f);
1619 return 0; /* If no Flush defined, silently succeed. */
1622 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1623 SETERRNO(EBADF, SS_IVCHAN);
1629 * Is it good API design to do flush-all on NULL, a potentially
1630 * erroneous input? Maybe some magical value (PerlIO*
1631 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1632 * things on fflush(NULL), but should we be bound by their design
1635 PerlIOl **table = &PL_perlio;
1638 while ((ff = *table)) {
1640 table = (PerlIOl **) (ff++);
1641 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1642 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1652 PerlIOBase_flush_linebuf(pTHX)
1654 PerlIOl **table = &PL_perlio;
1656 while ((f = *table)) {
1658 table = (PerlIOl **) (f++);
1659 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1661 && (PerlIOBase(&(f->next))->
1662 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1663 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1664 PerlIO_flush(&(f->next));
1671 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1673 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1677 PerlIO_isutf8(PerlIO *f)
1680 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1682 SETERRNO(EBADF, SS_IVCHAN);
1688 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1690 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1694 Perl_PerlIO_error(pTHX_ PerlIO *f)
1696 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1700 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1702 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1706 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1708 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1712 PerlIO_has_base(PerlIO *f)
1714 if (PerlIOValid(f)) {
1715 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1718 return (tab->Get_base != NULL);
1725 PerlIO_fast_gets(PerlIO *f)
1727 if (PerlIOValid(f)) {
1728 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1729 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1732 return (tab->Set_ptrcnt != NULL);
1740 PerlIO_has_cntptr(PerlIO *f)
1742 if (PerlIOValid(f)) {
1743 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1746 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1753 PerlIO_canset_cnt(PerlIO *f)
1755 if (PerlIOValid(f)) {
1756 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1759 return (tab->Set_ptrcnt != NULL);
1766 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1768 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1772 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1774 /* Note that Get_bufsiz returns a Size_t */
1775 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1779 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1781 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1785 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1787 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1791 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1793 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1797 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1799 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1803 /*--------------------------------------------------------------------------------------*/
1805 * utf8 and raw dummy layers
1809 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1811 PERL_UNUSED_CONTEXT;
1812 PERL_UNUSED_ARG(mode);
1813 PERL_UNUSED_ARG(arg);
1814 if (PerlIOValid(f)) {
1815 if (tab && tab->kind & PERLIO_K_UTF8)
1816 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1818 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1824 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1825 sizeof(PerlIO_funcs),
1828 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1848 NULL, /* get_base */
1849 NULL, /* get_bufsiz */
1852 NULL, /* set_ptrcnt */
1855 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1856 sizeof(PerlIO_funcs),
1859 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1879 NULL, /* get_base */
1880 NULL, /* get_bufsiz */
1883 NULL, /* set_ptrcnt */
1886 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1887 sizeof(PerlIO_funcs),
1910 NULL, /* get_base */
1911 NULL, /* get_bufsiz */
1914 NULL, /* set_ptrcnt */
1916 /*--------------------------------------------------------------------------------------*/
1917 /*--------------------------------------------------------------------------------------*/
1919 * "Methods" of the "base class"
1923 PerlIOBase_fileno(pTHX_ PerlIO *f)
1925 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1929 PerlIO_modestr(PerlIO * f, char *buf)
1932 if (PerlIOValid(f)) {
1933 const IV flags = PerlIOBase(f)->flags;
1934 if (flags & PERLIO_F_APPEND) {
1936 if (flags & PERLIO_F_CANREAD) {
1940 else if (flags & PERLIO_F_CANREAD) {
1942 if (flags & PERLIO_F_CANWRITE)
1945 else if (flags & PERLIO_F_CANWRITE) {
1947 if (flags & PERLIO_F_CANREAD) {
1951 #ifdef PERLIO_USING_CRLF
1952 if (!(flags & PERLIO_F_CRLF))
1962 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1964 PerlIOl * const l = PerlIOBase(f);
1965 PERL_UNUSED_CONTEXT;
1966 PERL_UNUSED_ARG(arg);
1968 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1969 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1970 if (tab && tab->Set_ptrcnt != NULL)
1971 l->flags |= PERLIO_F_FASTGETS;
1973 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1977 l->flags |= PERLIO_F_CANREAD;
1980 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1983 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1986 SETERRNO(EINVAL, LIB_INVARG);
1992 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1995 l->flags &= ~PERLIO_F_CRLF;
1998 l->flags |= PERLIO_F_CRLF;
2001 SETERRNO(EINVAL, LIB_INVARG);
2008 l->flags |= l->next->flags &
2009 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2015 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2016 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2017 l->flags, PerlIO_modestr(f, temp));
2024 PerlIOBase_popped(pTHX_ PerlIO *f)
2026 PERL_UNUSED_CONTEXT;
2032 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2035 * Save the position as current head considers it
2037 const Off_t old = PerlIO_tell(f);
2038 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2039 PerlIOSelf(f, PerlIOBuf)->posn = old;
2040 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2044 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2046 STDCHAR *buf = (STDCHAR *) vbuf;
2048 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2049 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2050 SETERRNO(EBADF, SS_IVCHAN);
2051 PerlIO_save_errno(f);
2057 SSize_t avail = PerlIO_get_cnt(f);
2060 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2062 STDCHAR *ptr = PerlIO_get_ptr(f);
2063 Copy(ptr, buf, take, STDCHAR);
2064 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2067 if (avail == 0) /* set_ptrcnt could have reset avail */
2070 if (count > 0 && avail <= 0) {
2071 if (PerlIO_fill(f) != 0)
2076 return (buf - (STDCHAR *) vbuf);
2082 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2084 PERL_UNUSED_CONTEXT;
2090 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2092 PERL_UNUSED_CONTEXT;
2098 PerlIOBase_close(pTHX_ PerlIO *f)
2101 if (PerlIOValid(f)) {
2102 PerlIO *n = PerlIONext(f);
2103 code = PerlIO_flush(f);
2104 PerlIOBase(f)->flags &=
2105 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2106 while (PerlIOValid(n)) {
2107 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2108 if (tab && tab->Close) {
2109 if ((*tab->Close)(aTHX_ n) != 0)
2114 PerlIOBase(n)->flags &=
2115 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2121 SETERRNO(EBADF, SS_IVCHAN);
2127 PerlIOBase_eof(pTHX_ PerlIO *f)
2129 PERL_UNUSED_CONTEXT;
2130 if (PerlIOValid(f)) {
2131 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2137 PerlIOBase_error(pTHX_ PerlIO *f)
2139 PERL_UNUSED_CONTEXT;
2140 if (PerlIOValid(f)) {
2141 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2147 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2149 if (PerlIOValid(f)) {
2150 PerlIO * const n = PerlIONext(f);
2151 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2158 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2160 PERL_UNUSED_CONTEXT;
2161 if (PerlIOValid(f)) {
2162 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2167 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2173 arg = sv_dup(arg, param);
2174 SvREFCNT_inc_simple_void_NN(arg);
2178 return newSVsv(arg);
2181 PERL_UNUSED_ARG(param);
2182 return newSVsv(arg);
2187 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2189 PerlIO * const nexto = PerlIONext(o);
2190 if (PerlIOValid(nexto)) {
2191 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2192 if (tab && tab->Dup)
2193 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2195 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2198 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2202 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2204 (void*)f, (void*)o, (void*)param) );
2206 arg = (*self->Getarg)(aTHX_ o, param, flags);
2207 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2208 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2209 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2215 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2217 /* Must be called with PL_perlio_mutex locked. */
2219 S_more_refcounted_fds(pTHX_ const int new_fd)
2220 PERL_TSA_REQUIRES(PL_perlio_mutex)
2223 const int old_max = PL_perlio_fd_refcnt_size;
2224 const int new_max = 16 + (new_fd & ~15);
2227 #ifndef PERL_IMPLICIT_SYS
2228 PERL_UNUSED_CONTEXT;
2231 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2232 old_max, new_fd, new_max) );
2234 if (new_fd < old_max) {
2238 assert (new_max > new_fd);
2240 /* Use plain realloc() since we need this memory to be really
2241 * global and visible to all the interpreters and/or threads. */
2242 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2246 MUTEX_UNLOCK(&PL_perlio_mutex);
2251 PL_perlio_fd_refcnt_size = new_max;
2252 PL_perlio_fd_refcnt = new_array;
2254 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2255 (void*)(new_array + old_max),
2256 new_max - old_max) );
2258 Zero(new_array + old_max, new_max - old_max, int);
2265 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2266 PERL_UNUSED_CONTEXT;
2270 PerlIOUnix_refcnt_inc(int fd)
2277 MUTEX_LOCK(&PL_perlio_mutex);
2279 if (fd >= PL_perlio_fd_refcnt_size)
2280 S_more_refcounted_fds(aTHX_ fd);
2282 PL_perlio_fd_refcnt[fd]++;
2283 if (PL_perlio_fd_refcnt[fd] <= 0) {
2284 /* diag_listed_as: refcnt_inc: fd %d%s */
2285 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2286 fd, PL_perlio_fd_refcnt[fd]);
2288 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2289 fd, PL_perlio_fd_refcnt[fd]) );
2292 MUTEX_UNLOCK(&PL_perlio_mutex);
2295 /* diag_listed_as: refcnt_inc: fd %d%s */
2296 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2301 PerlIOUnix_refcnt_dec(int fd)
2311 MUTEX_LOCK(&PL_perlio_mutex);
2313 if (fd >= PL_perlio_fd_refcnt_size) {
2314 /* diag_listed_as: refcnt_dec: fd %d%s */
2315 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2316 fd, PL_perlio_fd_refcnt_size);
2318 if (PL_perlio_fd_refcnt[fd] <= 0) {
2319 /* diag_listed_as: refcnt_dec: fd %d%s */
2320 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2321 fd, PL_perlio_fd_refcnt[fd]);
2323 cnt = --PL_perlio_fd_refcnt[fd];
2324 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2326 MUTEX_UNLOCK(&PL_perlio_mutex);
2329 /* diag_listed_as: refcnt_dec: fd %d%s */
2330 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2336 PerlIOUnix_refcnt(int fd)
2343 MUTEX_LOCK(&PL_perlio_mutex);
2345 if (fd >= PL_perlio_fd_refcnt_size) {
2346 /* diag_listed_as: refcnt: fd %d%s */
2347 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2348 fd, PL_perlio_fd_refcnt_size);
2350 if (PL_perlio_fd_refcnt[fd] <= 0) {
2351 /* diag_listed_as: refcnt: fd %d%s */
2352 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2353 fd, PL_perlio_fd_refcnt[fd]);
2355 cnt = PL_perlio_fd_refcnt[fd];
2357 MUTEX_UNLOCK(&PL_perlio_mutex);
2360 /* diag_listed_as: refcnt: fd %d%s */
2361 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2367 PerlIO_cleanup(pTHX)
2371 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2373 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2376 /* Raise STDIN..STDERR refcount so we don't close them */
2377 for (i=0; i < 3; i++)
2378 PerlIOUnix_refcnt_inc(i);
2379 PerlIO_cleantable(aTHX_ &PL_perlio);
2380 /* Restore STDIN..STDERR refcount */
2381 for (i=0; i < 3; i++)
2382 PerlIOUnix_refcnt_dec(i);
2384 if (PL_known_layers) {
2385 PerlIO_list_free(aTHX_ PL_known_layers);
2386 PL_known_layers = NULL;
2388 if (PL_def_layerlist) {
2389 PerlIO_list_free(aTHX_ PL_def_layerlist);
2390 PL_def_layerlist = NULL;
2394 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2398 /* XXX we can't rely on an interpreter being present at this late stage,
2399 XXX so we can't use a function like PerlLIO_write that relies on one
2400 being present (at least in win32) :-(.
2405 /* By now all filehandles should have been closed, so any
2406 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2408 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2409 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2410 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2412 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2413 if (PL_perlio_fd_refcnt[i]) {
2415 my_snprintf(buf, sizeof(buf),
2416 "PerlIO_teardown: fd %d refcnt=%d\n",
2417 i, PL_perlio_fd_refcnt[i]);
2418 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2424 /* Not bothering with PL_perlio_mutex since by now
2425 * all the interpreters are gone. */
2426 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2427 && PL_perlio_fd_refcnt) {
2428 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2429 PL_perlio_fd_refcnt = NULL;
2430 PL_perlio_fd_refcnt_size = 0;
2434 /*--------------------------------------------------------------------------------------*/
2436 * Bottom-most level for UNIX-like case
2440 struct _PerlIO base; /* The generic part */
2441 int fd; /* UNIX like file descriptor */
2442 int oflags; /* open/fcntl flags */
2446 S_lockcnt_dec(pTHX_ const void* f)
2448 #ifndef PERL_IMPLICIT_SYS
2449 PERL_UNUSED_CONTEXT;
2451 PerlIO_lockcnt((PerlIO*)f)--;
2455 /* call the signal handler, and if that handler happens to clear
2456 * this handle, free what we can and return true */
2459 S_perlio_async_run(pTHX_ PerlIO* f) {
2461 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2462 PerlIO_lockcnt(f)++;
2464 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2468 /* we've just run some perl-level code that could have done
2469 * anything, including closing the file or clearing this layer.
2470 * If so, free any lower layers that have already been
2471 * cleared, then return an error. */
2472 while (PerlIOValid(f) &&
2473 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2475 const PerlIOl *l = *f;
2484 PerlIOUnix_oflags(const char *mode)
2487 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2492 if (*++mode == '+') {
2499 oflags = O_CREAT | O_TRUNC;
2500 if (*++mode == '+') {
2509 oflags = O_CREAT | O_APPEND;
2510 if (*++mode == '+') {
2519 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2521 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2522 * of them in, and then bit-and-masking the other them away, won't
2523 * have much of an effect. */
2526 #if O_TEXT != O_BINARY
2533 #if O_TEXT != O_BINARY
2535 oflags &= ~O_BINARY;
2541 /* bit-or:ing with zero O_BINARY would be useless. */
2543 * If neither "t" nor "b" was specified, open the file
2546 * Note that if something else than the zero byte was seen
2547 * here (e.g. bogus mode "rx"), just few lines later we will
2548 * set the errno and invalidate the flags.
2554 if (*mode || oflags == -1) {
2555 SETERRNO(EINVAL, LIB_INVARG);
2562 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2564 PERL_UNUSED_CONTEXT;
2565 return PerlIOSelf(f, PerlIOUnix)->fd;
2569 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2571 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2574 if (PerlLIO_fstat(fd, &st) == 0) {
2575 if (!S_ISREG(st.st_mode)) {
2576 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2577 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2580 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2586 PerlIOUnix_refcnt_inc(fd);
2587 PERL_UNUSED_CONTEXT;
2591 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2593 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2594 if (*PerlIONext(f)) {
2595 /* We never call down so do any pending stuff now */
2596 PerlIO_flush(PerlIONext(f));
2598 * XXX could (or should) we retrieve the oflags from the open file
2599 * handle rather than believing the "mode" we are passed in? XXX
2600 * Should the value on NULL mode be 0 or -1?
2602 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2603 mode ? PerlIOUnix_oflags(mode) : -1);
2605 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2611 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2613 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2615 PERL_UNUSED_CONTEXT;
2616 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2618 SETERRNO(ESPIPE, LIB_INVARG);
2620 SETERRNO(EINVAL, LIB_INVARG);
2624 new_loc = PerlLIO_lseek(fd, offset, whence);
2625 if (new_loc == (Off_t) - 1)
2627 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2632 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2633 IV n, const char *mode, int fd, int imode,
2634 int perm, PerlIO *f, int narg, SV **args)
2636 if (PerlIOValid(f)) {
2637 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2638 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2641 if (*mode == IoTYPE_NUMERIC)
2644 imode = PerlIOUnix_oflags(mode);
2646 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2653 const char *path = SvPV_const(*args, len);
2654 if (!IS_SAFE_PATHNAME(path, len, "open"))
2656 fd = PerlLIO_open3(path, imode, perm);
2660 if (*mode == IoTYPE_IMPLICIT)
2663 f = PerlIO_allocate(aTHX);
2665 if (!PerlIOValid(f)) {
2666 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2671 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2672 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2673 if (*mode == IoTYPE_APPEND)
2674 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2681 * FIXME: pop layers ???
2689 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2691 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2693 if (flags & PERLIO_DUP_FD) {
2694 fd = PerlLIO_dup(fd);
2697 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2699 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2700 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2710 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2713 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2715 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2716 #ifdef PERLIO_STD_SPECIAL
2718 return PERLIO_STD_IN(fd, vbuf, count);
2720 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2721 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2725 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2726 if (len >= 0 || errno != EINTR) {
2728 if (errno != EAGAIN) {
2729 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2730 PerlIO_save_errno(f);
2733 else if (len == 0 && count != 0) {
2734 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2740 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2743 NOT_REACHED; /*NOTREACHED*/
2747 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2750 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2752 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2753 #ifdef PERLIO_STD_SPECIAL
2754 if (fd == 1 || fd == 2)
2755 return PERLIO_STD_OUT(fd, vbuf, count);
2758 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2759 if (len >= 0 || errno != EINTR) {
2761 if (errno != EAGAIN) {
2762 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2763 PerlIO_save_errno(f);
2769 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2772 NOT_REACHED; /*NOTREACHED*/
2776 PerlIOUnix_tell(pTHX_ PerlIO *f)
2778 PERL_UNUSED_CONTEXT;
2780 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2785 PerlIOUnix_close(pTHX_ PerlIO *f)
2787 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2789 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2790 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2791 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2796 SETERRNO(EBADF,SS_IVCHAN);
2799 while (PerlLIO_close(fd) != 0) {
2800 if (errno != EINTR) {
2805 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2809 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2814 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2815 sizeof(PerlIO_funcs),
2822 PerlIOBase_binmode, /* binmode */
2832 PerlIOBase_noop_ok, /* flush */
2833 PerlIOBase_noop_fail, /* fill */
2836 PerlIOBase_clearerr,
2837 PerlIOBase_setlinebuf,
2838 NULL, /* get_base */
2839 NULL, /* get_bufsiz */
2842 NULL, /* set_ptrcnt */
2845 /*--------------------------------------------------------------------------------------*/
2850 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2851 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2852 broken by the last second glibc 2.3 fix
2854 #define STDIO_BUFFER_WRITABLE
2859 struct _PerlIO base;
2860 FILE *stdio; /* The stream */
2864 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2866 PERL_UNUSED_CONTEXT;
2868 if (PerlIOValid(f)) {
2869 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2871 return PerlSIO_fileno(s);
2878 PerlIOStdio_mode(const char *mode, char *tmode)
2880 char * const ret = tmode;
2886 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2894 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2897 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2898 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2899 if (toptab == tab) {
2900 /* Top is already stdio - pop self (duplicate) and use original */
2901 PerlIO_pop(aTHX_ f);
2904 const int fd = PerlIO_fileno(n);
2907 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2908 mode = PerlIOStdio_mode(mode, tmode)))) {
2909 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2910 /* We never call down so do any pending stuff now */
2911 PerlIO_flush(PerlIONext(f));
2912 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2919 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2924 PerlIO_importFILE(FILE *stdio, const char *mode)
2930 char filename[FILENAME_MAX];
2935 int fd0 = fileno(stdio);
2938 rc = fldata(stdio,filename,&fileinfo);
2942 if(fileinfo.__dsorgHFS){
2945 /*This MVS dataset , OK!*/
2950 if (!mode || !*mode) {
2951 /* We need to probe to see how we can open the stream
2952 so start with read/write and then try write and read
2953 we dup() so that we can fclose without loosing the fd.
2955 Note that the errno value set by a failing fdopen
2956 varies between stdio implementations.
2958 const int fd = PerlLIO_dup(fd0);
2963 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2965 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2968 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2971 /* Don't seem to be able to open */
2977 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2978 s = PerlIOSelf(f, PerlIOStdio);
2981 fd0 = fileno(stdio);
2983 PerlIOUnix_refcnt_inc(fd0);
2986 rc = fldata(stdio,filename,&fileinfo);
2988 PerlIOUnix_refcnt_inc(fd0);
2990 if(fileinfo.__dsorgHFS){
2991 PerlIOUnix_refcnt_inc(fd0);
2993 /*This MVS dataset , OK!*/
2996 PerlIOUnix_refcnt_inc(fileno(stdio));
3004 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3005 IV n, const char *mode, int fd, int imode,
3006 int perm, PerlIO *f, int narg, SV **args)
3009 if (PerlIOValid(f)) {
3011 const char * const path = SvPV_const(*args, len);
3012 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3014 if (!IS_SAFE_PATHNAME(path, len, "open"))
3016 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3017 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3022 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3028 const char * const path = SvPV_const(*args, len);
3029 if (!IS_SAFE_PATHNAME(path, len, "open"))
3031 if (*mode == IoTYPE_NUMERIC) {
3033 fd = PerlLIO_open3(path, imode, perm);
3037 bool appended = FALSE;
3039 /* Cygwin wants its 'b' early. */
3041 mode = PerlIOStdio_mode(mode, tmode);
3043 stdio = PerlSIO_fopen(path, mode);
3046 f = PerlIO_allocate(aTHX);
3049 mode = PerlIOStdio_mode(mode, tmode);
3050 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3052 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3053 PerlIOUnix_refcnt_inc(fileno(stdio));
3055 PerlSIO_fclose(stdio);
3067 if (*mode == IoTYPE_IMPLICIT) {
3074 stdio = PerlSIO_stdin;
3077 stdio = PerlSIO_stdout;
3080 stdio = PerlSIO_stderr;
3085 stdio = PerlSIO_fdopen(fd, mode =
3086 PerlIOStdio_mode(mode, tmode));
3090 f = PerlIO_allocate(aTHX);
3092 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3093 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3094 PerlIOUnix_refcnt_inc(fileno(stdio));
3105 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3107 /* This assumes no layers underneath - which is what
3108 happens, but is not how I remember it. NI-S 2001/10/16
3110 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3111 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3112 const int fd = fileno(stdio);
3114 if (flags & PERLIO_DUP_FD) {
3115 const int dfd = PerlLIO_dup(fileno(stdio));
3117 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3122 /* FIXME: To avoid messy error recovery if dup fails
3123 re-use the existing stdio as though flag was not set
3127 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3129 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3131 PerlIOUnix_refcnt_inc(fileno(stdio));
3138 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3140 PERL_UNUSED_CONTEXT;
3142 /* XXX this could use PerlIO_canset_fileno() and
3143 * PerlIO_set_fileno() support from Configure
3145 # if defined(HAS_FDCLOSE)
3146 return fdclose(f, NULL) == 0 ? 1 : 0;
3147 # elif defined(__UCLIBC__)
3148 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3151 # elif defined(__GLIBC__)
3152 /* There may be a better way for GLIBC:
3153 - libio.h defines a flag to not close() on cleanup
3157 # elif defined(__sun)
3160 # elif defined(__hpux)
3164 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3165 your platform does not have special entry try this one.
3166 [For OSF only have confirmation for Tru64 (alpha)
3167 but assume other OSFs will be similar.]
3169 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3172 # elif defined(__FreeBSD__)
3173 /* There may be a better way on FreeBSD:
3174 - we could insert a dummy func in the _close function entry
3175 f->_close = (int (*)(void *)) dummy_close;
3179 # elif defined(__OpenBSD__)
3180 /* There may be a better way on OpenBSD:
3181 - we could insert a dummy func in the _close function entry
3182 f->_close = (int (*)(void *)) dummy_close;
3186 # elif defined(__EMX__)
3187 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3190 # elif defined(__CYGWIN__)
3191 /* There may be a better way on CYGWIN:
3192 - we could insert a dummy func in the _close function entry
3193 f->_close = (int (*)(void *)) dummy_close;
3197 # elif defined(WIN32)
3198 # if defined(UNDER_CE)
3199 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3208 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3209 (which isn't thread safe) instead
3211 # error "Don't know how to set FILE.fileno on your platform"
3219 PerlIOStdio_close(pTHX_ PerlIO *f)
3221 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3227 const int fd = fileno(stdio);
3235 #ifdef SOCKS5_VERSION_NAME
3236 /* Socks lib overrides close() but stdio isn't linked to
3237 that library (though we are) - so we must call close()
3238 on sockets on stdio's behalf.
3241 Sock_size_t optlen = sizeof(int);
3242 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3245 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3246 that a subsequent fileno() on it returns -1. Don't want to croak()
3247 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3248 trying to close an already closed handle which somehow it still has
3249 a reference to. (via.xs, I'm looking at you). */
3250 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3251 /* File descriptor still in use */
3255 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3256 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3258 if (stdio == stdout || stdio == stderr)
3259 return PerlIO_flush(f);
3262 MUTEX_LOCK(&PL_perlio_mutex);
3263 /* Right. We need a mutex here because for a brief while we
3264 will have the situation that fd is actually closed. Hence if
3265 a second thread were to get into this block, its dup() would
3266 likely return our fd as its dupfd. (after all, it is closed)
3267 Then if we get to the dup2() first, we blat the fd back
3268 (messing up its temporary as a side effect) only for it to
3269 then close its dupfd (== our fd) in its close(dupfd) */
3271 /* There is, of course, a race condition, that any other thread
3272 trying to input/output/whatever on this fd will be stuffed
3273 for the duration of this little manoeuvrer. Perhaps we
3274 should hold an IO mutex for the duration of every IO
3275 operation if we know that invalidate doesn't work on this
3276 platform, but that would suck, and could kill performance.
3278 Except that correctness trumps speed.
3279 Advice from klortho #11912. */
3282 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3283 Use Sarathy's trick from maint-5.6 to invalidate the
3284 fileno slot of the FILE *
3286 result = PerlIO_flush(f);
3288 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3290 dupfd = PerlLIO_dup(fd);
3293 /* Oh cXap. This isn't going to go well. Not sure if we can
3294 recover from here, or if closing this particular FILE *
3295 is a good idea now. */
3300 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3302 result = PerlSIO_fclose(stdio);
3303 /* We treat error from stdio as success if we invalidated
3304 errno may NOT be expected EBADF
3306 if (invalidate && result != 0) {
3310 #ifdef SOCKS5_VERSION_NAME
3311 /* in SOCKS' case, let close() determine return value */
3315 PerlLIO_dup2(dupfd,fd);
3316 PerlLIO_close(dupfd);
3319 MUTEX_UNLOCK(&PL_perlio_mutex);
3326 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3330 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3332 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3335 STDCHAR *buf = (STDCHAR *) vbuf;
3337 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3338 * stdio does not do that for fread()
3340 const int ch = PerlSIO_fgetc(s);
3347 got = PerlSIO_fread(vbuf, 1, count, s);
3348 if (got == 0 && PerlSIO_ferror(s))
3350 if (got >= 0 || errno != EINTR)
3352 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3354 SETERRNO(0,0); /* just in case */
3357 /* Under some circumstances IRIX stdio fgetc() and fread()
3358 * set the errno to ENOENT, which makes no sense according
3359 * to either IRIX or POSIX. [rt.perl.org #123977] */
3360 if (errno == ENOENT) SETERRNO(0,0);
3366 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3369 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3371 #ifdef STDIO_BUFFER_WRITABLE
3372 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3373 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3374 STDCHAR *base = PerlIO_get_base(f);
3375 SSize_t cnt = PerlIO_get_cnt(f);
3376 STDCHAR *ptr = PerlIO_get_ptr(f);
3377 SSize_t avail = ptr - base;
3379 if (avail > count) {
3383 Move(buf-avail,ptr,avail,STDCHAR);
3386 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3387 if (PerlSIO_feof(s) && unread >= 0)
3388 PerlSIO_clearerr(s);
3393 if (PerlIO_has_cntptr(f)) {
3394 /* We can get pointer to buffer but not its base
3395 Do ungetc() but check chars are ending up in the
3398 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3399 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3401 const int ch = *--buf & 0xFF;
3402 if (ungetc(ch,s) != ch) {
3403 /* ungetc did not work */
3406 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3407 /* Did not change pointer as expected */
3408 if (fgetc(s) != EOF) /* get char back again */
3418 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3424 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3427 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3430 got = PerlSIO_fwrite(vbuf, 1, count,
3431 PerlIOSelf(f, PerlIOStdio)->stdio);
3432 if (got >= 0 || errno != EINTR)
3434 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3436 SETERRNO(0,0); /* just in case */
3442 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3444 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3445 PERL_UNUSED_CONTEXT;
3447 return PerlSIO_fseek(stdio, offset, whence);
3451 PerlIOStdio_tell(pTHX_ PerlIO *f)
3453 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3454 PERL_UNUSED_CONTEXT;
3456 return PerlSIO_ftell(stdio);
3460 PerlIOStdio_flush(pTHX_ PerlIO *f)
3462 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3463 PERL_UNUSED_CONTEXT;
3465 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3466 return PerlSIO_fflush(stdio);
3472 * FIXME: This discards ungetc() and pre-read stuff which is not
3473 * right if this is just a "sync" from a layer above Suspect right
3474 * design is to do _this_ but not have layer above flush this
3475 * layer read-to-read
3478 * Not writeable - sync by attempting a seek
3481 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3489 PerlIOStdio_eof(pTHX_ PerlIO *f)
3491 PERL_UNUSED_CONTEXT;
3493 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3497 PerlIOStdio_error(pTHX_ PerlIO *f)
3499 PERL_UNUSED_CONTEXT;
3501 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3505 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3507 PERL_UNUSED_CONTEXT;
3509 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3513 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3515 PERL_UNUSED_CONTEXT;
3517 #ifdef HAS_SETLINEBUF
3518 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3520 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3526 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3528 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3529 return (STDCHAR*)PerlSIO_get_base(stdio);
3533 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3535 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3536 return PerlSIO_get_bufsiz(stdio);
3540 #ifdef USE_STDIO_PTR
3542 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3544 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3545 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3549 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3551 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3552 return PerlSIO_get_cnt(stdio);
3556 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3558 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3560 #ifdef STDIO_PTR_LVALUE
3561 /* This is a long-standing infamous mess. The root of the
3562 * problem is that one cannot know the signedness of char, and
3563 * more precisely the signedness of FILE._ptr. The following
3564 * things have been tried, and they have all failed (across
3565 * different compilers (remember that core needs to to build
3566 * also with c++) and compiler options:
3568 * - casting the RHS to (void*) -- works in *some* places
3569 * - casting the LHS to (void*) -- totally unportable
3571 * So let's try silencing the warning at least for gcc. */
3572 GCC_DIAG_IGNORE(-Wpointer-sign);
3573 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3575 #ifdef STDIO_PTR_LVAL_SETS_CNT
3576 assert(PerlSIO_get_cnt(stdio) == (cnt));
3578 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3580 * Setting ptr _does_ change cnt - we are done
3584 #else /* STDIO_PTR_LVALUE */
3586 #endif /* STDIO_PTR_LVALUE */
3589 * Now (or only) set cnt
3591 #ifdef STDIO_CNT_LVALUE
3592 PerlSIO_set_cnt(stdio, cnt);
3593 #else /* STDIO_CNT_LVALUE */
3594 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3595 PerlSIO_set_ptr(stdio,
3596 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3598 #else /* STDIO_PTR_LVAL_SETS_CNT */
3600 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3601 #endif /* STDIO_CNT_LVALUE */
3608 PerlIOStdio_fill(pTHX_ PerlIO *f)
3612 PERL_UNUSED_CONTEXT;
3613 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3615 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3618 * fflush()ing read-only streams can cause trouble on some stdio-s
3620 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3621 if (PerlSIO_fflush(stdio) != 0)
3625 c = PerlSIO_fgetc(stdio);
3628 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3630 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3635 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3637 #ifdef STDIO_BUFFER_WRITABLE
3638 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3639 /* Fake ungetc() to the real buffer in case system's ungetc
3642 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3643 SSize_t cnt = PerlSIO_get_cnt(stdio);
3644 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3645 if (ptr == base+1) {
3646 *--ptr = (STDCHAR) c;
3647 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3648 if (PerlSIO_feof(stdio))
3649 PerlSIO_clearerr(stdio);
3655 if (PerlIO_has_cntptr(f)) {
3657 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3663 /* If buffer snoop scheme above fails fall back to
3666 if (PerlSIO_ungetc(c, stdio) != c)
3674 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3675 sizeof(PerlIO_funcs),
3677 sizeof(PerlIOStdio),
3678 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3682 PerlIOBase_binmode, /* binmode */
3696 PerlIOStdio_clearerr,
3697 PerlIOStdio_setlinebuf,
3699 PerlIOStdio_get_base,
3700 PerlIOStdio_get_bufsiz,
3705 #ifdef USE_STDIO_PTR
3706 PerlIOStdio_get_ptr,
3707 PerlIOStdio_get_cnt,
3708 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3709 PerlIOStdio_set_ptrcnt,
3712 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3717 #endif /* USE_STDIO_PTR */
3720 /* Note that calls to PerlIO_exportFILE() are reversed using
3721 * PerlIO_releaseFILE(), not importFILE. */
3723 PerlIO_exportFILE(PerlIO * f, const char *mode)
3727 if (PerlIOValid(f)) {
3729 int fd = PerlIO_fileno(f);
3734 if (!mode || !*mode) {
3735 mode = PerlIO_modestr(f, buf);
3737 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3741 /* De-link any lower layers so new :stdio sticks */
3743 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3744 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3746 PerlIOUnix_refcnt_inc(fileno(stdio));
3747 /* Link previous lower layers under new one */
3751 /* restore layers list */
3761 PerlIO_findFILE(PerlIO *f)
3766 if (l->tab == &PerlIO_stdio) {
3767 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3770 l = *PerlIONext(&l);
3772 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3773 /* However, we're not really exporting a FILE * to someone else (who
3774 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3775 So we need to undo its reference count increase on the underlying file
3776 descriptor. We have to do this, because if the loop above returns you
3777 the FILE *, then *it* didn't increase any reference count. So there's
3778 only one way to be consistent. */
3779 stdio = PerlIO_exportFILE(f, NULL);
3781 const int fd = fileno(stdio);
3783 PerlIOUnix_refcnt_dec(fd);
3788 /* Use this to reverse PerlIO_exportFILE calls. */
3790 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3794 if (l->tab == &PerlIO_stdio) {
3795 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3796 if (s->stdio == f) { /* not in a loop */
3797 const int fd = fileno(f);
3799 PerlIOUnix_refcnt_dec(fd);
3802 PerlIO_pop(aTHX_ p);
3812 /*--------------------------------------------------------------------------------------*/
3814 * perlio buffer layer
3818 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3820 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3821 const int fd = PerlIO_fileno(f);
3822 if (fd >= 0 && PerlLIO_isatty(fd)) {
3823 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3825 if (*PerlIONext(f)) {
3826 const Off_t posn = PerlIO_tell(PerlIONext(f));
3827 if (posn != (Off_t) - 1) {
3831 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3835 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3836 IV n, const char *mode, int fd, int imode, int perm,
3837 PerlIO *f, int narg, SV **args)
3839 if (PerlIOValid(f)) {
3840 PerlIO *next = PerlIONext(f);
3842 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3843 if (tab && tab->Open)
3845 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3847 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3852 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3854 if (*mode == IoTYPE_IMPLICIT) {
3860 if (tab && tab->Open)
3861 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3864 SETERRNO(EINVAL, LIB_INVARG);
3866 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3868 * if push fails during open, open fails. close will pop us.
3873 fd = PerlIO_fileno(f);
3874 if (init && fd == 2) {
3876 * Initial stderr is unbuffered
3878 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3880 #ifdef PERLIO_USING_CRLF
3881 # ifdef PERLIO_IS_BINMODE_FD
3882 if (PERLIO_IS_BINMODE_FD(fd))
3883 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3887 * do something about failing setmode()? --jhi
3889 PerlLIO_setmode(fd, O_BINARY);
3892 /* Enable line buffering with record-oriented regular files
3893 * so we don't introduce an extraneous record boundary when
3894 * the buffer fills up.
3896 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3898 if (PerlLIO_fstat(fd, &st) == 0
3899 && S_ISREG(st.st_mode)
3900 && (st.st_fab_rfm == FAB$C_VAR
3901 || st.st_fab_rfm == FAB$C_VFC)) {
3902 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3913 * This "flush" is akin to sfio's sync in that it handles files in either
3914 * read or write state. For write state, we put the postponed data through
3915 * the next layers. For read state, we seek() the next layers to the
3916 * offset given by current position in the buffer, and discard the buffer
3917 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3918 * in any case?). Then the pass the stick further in chain.
3921 PerlIOBuf_flush(pTHX_ PerlIO *f)
3923 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3925 PerlIO *n = PerlIONext(f);
3926 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3928 * write() the buffer
3930 const STDCHAR *buf = b->buf;
3931 const STDCHAR *p = buf;
3932 while (p < b->ptr) {
3933 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3937 else if (count < 0 || PerlIO_error(n)) {
3938 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3939 PerlIO_save_errno(f);
3944 b->posn += (p - buf);
3946 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3947 STDCHAR *buf = PerlIO_get_base(f);
3949 * Note position change
3951 b->posn += (b->ptr - buf);
3952 if (b->ptr < b->end) {
3953 /* We did not consume all of it - try and seek downstream to
3954 our logical position
3956 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3957 /* Reload n as some layers may pop themselves on seek */
3958 b->posn = PerlIO_tell(n = PerlIONext(f));
3961 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3962 data is lost for good - so return saying "ok" having undone
3965 b->posn -= (b->ptr - buf);
3970 b->ptr = b->end = b->buf;
3971 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3972 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3973 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3978 /* This discards the content of the buffer after b->ptr, and rereads
3979 * the buffer from the position off in the layer downstream; here off
3980 * is at offset corresponding to b->ptr - b->buf.
3983 PerlIOBuf_fill(pTHX_ PerlIO *f)
3985 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3986 PerlIO *n = PerlIONext(f);
3989 * Down-stream flush is defined not to loose read data so is harmless.
3990 * we would not normally be fill'ing if there was data left in anycase.
3992 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3994 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3995 PerlIOBase_flush_linebuf(aTHX);
3998 PerlIO_get_base(f); /* allocate via vtable */
4000 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4002 b->ptr = b->end = b->buf;
4004 if (!PerlIOValid(n)) {
4005 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4009 if (PerlIO_fast_gets(n)) {
4011 * Layer below is also buffered. We do _NOT_ want to call its
4012 * ->Read() because that will loop till it gets what we asked for
4013 * which may hang on a pipe etc. Instead take anything it has to
4014 * hand, or ask it to fill _once_.
4016 avail = PerlIO_get_cnt(n);
4018 avail = PerlIO_fill(n);
4020 avail = PerlIO_get_cnt(n);
4022 if (!PerlIO_error(n) && PerlIO_eof(n))
4027 STDCHAR *ptr = PerlIO_get_ptr(n);
4028 const SSize_t cnt = avail;
4029 if (avail > (SSize_t)b->bufsiz)
4031 Copy(ptr, b->buf, avail, STDCHAR);
4032 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4036 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4040 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4043 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4044 PerlIO_save_errno(f);
4048 b->end = b->buf + avail;
4049 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4054 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4056 if (PerlIOValid(f)) {
4057 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4060 return PerlIOBase_read(aTHX_ f, vbuf, count);
4066 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4068 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4069 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4072 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4077 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4079 * Buffer is already a read buffer, we can overwrite any chars
4080 * which have been read back to buffer start
4082 avail = (b->ptr - b->buf);
4086 * Buffer is idle, set it up so whole buffer is available for
4090 b->end = b->buf + avail;
4092 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4094 * Buffer extends _back_ from where we are now
4096 b->posn -= b->bufsiz;
4098 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4100 * If we have space for more than count, just move count
4108 * In simple stdio-like ungetc() case chars will be already
4111 if (buf != b->ptr) {
4112 Copy(buf, b->ptr, avail, STDCHAR);
4116 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4120 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4126 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4128 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4129 const STDCHAR *buf = (const STDCHAR *) vbuf;
4130 const STDCHAR *flushptr = buf;
4134 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4136 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4137 if (PerlIO_flush(f) != 0) {
4141 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4142 flushptr = buf + count;
4143 while (flushptr > buf && *(flushptr - 1) != '\n')
4147 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4148 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4150 if (flushptr > buf && flushptr <= buf + avail)
4151 avail = flushptr - buf;
4152 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4154 Copy(buf, b->ptr, avail, STDCHAR);
4159 if (buf == flushptr)
4162 if (b->ptr >= (b->buf + b->bufsiz))
4163 if (PerlIO_flush(f) == -1)
4166 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4172 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4175 if ((code = PerlIO_flush(f)) == 0) {
4176 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4177 code = PerlIO_seek(PerlIONext(f), offset, whence);
4179 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4180 b->posn = PerlIO_tell(PerlIONext(f));
4187 PerlIOBuf_tell(pTHX_ PerlIO *f)
4189 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4191 * b->posn is file position where b->buf was read, or will be written
4193 Off_t posn = b->posn;
4194 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4195 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4197 /* As O_APPEND files are normally shared in some sense it is better
4202 /* when file is NOT shared then this is sufficient */
4203 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4205 posn = b->posn = PerlIO_tell(PerlIONext(f));
4209 * If buffer is valid adjust position by amount in buffer
4211 posn += (b->ptr - b->buf);
4217 PerlIOBuf_popped(pTHX_ PerlIO *f)
4219 const IV code = PerlIOBase_popped(aTHX_ f);
4220 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4221 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4224 b->ptr = b->end = b->buf = NULL;
4225 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4230 PerlIOBuf_close(pTHX_ PerlIO *f)
4232 const IV code = PerlIOBase_close(aTHX_ f);
4233 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4234 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4237 b->ptr = b->end = b->buf = NULL;
4238 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4243 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4245 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4252 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4254 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4257 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4258 return (b->end - b->ptr);
4263 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4265 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4266 PERL_UNUSED_CONTEXT;
4270 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4271 Newxz(b->buf,b->bufsiz, STDCHAR);
4273 b->buf = (STDCHAR *) & b->oneword;
4274 b->bufsiz = sizeof(b->oneword);
4276 b->end = b->ptr = b->buf;
4282 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4284 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4287 return (b->end - b->buf);
4291 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4293 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4295 PERL_UNUSED_ARG(cnt);
4300 assert(PerlIO_get_cnt(f) == cnt);
4301 assert(b->ptr >= b->buf);
4302 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4306 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4308 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4313 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4314 sizeof(PerlIO_funcs),
4317 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4321 PerlIOBase_binmode, /* binmode */
4335 PerlIOBase_clearerr,
4336 PerlIOBase_setlinebuf,
4341 PerlIOBuf_set_ptrcnt,
4344 /*--------------------------------------------------------------------------------------*/
4346 * Temp layer to hold unread chars when cannot do it any other way
4350 PerlIOPending_fill(pTHX_ PerlIO *f)
4353 * Should never happen
4360 PerlIOPending_close(pTHX_ PerlIO *f)
4363 * A tad tricky - flush pops us, then we close new top
4366 return PerlIO_close(f);
4370 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4373 * A tad tricky - flush pops us, then we seek new top
4376 return PerlIO_seek(f, offset, whence);
4381 PerlIOPending_flush(pTHX_ PerlIO *f)
4383 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4384 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4388 PerlIO_pop(aTHX_ f);
4393 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4399 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4404 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4406 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4407 PerlIOl * const l = PerlIOBase(f);
4409 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4410 * etc. get muddled when it changes mid-string when we auto-pop.
4412 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4413 (PerlIOBase(PerlIONext(f))->
4414 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4419 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4421 SSize_t avail = PerlIO_get_cnt(f);
4423 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4426 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4427 if (got >= 0 && got < (SSize_t)count) {
4428 const SSize_t more =
4429 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4430 if (more >= 0 || got == 0)
4436 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4437 sizeof(PerlIO_funcs),
4440 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4441 PerlIOPending_pushed,
4444 PerlIOBase_binmode, /* binmode */
4453 PerlIOPending_close,
4454 PerlIOPending_flush,
4458 PerlIOBase_clearerr,
4459 PerlIOBase_setlinebuf,
4464 PerlIOPending_set_ptrcnt,
4469 /*--------------------------------------------------------------------------------------*/
4471 * crlf - translation On read translate CR,LF to "\n" we do this by
4472 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4473 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4475 * c->nl points on the first byte of CR LF pair when it is temporarily
4476 * replaced by LF, or to the last CR of the buffer. In the former case
4477 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4478 * that it ends at c->nl; these two cases can be distinguished by
4479 * *c->nl. c->nl is set during _getcnt() call, and unset during
4480 * _unread() and _flush() calls.
4481 * It only matters for read operations.
4485 PerlIOBuf base; /* PerlIOBuf stuff */
4486 STDCHAR *nl; /* Position of crlf we "lied" about in the
4490 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4491 * Otherwise the :crlf layer would always revert back to
4495 S_inherit_utf8_flag(PerlIO *f)
4497 PerlIO *g = PerlIONext(f);
4498 if (PerlIOValid(g)) {
4499 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4500 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4506 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4509 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4510 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4513 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4514 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4515 PerlIOBase(f)->flags);
4519 /* If the old top layer is a CRLF layer, reactivate it (if
4520 * necessary) and remove this new layer from the stack */
4521 PerlIO *g = PerlIONext(f);
4522 if (PerlIOValid(g)) {
4523 PerlIOl *b = PerlIOBase(g);
4524 if (b && b->tab == &PerlIO_crlf) {
4525 if (!(b->flags & PERLIO_F_CRLF))
4526 b->flags |= PERLIO_F_CRLF;
4527 S_inherit_utf8_flag(g);
4528 PerlIO_pop(aTHX_ f);
4533 S_inherit_utf8_flag(f);
4539 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4541 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4542 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4543 *(c->nl) = NATIVE_0xd;
4546 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4547 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4549 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4550 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4552 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4557 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4558 b->end = b->ptr = b->buf + b->bufsiz;
4559 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4560 b->posn -= b->bufsiz;
4562 while (count > 0 && b->ptr > b->buf) {
4563 const int ch = *--buf;
4565 if (b->ptr - 2 >= b->buf) {
4566 *--(b->ptr) = NATIVE_0xa;
4567 *--(b->ptr) = NATIVE_0xd;
4572 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4573 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4587 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4592 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4594 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4596 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4599 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4600 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4601 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4602 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4604 while (nl < b->end && *nl != NATIVE_0xd)
4606 if (nl < b->end && *nl == NATIVE_0xd) {
4608 if (nl + 1 < b->end) {
4609 if (nl[1] == NATIVE_0xa) {
4615 * Not CR,LF but just CR
4623 * Blast - found CR as last char in buffer
4628 * They may not care, defer work as long as
4632 return (nl - b->ptr);
4636 b->ptr++; /* say we have read it as far as
4637 * flush() is concerned */
4638 b->buf++; /* Leave space in front of buffer */
4639 /* Note as we have moved buf up flush's
4641 will naturally make posn point at CR
4643 b->bufsiz--; /* Buffer is thus smaller */
4644 code = PerlIO_fill(f); /* Fetch some more */
4645 b->bufsiz++; /* Restore size for next time */
4646 b->buf--; /* Point at space */
4647 b->ptr = nl = b->buf; /* Which is what we hand
4649 *nl = NATIVE_0xd; /* Fill in the CR */
4651 goto test; /* fill() call worked */
4653 * CR at EOF - just fall through
4655 /* Should we clear EOF though ??? */
4660 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4666 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4668 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4669 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4675 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4676 /* Deferred CR at end of buffer case - we lied about count */
4689 * Test code - delete when it works ...
4691 IV flags = PerlIOBase(f)->flags;
4692 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4693 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4694 /* Deferred CR at end of buffer case - we lied about count */
4700 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4701 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4702 flags, c->nl, b->end, cnt);
4709 * They have taken what we lied about
4711 *(c->nl) = NATIVE_0xd;
4717 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4721 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4723 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4724 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4726 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4727 const STDCHAR *buf = (const STDCHAR *) vbuf;
4728 const STDCHAR * const ebuf = buf + count;
4731 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4733 while (buf < ebuf) {
4734 const STDCHAR * const eptr = b->buf + b->bufsiz;
4735 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4736 while (buf < ebuf && b->ptr < eptr) {
4738 if ((b->ptr + 2) > eptr) {
4746 *(b->ptr)++ = NATIVE_0xd; /* CR */
4747 *(b->ptr)++ = NATIVE_0xa; /* LF */
4749 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4756 *(b->ptr)++ = *buf++;
4758 if (b->ptr >= eptr) {
4764 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4766 return (buf - (STDCHAR *) vbuf);
4771 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4773 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4775 *(c->nl) = NATIVE_0xd;
4778 return PerlIOBuf_flush(aTHX_ f);
4782 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4784 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4785 /* In text mode - flush any pending stuff and flip it */
4786 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4787 #ifndef PERLIO_USING_CRLF
4788 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4789 PerlIO_pop(aTHX_ f);
4795 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4796 sizeof(PerlIO_funcs),
4799 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4801 PerlIOBuf_popped, /* popped */
4803 PerlIOCrlf_binmode, /* binmode */
4807 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4808 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4809 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4817 PerlIOBase_clearerr,
4818 PerlIOBase_setlinebuf,
4823 PerlIOCrlf_set_ptrcnt,
4827 Perl_PerlIO_stdin(pTHX)
4830 PerlIO_stdstreams(aTHX);
4832 return (PerlIO*)&PL_perlio[1];
4836 Perl_PerlIO_stdout(pTHX)
4839 PerlIO_stdstreams(aTHX);
4841 return (PerlIO*)&PL_perlio[2];
4845 Perl_PerlIO_stderr(pTHX)
4848 PerlIO_stdstreams(aTHX);
4850 return (PerlIO*)&PL_perlio[3];
4853 /*--------------------------------------------------------------------------------------*/
4856 PerlIO_getname(PerlIO *f, char *buf)
4861 bool exported = FALSE;
4862 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4864 stdio = PerlIO_exportFILE(f,0);
4868 name = fgetname(stdio, buf);
4869 if (exported) PerlIO_releaseFILE(f,stdio);
4874 PERL_UNUSED_ARG(buf);
4875 Perl_croak_nocontext("Don't know how to get file name");
4881 /*--------------------------------------------------------------------------------------*/
4883 * Functions which can be called on any kind of PerlIO implemented in
4887 #undef PerlIO_fdopen
4889 PerlIO_fdopen(int fd, const char *mode)
4892 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4897 PerlIO_open(const char *path, const char *mode)
4900 SV *name = sv_2mortal(newSVpv(path, 0));
4901 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4904 #undef Perlio_reopen
4906 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4909 SV *name = sv_2mortal(newSVpv(path,0));
4910 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4915 PerlIO_getc(PerlIO *f)
4919 if ( 1 == PerlIO_read(f, buf, 1) ) {
4920 return (unsigned char) buf[0];
4925 #undef PerlIO_ungetc
4927 PerlIO_ungetc(PerlIO *f, int ch)
4932 if (PerlIO_unread(f, &buf, 1) == 1)
4940 PerlIO_putc(PerlIO *f, int ch)
4944 return PerlIO_write(f, &buf, 1);
4949 PerlIO_puts(PerlIO *f, const char *s)
4952 return PerlIO_write(f, s, strlen(s));
4955 #undef PerlIO_rewind
4957 PerlIO_rewind(PerlIO *f)
4960 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4964 #undef PerlIO_vprintf
4966 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4975 Perl_va_copy(ap, apc);
4976 sv = vnewSVpvf(fmt, &apc);
4979 sv = vnewSVpvf(fmt, &ap);
4981 s = SvPV_const(sv, len);
4982 wrote = PerlIO_write(f, s, len);
4987 #undef PerlIO_printf
4989 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4994 result = PerlIO_vprintf(f, fmt, ap);
4999 #undef PerlIO_stdoutf
5001 PerlIO_stdoutf(const char *fmt, ...)
5007 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5012 #undef PerlIO_tmpfile
5014 PerlIO_tmpfile(void)
5021 const int fd = win32_tmpfd();
5023 f = PerlIO_fdopen(fd, "w+b");
5025 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5027 char tempname[] = "/tmp/PerlIO_XXXXXX";
5028 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5030 int old_umask = umask(0177);
5032 * I have no idea how portable mkstemp() is ... NI-S
5034 if (tmpdir && *tmpdir) {
5035 /* if TMPDIR is set and not empty, we try that first */
5036 sv = newSVpv(tmpdir, 0);
5037 sv_catpv(sv, tempname + 4);
5038 fd = mkstemp(SvPVX(sv));
5043 /* else we try /tmp */
5044 fd = mkstemp(tempname);
5049 sv_catpv(sv, tempname + 4);
5050 fd = mkstemp(SvPVX(sv));
5054 f = PerlIO_fdopen(fd, "w+");
5056 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5057 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5060 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5061 FILE * const stdio = PerlSIO_tmpfile();
5064 f = PerlIO_fdopen(fileno(stdio), "w+");
5066 # endif /* else HAS_MKSTEMP */
5067 #endif /* else WIN32 */
5072 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5074 if (!PerlIOValid(f))
5076 PerlIOBase(f)->err = errno;
5078 PerlIOBase(f)->os_err = vaxc$errno;
5080 PerlIOBase(f)->os_err = Perl_rc;
5081 #elif defined(WIN32)
5082 PerlIOBase(f)->os_err = GetLastError();
5087 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5089 if (!PerlIOValid(f))
5091 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5093 Perl_rc = PerlIOBase(f)->os_err);
5094 #elif defined(WIN32)
5095 SetLastError(PerlIOBase(f)->os_err);
5103 /*======================================================================================*/
5105 * Now some functions in terms of above which may be needed even if we are
5106 * not in true PerlIO mode
5109 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5111 const char *direction = NULL;
5114 * Need to supply default layer info from open.pm
5120 if (mode && mode[0] != 'r') {
5121 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5122 direction = "open>";
5124 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5125 direction = "open<";
5130 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5133 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5138 #undef PerlIO_setpos
5140 PerlIO_setpos(PerlIO *f, SV *pos)
5146 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5147 if(len == sizeof(Off_t))
5148 return PerlIO_seek(f, *posn, SEEK_SET);
5151 SETERRNO(EINVAL, SS_IVCHAN);
5155 #undef PerlIO_setpos
5157 PerlIO_setpos(PerlIO *f, SV *pos)
5163 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5164 if(len == sizeof(Fpos_t))
5165 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5166 return fsetpos64(f, fpos);
5168 return fsetpos(f, fpos);
5172 SETERRNO(EINVAL, SS_IVCHAN);
5178 #undef PerlIO_getpos
5180 PerlIO_getpos(PerlIO *f, SV *pos)
5183 Off_t posn = PerlIO_tell(f);
5184 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5185 return (posn == (Off_t) - 1) ? -1 : 0;
5188 #undef PerlIO_getpos
5190 PerlIO_getpos(PerlIO *f, SV *pos)
5195 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5196 code = fgetpos64(f, &fpos);
5198 code = fgetpos(f, &fpos);
5200 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5205 #if !defined(HAS_VPRINTF)
5208 vprintf(char *pat, char *args)
5210 _doprnt(pat, args, stdout);
5211 return 0; /* wrong, but perl doesn't use the return
5216 vfprintf(FILE *fd, char *pat, char *args)
5218 _doprnt(pat, args, fd);
5219 return 0; /* wrong, but perl doesn't use the return
5225 /* print a failure format string message to stderr and fail exit the process
5226 using only libc without depending on any perl data structures being
5231 Perl_noperl_die(const char* pat, ...)
5234 PERL_ARGS_ASSERT_NOPERL_DIE;
5235 va_start(arglist, pat);
5236 vfprintf(stderr, pat, arglist);
5242 * ex: set ts=8 sts=4 sw=4 et: