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, ...)
359 if (!PL_perlio_debug_fd) {
361 PerlProc_getuid() == PerlProc_geteuid() &&
362 PerlProc_getgid() == PerlProc_getegid()) {
363 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
366 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
368 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
370 /* tainting or set*id, so ignore the environment and send the
371 debug output to stderr, like other -D switches. */
372 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
375 if (PL_perlio_debug_fd > 0) {
377 const char * const s = CopFILE(PL_curcop);
378 /* Use fixed buffer as sv_catpvf etc. needs SVs */
380 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
381 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
382 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
384 const char *s = CopFILE(PL_curcop);
386 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
387 (IV) CopLINE(PL_curcop));
388 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
390 s = SvPV_const(sv, len);
391 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
398 /*--------------------------------------------------------------------------------------*/
401 * Inner level routines
404 /* check that the head field of each layer points back to the head */
407 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
409 PerlIO_verify_head(pTHX_ PerlIO *f)
413 #ifndef PERL_IMPLICIT_SYS
418 p = head = PerlIOBase(f)->head;
421 assert(p->head == head);
422 if (p == (PerlIOl*)f)
429 # define VERIFY_HEAD(f)
434 * Table of pointers to the PerlIO structs (malloc'ed)
436 #define PERLIO_TABLE_SIZE 64
439 PerlIO_init_table(pTHX)
443 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
449 PerlIO_allocate(pTHX)
452 * Find a free slot in the table, allocating new table as necessary
457 while ((f = *last)) {
459 last = (PerlIOl **) (f);
460 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
461 if (!((++f)->next)) {
466 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
470 *last = (PerlIOl*) f++;
473 f->flags = 0; /* lockcnt */
479 #undef PerlIO_fdupopen
481 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
483 if (PerlIOValid(f)) {
484 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
485 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
487 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
489 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
493 SETERRNO(EBADF, SS_IVCHAN);
499 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
501 PerlIOl * const table = *tablep;
504 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
505 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
506 PerlIOl * const f = table + i;
508 PerlIO_close(&(f->next));
518 PerlIO_list_alloc(pTHX)
522 Newxz(list, 1, PerlIO_list_t);
528 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
531 if (--list->refcnt == 0) {
534 for (i = 0; i < list->cur; i++)
535 SvREFCNT_dec(list->array[i].arg);
536 Safefree(list->array);
544 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
549 if (list->cur >= list->len) {
552 Renew(list->array, list->len, PerlIO_pair_t);
554 Newx(list->array, list->len, PerlIO_pair_t);
556 p = &(list->array[list->cur++]);
558 if ((p->arg = arg)) {
559 SvREFCNT_inc_simple_void_NN(arg);
564 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
566 PerlIO_list_t *list = NULL;
569 list = PerlIO_list_alloc(aTHX);
570 for (i=0; i < proto->cur; i++) {
571 SV *arg = proto->array[i].arg;
574 arg = sv_dup(arg, param);
576 PERL_UNUSED_ARG(param);
578 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
585 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
588 PerlIOl **table = &proto->Iperlio;
591 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
592 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
593 PerlIO_init_table(aTHX);
594 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
595 while ((f = *table)) {
597 table = (PerlIOl **) (f++);
598 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
600 (void) fp_dup(&(f->next), 0, param);
607 PERL_UNUSED_ARG(proto);
608 PERL_UNUSED_ARG(param);
613 PerlIO_destruct(pTHX)
615 PerlIOl **table = &PL_perlio;
618 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
620 while ((f = *table)) {
622 table = (PerlIOl **) (f++);
623 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
624 PerlIO *x = &(f->next);
627 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
628 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
642 PerlIO_pop(pTHX_ PerlIO *f)
644 const PerlIOl *l = *f;
647 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
648 l->tab ? l->tab->name : "(Null)") );
649 if (l->tab && l->tab->Popped) {
651 * If popped returns non-zero do not free its layer structure
652 * it has either done so itself, or it is shared and still in
655 if ((*l->tab->Popped) (aTHX_ f) != 0)
658 if (PerlIO_lockcnt(f)) {
659 /* we're in use; defer freeing the structure */
660 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
661 PerlIOBase(f)->tab = NULL;
671 /* Return as an array the stack of layers on a filehandle. Note that
672 * the stack is returned top-first in the array, and there are three
673 * times as many array elements as there are layers in the stack: the
674 * first element of a layer triplet is the name, the second one is the
675 * arguments, and the third one is the flags. */
678 PerlIO_get_layers(pTHX_ PerlIO *f)
680 AV * const av = newAV();
682 if (PerlIOValid(f)) {
683 PerlIOl *l = PerlIOBase(f);
686 /* There is some collusion in the implementation of
687 XS_PerlIO_get_layers - it knows that name and flags are
688 generated as fresh SVs here, and takes advantage of that to
689 "copy" them by taking a reference. If it changes here, it needs
690 to change there too. */
691 SV * const name = l->tab && l->tab->name ?
692 newSVpv(l->tab->name, 0) : &PL_sv_undef;
693 SV * const arg = l->tab && l->tab->Getarg ?
694 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
697 av_push(av, newSViv((IV)l->flags));
705 /*--------------------------------------------------------------------------------------*/
707 * XS Interface for perl code
711 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
715 if ((SSize_t) len <= 0)
717 for (i = 0; i < PL_known_layers->cur; i++) {
718 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
719 const STRLEN this_len = strlen(f->name);
720 if (this_len == len && memEQ(f->name, name, len)) {
721 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
725 if (load && PL_subname && PL_def_layerlist
726 && PL_def_layerlist->cur >= 2) {
727 if (PL_in_load_module) {
728 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
731 SV * const pkgsv = newSVpvs("PerlIO");
732 SV * const layer = newSVpvn(name, len);
733 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
735 SAVEBOOL(PL_in_load_module);
737 SAVEGENERICSV(PL_warnhook);
738 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
740 PL_in_load_module = TRUE;
742 * The two SVs are magically freed by load_module
744 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
746 return PerlIO_find_layer(aTHX_ name, len, 0);
749 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
753 #ifdef USE_ATTRIBUTES_FOR_PERLIO
756 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
759 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
760 PerlIO * const ifp = IoIFP(io);
761 PerlIO * const ofp = IoOFP(io);
762 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
763 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
769 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
772 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
773 PerlIO * const ifp = IoIFP(io);
774 PerlIO * const ofp = IoOFP(io);
775 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
776 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
782 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
784 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
789 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
791 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
795 MGVTBL perlio_vtab = {
803 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
804 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
807 SV * const sv = SvRV(ST(1));
808 AV * const av = newAV();
812 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
814 mg = mg_find(sv, PERL_MAGIC_ext);
815 mg->mg_virtual = &perlio_vtab;
817 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
818 for (i = 2; i < items; i++) {
820 const char * const name = SvPV_const(ST(i), len);
821 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
823 av_push(av, SvREFCNT_inc_simple_NN(layer));
834 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
837 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
839 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
840 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
844 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
845 XS(XS_PerlIO__Layer__NoWarnings)
847 /* This is used as a %SIG{__WARN__} handler to suppress warnings
848 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)
863 Perl_croak(aTHX_ "Usage class->find(name[,load])");
866 const char * const name = SvPV_const(ST(1), len);
867 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
868 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
870 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
877 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
879 if (!PL_known_layers)
880 PL_known_layers = PerlIO_list_alloc(aTHX);
881 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
882 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
886 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
889 const char *s = names;
891 while (isSPACE(*s) || *s == ':')
896 const char *as = NULL;
898 if (!isIDFIRST(*s)) {
900 * Message is consistent with how attribute lists are
901 * passed. Even though this means "foo : : bar" is
902 * seen as an invalid separator character.
904 const char q = ((*s == '\'') ? '"' : '\'');
905 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
906 "Invalid separator character %c%c%c in PerlIO layer specification %s",
908 SETERRNO(EINVAL, LIB_INVARG);
913 } while (isWORDCHAR(*e));
929 * It's a nul terminated string, not allowed
930 * to \ the terminating null. Anything other
931 * character is passed over.
941 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
942 "Argument list not closed for PerlIO layer \"%.*s\"",
954 PerlIO_funcs * const layer =
955 PerlIO_find_layer(aTHX_ s, llen, 1);
959 arg = newSVpvn(as, alen);
960 PerlIO_list_push(aTHX_ av, layer,
961 (arg) ? arg : &PL_sv_undef);
965 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
978 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
980 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
981 #ifdef PERLIO_USING_CRLF
984 if (PerlIO_stdio.Set_ptrcnt)
987 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
988 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
992 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
994 return av->array[n].arg;
998 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1000 if (n >= 0 && n < av->cur) {
1001 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1002 av->array[n].funcs->name) );
1003 return av->array[n].funcs;
1006 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1011 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1013 PERL_UNUSED_ARG(mode);
1014 PERL_UNUSED_ARG(arg);
1015 PERL_UNUSED_ARG(tab);
1016 if (PerlIOValid(f)) {
1018 PerlIO_pop(aTHX_ f);
1024 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1025 sizeof(PerlIO_funcs),
1028 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1048 NULL, /* get_base */
1049 NULL, /* get_bufsiz */
1052 NULL, /* set_ptrcnt */
1056 PerlIO_default_layers(pTHX)
1058 if (!PL_def_layerlist) {
1059 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1060 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1061 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1062 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1064 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1066 osLayer = &PerlIO_win32;
1069 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1070 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1071 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1072 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1076 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1079 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1082 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1085 if (PL_def_layerlist->cur < 2) {
1086 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1088 return PL_def_layerlist;
1092 Perl_boot_core_PerlIO(pTHX)
1094 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1095 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1098 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1099 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1103 PerlIO_default_layer(pTHX_ I32 n)
1105 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1108 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1111 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1112 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1115 PerlIO_stdstreams(pTHX)
1118 PerlIO_init_table(aTHX);
1119 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1120 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1121 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1126 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1129 if (tab->fsize != sizeof(PerlIO_funcs)) {
1131 "%s (%" UVuf ") does not match %s (%" UVuf ")",
1132 "PerlIO layer function table size", (UV)tab->fsize,
1133 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1137 if (tab->size < sizeof(PerlIOl)) {
1139 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1140 "PerlIO layer instance size", (UV)tab->size,
1141 "size expected by this perl", (UV)sizeof(PerlIOl) );
1143 /* Real layer with a data area */
1146 Newxz(temp, tab->size, char);
1150 l->tab = (PerlIO_funcs*) tab;
1151 l->head = ((PerlIOl*)f)->head;
1153 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1154 (void*)f, tab->name,
1155 (mode) ? mode : "(Null)", (void*)arg) );
1156 if (*l->tab->Pushed &&
1158 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1159 PerlIO_pop(aTHX_ f);
1168 /* Pseudo-layer where push does its own stack adjust */
1169 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1170 (mode) ? mode : "(Null)", (void*)arg) );
1172 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1180 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1181 IV n, const char *mode, int fd, int imode, int perm,
1182 PerlIO *old, int narg, SV **args)
1184 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1185 if (tab && tab->Open) {
1186 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1187 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1193 SETERRNO(EINVAL, LIB_INVARG);
1198 PerlIOBase_binmode(pTHX_ PerlIO *f)
1200 if (PerlIOValid(f)) {
1201 /* Is layer suitable for raw stream ? */
1202 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1203 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1204 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1207 /* Not suitable - pop it */
1208 PerlIO_pop(aTHX_ f);
1216 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1218 PERL_UNUSED_ARG(mode);
1219 PERL_UNUSED_ARG(arg);
1220 PERL_UNUSED_ARG(tab);
1222 if (PerlIOValid(f)) {
1227 * Strip all layers that are not suitable for a raw stream
1230 while (t && (l = *t)) {
1231 if (l->tab && l->tab->Binmode) {
1232 /* Has a handler - normal case */
1233 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1235 /* Layer still there - move down a layer */
1244 /* No handler - pop it */
1245 PerlIO_pop(aTHX_ t);
1248 if (PerlIOValid(f)) {
1249 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1250 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1258 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1259 PerlIO_list_t *layers, IV n, IV max)
1263 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1265 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1276 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1280 save_scalar(PL_errgv);
1282 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1283 code = PerlIO_parse_layers(aTHX_ layers, names);
1285 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1287 PerlIO_list_free(aTHX_ layers);
1294 /*--------------------------------------------------------------------------------------*/
1296 * Given the abstraction above the public API functions
1300 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1302 PERL_UNUSED_ARG(iotype);
1303 PERL_UNUSED_ARG(mode);
1306 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1307 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1308 PerlIOBase(f)->tab->name : "(Null)",
1309 iotype, mode, (names) ? names : "(Null)") );
1312 /* Do not flush etc. if (e.g.) switching encodings.
1313 if a pushed layer knows it needs to flush lower layers
1314 (for example :unix which is never going to call them)
1315 it can do the flush when it is pushed.
1317 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1320 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1321 #ifdef PERLIO_USING_CRLF
1322 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1323 O_BINARY so we can look for it in mode.
1325 if (!(mode & O_BINARY)) {
1327 /* FIXME?: Looking down the layer stack seems wrong,
1328 but is a way of reaching past (say) an encoding layer
1329 to flip CRLF-ness of the layer(s) below
1332 /* Perhaps we should turn on bottom-most aware layer
1333 e.g. Ilya's idea that UNIX TTY could serve
1335 if (PerlIOBase(f)->tab &&
1336 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1338 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1339 /* Not in text mode - flush any pending stuff and flip it */
1341 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1343 /* Only need to turn it on in one layer so we are done */
1348 /* Not finding a CRLF aware layer presumably means we are binary
1349 which is not what was requested - so we failed
1350 We _could_ push :crlf layer but so could caller
1355 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1356 So code that used to be here is now in PerlIORaw_pushed().
1358 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1363 PerlIO__close(pTHX_ PerlIO *f)
1365 if (PerlIOValid(f)) {
1366 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1367 if (tab && tab->Close)
1368 return (*tab->Close)(aTHX_ f);
1370 return PerlIOBase_close(aTHX_ f);
1373 SETERRNO(EBADF, SS_IVCHAN);
1379 Perl_PerlIO_close(pTHX_ PerlIO *f)
1381 const int code = PerlIO__close(aTHX_ f);
1382 while (PerlIOValid(f)) {
1383 PerlIO_pop(aTHX_ f);
1384 if (PerlIO_lockcnt(f))
1385 /* we're in use; the 'pop' deferred freeing the structure */
1392 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1394 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1398 static PerlIO_funcs *
1399 PerlIO_layer_from_ref(pTHX_ SV *sv)
1402 * For any scalar type load the handler which is bundled with perl
1404 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1405 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1406 /* This isn't supposed to happen, since PerlIO::scalar is core,
1407 * but could happen anyway in smaller installs or with PAR */
1409 /* diag_listed_as: Unknown PerlIO layer "%s" */
1410 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1415 * For other types allow if layer is known but don't try and load it
1417 switch (SvTYPE(sv)) {
1419 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1421 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1423 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1425 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1432 PerlIO_resolve_layers(pTHX_ const char *layers,
1433 const char *mode, int narg, SV **args)
1435 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1438 PerlIO_stdstreams(aTHX);
1440 SV * const arg = *args;
1442 * If it is a reference but not an object see if we have a handler
1445 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1446 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1448 def = PerlIO_list_alloc(aTHX);
1449 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1453 * Don't fail if handler cannot be found :via(...) etc. may do
1454 * something sensible else we will just stringfy and open
1459 if (!layers || !*layers)
1460 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1461 if (layers && *layers) {
1464 av = PerlIO_clone_list(aTHX_ def, NULL);
1469 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1473 PerlIO_list_free(aTHX_ av);
1485 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1486 int imode, int perm, PerlIO *f, int narg, SV **args)
1488 if (!f && narg == 1 && *args == &PL_sv_undef) {
1489 if ((f = PerlIO_tmpfile())) {
1490 if (!layers || !*layers)
1491 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1492 if (layers && *layers)
1493 PerlIO_apply_layers(aTHX_ f, mode, layers);
1497 PerlIO_list_t *layera;
1499 PerlIO_funcs *tab = NULL;
1500 if (PerlIOValid(f)) {
1502 * This is "reopen" - it is not tested as perl does not use it
1506 layera = PerlIO_list_alloc(aTHX);
1509 if (l->tab && l->tab->Getarg)
1510 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1511 PerlIO_list_push(aTHX_ layera, l->tab,
1512 (arg) ? arg : &PL_sv_undef);
1514 l = *PerlIONext(&l);
1518 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1524 * Start at "top" of layer stack
1526 n = layera->cur - 1;
1528 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1537 * Found that layer 'n' can do opens - call it
1539 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1540 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1542 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1543 tab->name, layers ? layers : "(Null)", mode, fd,
1544 imode, perm, (void*)f, narg, (void*)args) );
1546 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1549 SETERRNO(EINVAL, LIB_INVARG);
1553 if (n + 1 < layera->cur) {
1555 * More layers above the one that we used to open -
1558 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1559 /* If pushing layers fails close the file */
1566 PerlIO_list_free(aTHX_ layera);
1573 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1575 PERL_ARGS_ASSERT_PERLIO_READ;
1577 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1581 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1583 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1585 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1589 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1591 PERL_ARGS_ASSERT_PERLIO_WRITE;
1593 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1597 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1599 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1603 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1605 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1609 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1613 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1615 if (tab && tab->Flush)
1616 return (*tab->Flush) (aTHX_ f);
1618 return 0; /* If no Flush defined, silently succeed. */
1621 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1622 SETERRNO(EBADF, SS_IVCHAN);
1628 * Is it good API design to do flush-all on NULL, a potentially
1629 * erroneous input? Maybe some magical value (PerlIO*
1630 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1631 * things on fflush(NULL), but should we be bound by their design
1634 PerlIOl **table = &PL_perlio;
1637 while ((ff = *table)) {
1639 table = (PerlIOl **) (ff++);
1640 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1641 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1651 PerlIOBase_flush_linebuf(pTHX)
1653 PerlIOl **table = &PL_perlio;
1655 while ((f = *table)) {
1657 table = (PerlIOl **) (f++);
1658 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1660 && (PerlIOBase(&(f->next))->
1661 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1662 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1663 PerlIO_flush(&(f->next));
1670 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1672 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1676 PerlIO_isutf8(PerlIO *f)
1679 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1681 SETERRNO(EBADF, SS_IVCHAN);
1687 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1689 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1693 Perl_PerlIO_error(pTHX_ PerlIO *f)
1695 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1699 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1701 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1705 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1707 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1711 PerlIO_has_base(PerlIO *f)
1713 if (PerlIOValid(f)) {
1714 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1717 return (tab->Get_base != NULL);
1724 PerlIO_fast_gets(PerlIO *f)
1726 if (PerlIOValid(f)) {
1727 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1728 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1731 return (tab->Set_ptrcnt != NULL);
1739 PerlIO_has_cntptr(PerlIO *f)
1741 if (PerlIOValid(f)) {
1742 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1745 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1752 PerlIO_canset_cnt(PerlIO *f)
1754 if (PerlIOValid(f)) {
1755 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1758 return (tab->Set_ptrcnt != NULL);
1765 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1767 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1771 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1773 /* Note that Get_bufsiz returns a Size_t */
1774 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1778 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1780 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1784 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1786 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1790 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1792 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1796 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1798 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1802 /*--------------------------------------------------------------------------------------*/
1804 * utf8 and raw dummy layers
1808 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1810 PERL_UNUSED_CONTEXT;
1811 PERL_UNUSED_ARG(mode);
1812 PERL_UNUSED_ARG(arg);
1813 if (PerlIOValid(f)) {
1814 if (tab && tab->kind & PERLIO_K_UTF8)
1815 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1817 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1823 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1824 sizeof(PerlIO_funcs),
1827 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1847 NULL, /* get_base */
1848 NULL, /* get_bufsiz */
1851 NULL, /* set_ptrcnt */
1854 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1855 sizeof(PerlIO_funcs),
1858 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1878 NULL, /* get_base */
1879 NULL, /* get_bufsiz */
1882 NULL, /* set_ptrcnt */
1885 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1886 sizeof(PerlIO_funcs),
1909 NULL, /* get_base */
1910 NULL, /* get_bufsiz */
1913 NULL, /* set_ptrcnt */
1915 /*--------------------------------------------------------------------------------------*/
1916 /*--------------------------------------------------------------------------------------*/
1918 * "Methods" of the "base class"
1922 PerlIOBase_fileno(pTHX_ PerlIO *f)
1924 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1928 PerlIO_modestr(PerlIO * f, char *buf)
1931 if (PerlIOValid(f)) {
1932 const IV flags = PerlIOBase(f)->flags;
1933 if (flags & PERLIO_F_APPEND) {
1935 if (flags & PERLIO_F_CANREAD) {
1939 else if (flags & PERLIO_F_CANREAD) {
1941 if (flags & PERLIO_F_CANWRITE)
1944 else if (flags & PERLIO_F_CANWRITE) {
1946 if (flags & PERLIO_F_CANREAD) {
1950 #ifdef PERLIO_USING_CRLF
1951 if (!(flags & PERLIO_F_CRLF))
1961 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1963 PerlIOl * const l = PerlIOBase(f);
1964 PERL_UNUSED_CONTEXT;
1965 PERL_UNUSED_ARG(arg);
1967 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1968 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1969 if (tab && tab->Set_ptrcnt != NULL)
1970 l->flags |= PERLIO_F_FASTGETS;
1972 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1976 l->flags |= PERLIO_F_CANREAD;
1979 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1982 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1985 SETERRNO(EINVAL, LIB_INVARG);
1990 /* The mode variable contains one positional parameter followed by
1991 * optional keyword parameters. The positional parameters must be
1992 * passed as lowercase characters. The keyword parameters can be
1993 * passed in mixed case. They must be separated by commas. Only one
1994 * instance of a keyword can be specified. */
2000 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2004 l->flags &= ~PERLIO_F_CRLF;
2008 l->flags |= PERLIO_F_CRLF;
2022 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2025 l->flags &= ~PERLIO_F_CRLF;
2028 l->flags |= PERLIO_F_CRLF;
2031 SETERRNO(EINVAL, LIB_INVARG);
2039 l->flags |= l->next->flags &
2040 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2046 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2047 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2048 l->flags, PerlIO_modestr(f, temp));
2055 PerlIOBase_popped(pTHX_ PerlIO *f)
2057 PERL_UNUSED_CONTEXT;
2063 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2066 * Save the position as current head considers it
2068 const Off_t old = PerlIO_tell(f);
2069 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2070 PerlIOSelf(f, PerlIOBuf)->posn = old;
2071 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2075 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2077 STDCHAR *buf = (STDCHAR *) vbuf;
2079 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2080 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2081 SETERRNO(EBADF, SS_IVCHAN);
2082 PerlIO_save_errno(f);
2088 SSize_t avail = PerlIO_get_cnt(f);
2091 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2093 STDCHAR *ptr = PerlIO_get_ptr(f);
2094 Copy(ptr, buf, take, STDCHAR);
2095 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2098 if (avail == 0) /* set_ptrcnt could have reset avail */
2101 if (count > 0 && avail <= 0) {
2102 if (PerlIO_fill(f) != 0)
2107 return (buf - (STDCHAR *) vbuf);
2113 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2115 PERL_UNUSED_CONTEXT;
2121 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2123 PERL_UNUSED_CONTEXT;
2129 PerlIOBase_close(pTHX_ PerlIO *f)
2132 if (PerlIOValid(f)) {
2133 PerlIO *n = PerlIONext(f);
2134 code = PerlIO_flush(f);
2135 PerlIOBase(f)->flags &=
2136 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2137 while (PerlIOValid(n)) {
2138 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2139 if (tab && tab->Close) {
2140 if ((*tab->Close)(aTHX_ n) != 0)
2145 PerlIOBase(n)->flags &=
2146 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2152 SETERRNO(EBADF, SS_IVCHAN);
2158 PerlIOBase_eof(pTHX_ PerlIO *f)
2160 PERL_UNUSED_CONTEXT;
2161 if (PerlIOValid(f)) {
2162 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2168 PerlIOBase_error(pTHX_ PerlIO *f)
2170 PERL_UNUSED_CONTEXT;
2171 if (PerlIOValid(f)) {
2172 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2178 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2180 if (PerlIOValid(f)) {
2181 PerlIO * const n = PerlIONext(f);
2182 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2189 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2191 PERL_UNUSED_CONTEXT;
2192 if (PerlIOValid(f)) {
2193 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2198 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2204 arg = sv_dup(arg, param);
2205 SvREFCNT_inc_simple_void_NN(arg);
2209 return newSVsv(arg);
2212 PERL_UNUSED_ARG(param);
2213 return newSVsv(arg);
2218 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2220 PerlIO * const nexto = PerlIONext(o);
2221 if (PerlIOValid(nexto)) {
2222 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2223 if (tab && tab->Dup)
2224 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2226 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2229 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2233 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2235 (void*)f, (void*)o, (void*)param) );
2237 arg = (*self->Getarg)(aTHX_ o, param, flags);
2238 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2239 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2240 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2246 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2248 /* Must be called with PL_perlio_mutex locked. */
2250 S_more_refcounted_fds(pTHX_ const int new_fd)
2251 PERL_TSA_REQUIRES(PL_perlio_mutex)
2254 const int old_max = PL_perlio_fd_refcnt_size;
2255 const int new_max = 16 + (new_fd & ~15);
2258 #ifndef PERL_IMPLICIT_SYS
2259 PERL_UNUSED_CONTEXT;
2262 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2263 old_max, new_fd, new_max) );
2265 if (new_fd < old_max) {
2269 assert (new_max > new_fd);
2271 /* Use plain realloc() since we need this memory to be really
2272 * global and visible to all the interpreters and/or threads. */
2273 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2277 MUTEX_UNLOCK(&PL_perlio_mutex);
2282 PL_perlio_fd_refcnt_size = new_max;
2283 PL_perlio_fd_refcnt = new_array;
2285 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2286 (void*)(new_array + old_max),
2287 new_max - old_max) );
2289 Zero(new_array + old_max, new_max - old_max, int);
2296 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2297 PERL_UNUSED_CONTEXT;
2301 PerlIOUnix_refcnt_inc(int fd)
2308 MUTEX_LOCK(&PL_perlio_mutex);
2310 if (fd >= PL_perlio_fd_refcnt_size)
2311 S_more_refcounted_fds(aTHX_ fd);
2313 PL_perlio_fd_refcnt[fd]++;
2314 if (PL_perlio_fd_refcnt[fd] <= 0) {
2315 /* diag_listed_as: refcnt_inc: fd %d%s */
2316 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2317 fd, PL_perlio_fd_refcnt[fd]);
2319 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2320 fd, PL_perlio_fd_refcnt[fd]) );
2323 MUTEX_UNLOCK(&PL_perlio_mutex);
2326 /* diag_listed_as: refcnt_inc: fd %d%s */
2327 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2332 PerlIOUnix_refcnt_dec(int fd)
2342 MUTEX_LOCK(&PL_perlio_mutex);
2344 if (fd >= PL_perlio_fd_refcnt_size) {
2345 /* diag_listed_as: refcnt_dec: fd %d%s */
2346 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2347 fd, PL_perlio_fd_refcnt_size);
2349 if (PL_perlio_fd_refcnt[fd] <= 0) {
2350 /* diag_listed_as: refcnt_dec: fd %d%s */
2351 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2352 fd, PL_perlio_fd_refcnt[fd]);
2354 cnt = --PL_perlio_fd_refcnt[fd];
2355 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2357 MUTEX_UNLOCK(&PL_perlio_mutex);
2360 /* diag_listed_as: refcnt_dec: fd %d%s */
2361 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2367 PerlIOUnix_refcnt(int fd)
2374 MUTEX_LOCK(&PL_perlio_mutex);
2376 if (fd >= PL_perlio_fd_refcnt_size) {
2377 /* diag_listed_as: refcnt: fd %d%s */
2378 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2379 fd, PL_perlio_fd_refcnt_size);
2381 if (PL_perlio_fd_refcnt[fd] <= 0) {
2382 /* diag_listed_as: refcnt: fd %d%s */
2383 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2384 fd, PL_perlio_fd_refcnt[fd]);
2386 cnt = PL_perlio_fd_refcnt[fd];
2388 MUTEX_UNLOCK(&PL_perlio_mutex);
2391 /* diag_listed_as: refcnt: fd %d%s */
2392 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2398 PerlIO_cleanup(pTHX)
2402 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2404 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2407 /* Raise STDIN..STDERR refcount so we don't close them */
2408 for (i=0; i < 3; i++)
2409 PerlIOUnix_refcnt_inc(i);
2410 PerlIO_cleantable(aTHX_ &PL_perlio);
2411 /* Restore STDIN..STDERR refcount */
2412 for (i=0; i < 3; i++)
2413 PerlIOUnix_refcnt_dec(i);
2415 if (PL_known_layers) {
2416 PerlIO_list_free(aTHX_ PL_known_layers);
2417 PL_known_layers = NULL;
2419 if (PL_def_layerlist) {
2420 PerlIO_list_free(aTHX_ PL_def_layerlist);
2421 PL_def_layerlist = NULL;
2425 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2429 /* XXX we can't rely on an interpreter being present at this late stage,
2430 XXX so we can't use a function like PerlLIO_write that relies on one
2431 being present (at least in win32) :-(.
2436 /* By now all filehandles should have been closed, so any
2437 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2439 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2440 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2441 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2443 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2444 if (PL_perlio_fd_refcnt[i]) {
2446 my_snprintf(buf, sizeof(buf),
2447 "PerlIO_teardown: fd %d refcnt=%d\n",
2448 i, PL_perlio_fd_refcnt[i]);
2449 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2455 /* Not bothering with PL_perlio_mutex since by now
2456 * all the interpreters are gone. */
2457 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2458 && PL_perlio_fd_refcnt) {
2459 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2460 PL_perlio_fd_refcnt = NULL;
2461 PL_perlio_fd_refcnt_size = 0;
2465 /*--------------------------------------------------------------------------------------*/
2467 * Bottom-most level for UNIX-like case
2471 struct _PerlIO base; /* The generic part */
2472 int fd; /* UNIX like file descriptor */
2473 int oflags; /* open/fcntl flags */
2477 S_lockcnt_dec(pTHX_ const void* f)
2479 #ifndef PERL_IMPLICIT_SYS
2480 PERL_UNUSED_CONTEXT;
2482 PerlIO_lockcnt((PerlIO*)f)--;
2486 /* call the signal handler, and if that handler happens to clear
2487 * this handle, free what we can and return true */
2490 S_perlio_async_run(pTHX_ PerlIO* f) {
2492 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2493 PerlIO_lockcnt(f)++;
2495 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2499 /* we've just run some perl-level code that could have done
2500 * anything, including closing the file or clearing this layer.
2501 * If so, free any lower layers that have already been
2502 * cleared, then return an error. */
2503 while (PerlIOValid(f) &&
2504 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2506 const PerlIOl *l = *f;
2515 PerlIOUnix_oflags(const char *mode)
2518 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2523 if (*++mode == '+') {
2530 oflags = O_CREAT | O_TRUNC;
2531 if (*++mode == '+') {
2540 oflags = O_CREAT | O_APPEND;
2541 if (*++mode == '+') {
2550 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2552 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2553 * of them in, and then bit-and-masking the other them away, won't
2554 * have much of an effect. */
2557 #if O_TEXT != O_BINARY
2564 #if O_TEXT != O_BINARY
2566 oflags &= ~O_BINARY;
2572 /* bit-or:ing with zero O_BINARY would be useless. */
2574 * If neither "t" nor "b" was specified, open the file
2577 * Note that if something else than the zero byte was seen
2578 * here (e.g. bogus mode "rx"), just few lines later we will
2579 * set the errno and invalidate the flags.
2585 if (*mode || oflags == -1) {
2586 SETERRNO(EINVAL, LIB_INVARG);
2593 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2595 PERL_UNUSED_CONTEXT;
2596 return PerlIOSelf(f, PerlIOUnix)->fd;
2600 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2602 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2605 if (PerlLIO_fstat(fd, &st) == 0) {
2606 if (!S_ISREG(st.st_mode)) {
2607 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2608 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2611 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2617 PerlIOUnix_refcnt_inc(fd);
2618 PERL_UNUSED_CONTEXT;
2622 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2624 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2625 if (*PerlIONext(f)) {
2626 /* We never call down so do any pending stuff now */
2627 PerlIO_flush(PerlIONext(f));
2629 * XXX could (or should) we retrieve the oflags from the open file
2630 * handle rather than believing the "mode" we are passed in? XXX
2631 * Should the value on NULL mode be 0 or -1?
2633 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2634 mode ? PerlIOUnix_oflags(mode) : -1);
2636 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2642 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2644 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2646 PERL_UNUSED_CONTEXT;
2647 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2649 SETERRNO(ESPIPE, LIB_INVARG);
2651 SETERRNO(EINVAL, LIB_INVARG);
2655 new_loc = PerlLIO_lseek(fd, offset, whence);
2656 if (new_loc == (Off_t) - 1)
2658 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2663 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2664 IV n, const char *mode, int fd, int imode,
2665 int perm, PerlIO *f, int narg, SV **args)
2667 if (PerlIOValid(f)) {
2668 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2669 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2672 if (*mode == IoTYPE_NUMERIC)
2675 imode = PerlIOUnix_oflags(mode);
2677 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2684 const char *path = SvPV_const(*args, len);
2685 if (!IS_SAFE_PATHNAME(path, len, "open"))
2687 fd = PerlLIO_open3(path, imode, perm);
2691 if (*mode == IoTYPE_IMPLICIT)
2694 f = PerlIO_allocate(aTHX);
2696 if (!PerlIOValid(f)) {
2697 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2702 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2703 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2704 if (*mode == IoTYPE_APPEND)
2705 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2712 * FIXME: pop layers ???
2720 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2722 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2724 if (flags & PERLIO_DUP_FD) {
2725 fd = PerlLIO_dup(fd);
2728 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2730 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2731 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2741 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2744 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2746 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2747 #ifdef PERLIO_STD_SPECIAL
2749 return PERLIO_STD_IN(fd, vbuf, count);
2751 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2752 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2756 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2757 if (len >= 0 || errno != EINTR) {
2759 if (errno != EAGAIN) {
2760 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2761 PerlIO_save_errno(f);
2764 else if (len == 0 && count != 0) {
2765 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2771 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2774 NOT_REACHED; /*NOTREACHED*/
2778 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2781 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2783 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2784 #ifdef PERLIO_STD_SPECIAL
2785 if (fd == 1 || fd == 2)
2786 return PERLIO_STD_OUT(fd, vbuf, count);
2789 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2790 if (len >= 0 || errno != EINTR) {
2792 if (errno != EAGAIN) {
2793 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2794 PerlIO_save_errno(f);
2800 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2803 NOT_REACHED; /*NOTREACHED*/
2807 PerlIOUnix_tell(pTHX_ PerlIO *f)
2809 PERL_UNUSED_CONTEXT;
2811 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2816 PerlIOUnix_close(pTHX_ PerlIO *f)
2818 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2820 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2821 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2822 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2827 SETERRNO(EBADF,SS_IVCHAN);
2830 while (PerlLIO_close(fd) != 0) {
2831 if (errno != EINTR) {
2836 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2840 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2845 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2846 sizeof(PerlIO_funcs),
2853 PerlIOBase_binmode, /* binmode */
2863 PerlIOBase_noop_ok, /* flush */
2864 PerlIOBase_noop_fail, /* fill */
2867 PerlIOBase_clearerr,
2868 PerlIOBase_setlinebuf,
2869 NULL, /* get_base */
2870 NULL, /* get_bufsiz */
2873 NULL, /* set_ptrcnt */
2876 /*--------------------------------------------------------------------------------------*/
2881 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2882 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2883 broken by the last second glibc 2.3 fix
2885 #define STDIO_BUFFER_WRITABLE
2890 struct _PerlIO base;
2891 FILE *stdio; /* The stream */
2895 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2897 PERL_UNUSED_CONTEXT;
2899 if (PerlIOValid(f)) {
2900 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2902 return PerlSIO_fileno(s);
2909 PerlIOStdio_mode(const char *mode, char *tmode)
2911 char * const ret = tmode;
2917 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2925 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2928 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2929 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2930 if (toptab == tab) {
2931 /* Top is already stdio - pop self (duplicate) and use original */
2932 PerlIO_pop(aTHX_ f);
2935 const int fd = PerlIO_fileno(n);
2938 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2939 mode = PerlIOStdio_mode(mode, tmode)))) {
2940 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2941 /* We never call down so do any pending stuff now */
2942 PerlIO_flush(PerlIONext(f));
2943 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2950 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2955 PerlIO_importFILE(FILE *stdio, const char *mode)
2961 char filename[FILENAME_MAX];
2966 int fd0 = fileno(stdio);
2969 rc = fldata(stdio,filename,&fileinfo);
2973 if(fileinfo.__dsorgHFS){
2976 /*This MVS dataset , OK!*/
2981 if (!mode || !*mode) {
2982 /* We need to probe to see how we can open the stream
2983 so start with read/write and then try write and read
2984 we dup() so that we can fclose without loosing the fd.
2986 Note that the errno value set by a failing fdopen
2987 varies between stdio implementations.
2989 const int fd = PerlLIO_dup(fd0);
2994 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2996 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2999 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3002 /* Don't seem to be able to open */
3008 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3009 s = PerlIOSelf(f, PerlIOStdio);
3012 fd0 = fileno(stdio);
3014 PerlIOUnix_refcnt_inc(fd0);
3017 rc = fldata(stdio,filename,&fileinfo);
3019 PerlIOUnix_refcnt_inc(fd0);
3021 if(fileinfo.__dsorgHFS){
3022 PerlIOUnix_refcnt_inc(fd0);
3024 /*This MVS dataset , OK!*/
3027 PerlIOUnix_refcnt_inc(fileno(stdio));
3035 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3036 IV n, const char *mode, int fd, int imode,
3037 int perm, PerlIO *f, int narg, SV **args)
3040 if (PerlIOValid(f)) {
3042 const char * const path = SvPV_const(*args, len);
3043 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3045 if (!IS_SAFE_PATHNAME(path, len, "open"))
3047 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3048 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3053 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3059 const char * const path = SvPV_const(*args, len);
3060 if (!IS_SAFE_PATHNAME(path, len, "open"))
3062 if (*mode == IoTYPE_NUMERIC) {
3064 fd = PerlLIO_open3(path, imode, perm);
3068 bool appended = FALSE;
3070 /* Cygwin wants its 'b' early. */
3072 mode = PerlIOStdio_mode(mode, tmode);
3074 stdio = PerlSIO_fopen(path, mode);
3077 f = PerlIO_allocate(aTHX);
3080 mode = PerlIOStdio_mode(mode, tmode);
3081 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3083 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3084 PerlIOUnix_refcnt_inc(fileno(stdio));
3086 PerlSIO_fclose(stdio);
3098 if (*mode == IoTYPE_IMPLICIT) {
3105 stdio = PerlSIO_stdin;
3108 stdio = PerlSIO_stdout;
3111 stdio = PerlSIO_stderr;
3116 stdio = PerlSIO_fdopen(fd, mode =
3117 PerlIOStdio_mode(mode, tmode));
3121 f = PerlIO_allocate(aTHX);
3123 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3124 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3125 PerlIOUnix_refcnt_inc(fileno(stdio));
3136 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3138 /* This assumes no layers underneath - which is what
3139 happens, but is not how I remember it. NI-S 2001/10/16
3141 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3142 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3143 const int fd = fileno(stdio);
3145 if (flags & PERLIO_DUP_FD) {
3146 const int dfd = PerlLIO_dup(fileno(stdio));
3148 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3153 /* FIXME: To avoid messy error recovery if dup fails
3154 re-use the existing stdio as though flag was not set
3158 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3160 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3162 PerlIOUnix_refcnt_inc(fileno(stdio));
3169 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3171 PERL_UNUSED_CONTEXT;
3173 /* XXX this could use PerlIO_canset_fileno() and
3174 * PerlIO_set_fileno() support from Configure
3176 # if defined(HAS_FDCLOSE)
3177 return fdclose(f, NULL) == 0 ? 1 : 0;
3178 # elif defined(__UCLIBC__)
3179 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3182 # elif defined(__GLIBC__)
3183 /* There may be a better way for GLIBC:
3184 - libio.h defines a flag to not close() on cleanup
3188 # elif defined(__sun)
3191 # elif defined(__hpux)
3195 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3196 your platform does not have special entry try this one.
3197 [For OSF only have confirmation for Tru64 (alpha)
3198 but assume other OSFs will be similar.]
3200 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3203 # elif defined(__FreeBSD__)
3204 /* There may be a better way on FreeBSD:
3205 - we could insert a dummy func in the _close function entry
3206 f->_close = (int (*)(void *)) dummy_close;
3210 # elif defined(__OpenBSD__)
3211 /* There may be a better way on OpenBSD:
3212 - we could insert a dummy func in the _close function entry
3213 f->_close = (int (*)(void *)) dummy_close;
3217 # elif defined(__EMX__)
3218 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3221 # elif defined(__CYGWIN__)
3222 /* There may be a better way on CYGWIN:
3223 - we could insert a dummy func in the _close function entry
3224 f->_close = (int (*)(void *)) dummy_close;
3228 # elif defined(WIN32)
3229 # if defined(UNDER_CE)
3230 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3239 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3240 (which isn't thread safe) instead
3242 # error "Don't know how to set FILE.fileno on your platform"
3250 PerlIOStdio_close(pTHX_ PerlIO *f)
3252 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3258 const int fd = fileno(stdio);
3266 #ifdef SOCKS5_VERSION_NAME
3267 /* Socks lib overrides close() but stdio isn't linked to
3268 that library (though we are) - so we must call close()
3269 on sockets on stdio's behalf.
3272 Sock_size_t optlen = sizeof(int);
3273 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3276 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3277 that a subsequent fileno() on it returns -1. Don't want to croak()
3278 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3279 trying to close an already closed handle which somehow it still has
3280 a reference to. (via.xs, I'm looking at you). */
3281 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3282 /* File descriptor still in use */
3286 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3287 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3289 if (stdio == stdout || stdio == stderr)
3290 return PerlIO_flush(f);
3293 MUTEX_LOCK(&PL_perlio_mutex);
3294 /* Right. We need a mutex here because for a brief while we
3295 will have the situation that fd is actually closed. Hence if
3296 a second thread were to get into this block, its dup() would
3297 likely return our fd as its dupfd. (after all, it is closed)
3298 Then if we get to the dup2() first, we blat the fd back
3299 (messing up its temporary as a side effect) only for it to
3300 then close its dupfd (== our fd) in its close(dupfd) */
3302 /* There is, of course, a race condition, that any other thread
3303 trying to input/output/whatever on this fd will be stuffed
3304 for the duration of this little manoeuvrer. Perhaps we
3305 should hold an IO mutex for the duration of every IO
3306 operation if we know that invalidate doesn't work on this
3307 platform, but that would suck, and could kill performance.
3309 Except that correctness trumps speed.
3310 Advice from klortho #11912. */
3313 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3314 Use Sarathy's trick from maint-5.6 to invalidate the
3315 fileno slot of the FILE *
3317 result = PerlIO_flush(f);
3319 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3321 dupfd = PerlLIO_dup(fd);
3324 /* Oh cXap. This isn't going to go well. Not sure if we can
3325 recover from here, or if closing this particular FILE *
3326 is a good idea now. */
3331 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3333 result = PerlSIO_fclose(stdio);
3334 /* We treat error from stdio as success if we invalidated
3335 errno may NOT be expected EBADF
3337 if (invalidate && result != 0) {
3341 #ifdef SOCKS5_VERSION_NAME
3342 /* in SOCKS' case, let close() determine return value */
3346 PerlLIO_dup2(dupfd,fd);
3347 PerlLIO_close(dupfd);
3350 MUTEX_UNLOCK(&PL_perlio_mutex);
3357 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3361 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3363 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3366 STDCHAR *buf = (STDCHAR *) vbuf;
3368 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3369 * stdio does not do that for fread()
3371 const int ch = PerlSIO_fgetc(s);
3378 got = PerlSIO_fread(vbuf, 1, count, s);
3379 if (got == 0 && PerlSIO_ferror(s))
3381 if (got >= 0 || errno != EINTR)
3383 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3385 SETERRNO(0,0); /* just in case */
3388 /* Under some circumstances IRIX stdio fgetc() and fread()
3389 * set the errno to ENOENT, which makes no sense according
3390 * to either IRIX or POSIX. [rt.perl.org #123977] */
3391 if (errno == ENOENT) SETERRNO(0,0);
3397 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3400 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3402 #ifdef STDIO_BUFFER_WRITABLE
3403 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3404 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3405 STDCHAR *base = PerlIO_get_base(f);
3406 SSize_t cnt = PerlIO_get_cnt(f);
3407 STDCHAR *ptr = PerlIO_get_ptr(f);
3408 SSize_t avail = ptr - base;
3410 if (avail > count) {
3414 Move(buf-avail,ptr,avail,STDCHAR);
3417 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3418 if (PerlSIO_feof(s) && unread >= 0)
3419 PerlSIO_clearerr(s);
3424 if (PerlIO_has_cntptr(f)) {
3425 /* We can get pointer to buffer but not its base
3426 Do ungetc() but check chars are ending up in the
3429 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3430 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3432 const int ch = *--buf & 0xFF;
3433 if (ungetc(ch,s) != ch) {
3434 /* ungetc did not work */
3437 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3438 /* Did not change pointer as expected */
3439 if (fgetc(s) != EOF) /* get char back again */
3449 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3455 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3458 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3461 got = PerlSIO_fwrite(vbuf, 1, count,
3462 PerlIOSelf(f, PerlIOStdio)->stdio);
3463 if (got >= 0 || errno != EINTR)
3465 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3467 SETERRNO(0,0); /* just in case */
3473 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3475 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3476 PERL_UNUSED_CONTEXT;
3478 return PerlSIO_fseek(stdio, offset, whence);
3482 PerlIOStdio_tell(pTHX_ PerlIO *f)
3484 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3485 PERL_UNUSED_CONTEXT;
3487 return PerlSIO_ftell(stdio);
3491 PerlIOStdio_flush(pTHX_ PerlIO *f)
3493 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3494 PERL_UNUSED_CONTEXT;
3496 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3497 return PerlSIO_fflush(stdio);
3503 * FIXME: This discards ungetc() and pre-read stuff which is not
3504 * right if this is just a "sync" from a layer above Suspect right
3505 * design is to do _this_ but not have layer above flush this
3506 * layer read-to-read
3509 * Not writeable - sync by attempting a seek
3512 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3520 PerlIOStdio_eof(pTHX_ PerlIO *f)
3522 PERL_UNUSED_CONTEXT;
3524 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3528 PerlIOStdio_error(pTHX_ PerlIO *f)
3530 PERL_UNUSED_CONTEXT;
3532 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3536 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3538 PERL_UNUSED_CONTEXT;
3540 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3544 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3546 PERL_UNUSED_CONTEXT;
3548 #ifdef HAS_SETLINEBUF
3549 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3551 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3557 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3559 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3560 PERL_UNUSED_CONTEXT;
3561 return (STDCHAR*)PerlSIO_get_base(stdio);
3565 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3567 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3568 PERL_UNUSED_CONTEXT;
3569 return PerlSIO_get_bufsiz(stdio);
3573 #ifdef USE_STDIO_PTR
3575 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3577 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3578 PERL_UNUSED_CONTEXT;
3579 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3583 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3585 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3586 PERL_UNUSED_CONTEXT;
3587 return PerlSIO_get_cnt(stdio);
3591 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3593 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3594 PERL_UNUSED_CONTEXT;
3596 #ifdef STDIO_PTR_LVALUE
3597 /* This is a long-standing infamous mess. The root of the
3598 * problem is that one cannot know the signedness of char, and
3599 * more precisely the signedness of FILE._ptr. The following
3600 * things have been tried, and they have all failed (across
3601 * different compilers (remember that core needs to to build
3602 * also with c++) and compiler options:
3604 * - casting the RHS to (void*) -- works in *some* places
3605 * - casting the LHS to (void*) -- totally unportable
3607 * So let's try silencing the warning at least for gcc. */
3608 GCC_DIAG_IGNORE(-Wpointer-sign);
3609 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3611 #ifdef STDIO_PTR_LVAL_SETS_CNT
3612 assert(PerlSIO_get_cnt(stdio) == (cnt));
3614 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3616 * Setting ptr _does_ change cnt - we are done
3620 #else /* STDIO_PTR_LVALUE */
3622 #endif /* STDIO_PTR_LVALUE */
3625 * Now (or only) set cnt
3627 #ifdef STDIO_CNT_LVALUE
3628 PerlSIO_set_cnt(stdio, cnt);
3629 #else /* STDIO_CNT_LVALUE */
3630 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3631 PerlSIO_set_ptr(stdio,
3632 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3634 #else /* STDIO_PTR_LVAL_SETS_CNT */
3636 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3637 #endif /* STDIO_CNT_LVALUE */
3644 PerlIOStdio_fill(pTHX_ PerlIO *f)
3648 PERL_UNUSED_CONTEXT;
3649 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3651 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3654 * fflush()ing read-only streams can cause trouble on some stdio-s
3656 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3657 if (PerlSIO_fflush(stdio) != 0)
3661 c = PerlSIO_fgetc(stdio);
3664 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3666 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3671 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3673 #ifdef STDIO_BUFFER_WRITABLE
3674 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3675 /* Fake ungetc() to the real buffer in case system's ungetc
3678 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3679 SSize_t cnt = PerlSIO_get_cnt(stdio);
3680 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3681 if (ptr == base+1) {
3682 *--ptr = (STDCHAR) c;
3683 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3684 if (PerlSIO_feof(stdio))
3685 PerlSIO_clearerr(stdio);
3691 if (PerlIO_has_cntptr(f)) {
3693 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3699 /* If buffer snoop scheme above fails fall back to
3702 if (PerlSIO_ungetc(c, stdio) != c)
3710 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3711 sizeof(PerlIO_funcs),
3713 sizeof(PerlIOStdio),
3714 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3718 PerlIOBase_binmode, /* binmode */
3732 PerlIOStdio_clearerr,
3733 PerlIOStdio_setlinebuf,
3735 PerlIOStdio_get_base,
3736 PerlIOStdio_get_bufsiz,
3741 #ifdef USE_STDIO_PTR
3742 PerlIOStdio_get_ptr,
3743 PerlIOStdio_get_cnt,
3744 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3745 PerlIOStdio_set_ptrcnt,
3748 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3753 #endif /* USE_STDIO_PTR */
3756 /* Note that calls to PerlIO_exportFILE() are reversed using
3757 * PerlIO_releaseFILE(), not importFILE. */
3759 PerlIO_exportFILE(PerlIO * f, const char *mode)
3763 if (PerlIOValid(f)) {
3765 int fd = PerlIO_fileno(f);
3770 if (!mode || !*mode) {
3771 mode = PerlIO_modestr(f, buf);
3773 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3777 /* De-link any lower layers so new :stdio sticks */
3779 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3780 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3782 PerlIOUnix_refcnt_inc(fileno(stdio));
3783 /* Link previous lower layers under new one */
3787 /* restore layers list */
3797 PerlIO_findFILE(PerlIO *f)
3802 if (l->tab == &PerlIO_stdio) {
3803 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3806 l = *PerlIONext(&l);
3808 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3809 /* However, we're not really exporting a FILE * to someone else (who
3810 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3811 So we need to undo its reference count increase on the underlying file
3812 descriptor. We have to do this, because if the loop above returns you
3813 the FILE *, then *it* didn't increase any reference count. So there's
3814 only one way to be consistent. */
3815 stdio = PerlIO_exportFILE(f, NULL);
3817 const int fd = fileno(stdio);
3819 PerlIOUnix_refcnt_dec(fd);
3824 /* Use this to reverse PerlIO_exportFILE calls. */
3826 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3830 if (l->tab == &PerlIO_stdio) {
3831 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3832 if (s->stdio == f) { /* not in a loop */
3833 const int fd = fileno(f);
3835 PerlIOUnix_refcnt_dec(fd);
3838 PerlIO_pop(aTHX_ p);
3848 /*--------------------------------------------------------------------------------------*/
3850 * perlio buffer layer
3854 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3856 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3857 const int fd = PerlIO_fileno(f);
3858 if (fd >= 0 && PerlLIO_isatty(fd)) {
3859 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3861 if (*PerlIONext(f)) {
3862 const Off_t posn = PerlIO_tell(PerlIONext(f));
3863 if (posn != (Off_t) - 1) {
3867 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3871 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3872 IV n, const char *mode, int fd, int imode, int perm,
3873 PerlIO *f, int narg, SV **args)
3875 if (PerlIOValid(f)) {
3876 PerlIO *next = PerlIONext(f);
3878 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3879 if (tab && tab->Open)
3881 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3883 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3888 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3890 if (*mode == IoTYPE_IMPLICIT) {
3896 if (tab && tab->Open)
3897 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3900 SETERRNO(EINVAL, LIB_INVARG);
3902 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3904 * if push fails during open, open fails. close will pop us.
3909 fd = PerlIO_fileno(f);
3910 if (init && fd == 2) {
3912 * Initial stderr is unbuffered
3914 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3916 #ifdef PERLIO_USING_CRLF
3917 # ifdef PERLIO_IS_BINMODE_FD
3918 if (PERLIO_IS_BINMODE_FD(fd))
3919 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3923 * do something about failing setmode()? --jhi
3925 PerlLIO_setmode(fd, O_BINARY);
3928 /* Enable line buffering with record-oriented regular files
3929 * so we don't introduce an extraneous record boundary when
3930 * the buffer fills up.
3932 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3934 if (PerlLIO_fstat(fd, &st) == 0
3935 && S_ISREG(st.st_mode)
3936 && (st.st_fab_rfm == FAB$C_VAR
3937 || st.st_fab_rfm == FAB$C_VFC)) {
3938 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3949 * This "flush" is akin to sfio's sync in that it handles files in either
3950 * read or write state. For write state, we put the postponed data through
3951 * the next layers. For read state, we seek() the next layers to the
3952 * offset given by current position in the buffer, and discard the buffer
3953 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3954 * in any case?). Then the pass the stick further in chain.
3957 PerlIOBuf_flush(pTHX_ PerlIO *f)
3959 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3961 PerlIO *n = PerlIONext(f);
3962 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3964 * write() the buffer
3966 const STDCHAR *buf = b->buf;
3967 const STDCHAR *p = buf;
3968 while (p < b->ptr) {
3969 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3973 else if (count < 0 || PerlIO_error(n)) {
3974 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3975 PerlIO_save_errno(f);
3980 b->posn += (p - buf);
3982 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3983 STDCHAR *buf = PerlIO_get_base(f);
3985 * Note position change
3987 b->posn += (b->ptr - buf);
3988 if (b->ptr < b->end) {
3989 /* We did not consume all of it - try and seek downstream to
3990 our logical position
3992 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3993 /* Reload n as some layers may pop themselves on seek */
3994 b->posn = PerlIO_tell(n = PerlIONext(f));
3997 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3998 data is lost for good - so return saying "ok" having undone
4001 b->posn -= (b->ptr - buf);
4006 b->ptr = b->end = b->buf;
4007 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4008 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4009 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4014 /* This discards the content of the buffer after b->ptr, and rereads
4015 * the buffer from the position off in the layer downstream; here off
4016 * is at offset corresponding to b->ptr - b->buf.
4019 PerlIOBuf_fill(pTHX_ PerlIO *f)
4021 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4022 PerlIO *n = PerlIONext(f);
4025 * Down-stream flush is defined not to loose read data so is harmless.
4026 * we would not normally be fill'ing if there was data left in anycase.
4028 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4030 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4031 PerlIOBase_flush_linebuf(aTHX);
4034 PerlIO_get_base(f); /* allocate via vtable */
4036 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4038 b->ptr = b->end = b->buf;
4040 if (!PerlIOValid(n)) {
4041 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4045 if (PerlIO_fast_gets(n)) {
4047 * Layer below is also buffered. We do _NOT_ want to call its
4048 * ->Read() because that will loop till it gets what we asked for
4049 * which may hang on a pipe etc. Instead take anything it has to
4050 * hand, or ask it to fill _once_.
4052 avail = PerlIO_get_cnt(n);
4054 avail = PerlIO_fill(n);
4056 avail = PerlIO_get_cnt(n);
4058 if (!PerlIO_error(n) && PerlIO_eof(n))
4063 STDCHAR *ptr = PerlIO_get_ptr(n);
4064 const SSize_t cnt = avail;
4065 if (avail > (SSize_t)b->bufsiz)
4067 Copy(ptr, b->buf, avail, STDCHAR);
4068 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4072 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4076 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4079 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4080 PerlIO_save_errno(f);
4084 b->end = b->buf + avail;
4085 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4090 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4092 if (PerlIOValid(f)) {
4093 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4096 return PerlIOBase_read(aTHX_ f, vbuf, count);
4102 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4104 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4105 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4108 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4113 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4115 * Buffer is already a read buffer, we can overwrite any chars
4116 * which have been read back to buffer start
4118 avail = (b->ptr - b->buf);
4122 * Buffer is idle, set it up so whole buffer is available for
4126 b->end = b->buf + avail;
4128 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4130 * Buffer extends _back_ from where we are now
4132 b->posn -= b->bufsiz;
4134 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4136 * If we have space for more than count, just move count
4144 * In simple stdio-like ungetc() case chars will be already
4147 if (buf != b->ptr) {
4148 Copy(buf, b->ptr, avail, STDCHAR);
4152 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4156 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4162 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4164 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4165 const STDCHAR *buf = (const STDCHAR *) vbuf;
4166 const STDCHAR *flushptr = buf;
4170 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4172 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4173 if (PerlIO_flush(f) != 0) {
4177 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4178 flushptr = buf + count;
4179 while (flushptr > buf && *(flushptr - 1) != '\n')
4183 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4184 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4186 if (flushptr > buf && flushptr <= buf + avail)
4187 avail = flushptr - buf;
4188 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4190 Copy(buf, b->ptr, avail, STDCHAR);
4195 if (buf == flushptr)
4198 if (b->ptr >= (b->buf + b->bufsiz))
4199 if (PerlIO_flush(f) == -1)
4202 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4208 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4211 if ((code = PerlIO_flush(f)) == 0) {
4212 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4213 code = PerlIO_seek(PerlIONext(f), offset, whence);
4215 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4216 b->posn = PerlIO_tell(PerlIONext(f));
4223 PerlIOBuf_tell(pTHX_ PerlIO *f)
4225 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4227 * b->posn is file position where b->buf was read, or will be written
4229 Off_t posn = b->posn;
4230 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4231 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4233 /* As O_APPEND files are normally shared in some sense it is better
4238 /* when file is NOT shared then this is sufficient */
4239 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4241 posn = b->posn = PerlIO_tell(PerlIONext(f));
4245 * If buffer is valid adjust position by amount in buffer
4247 posn += (b->ptr - b->buf);
4253 PerlIOBuf_popped(pTHX_ PerlIO *f)
4255 const IV code = PerlIOBase_popped(aTHX_ f);
4256 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4257 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4260 b->ptr = b->end = b->buf = NULL;
4261 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4266 PerlIOBuf_close(pTHX_ PerlIO *f)
4268 const IV code = PerlIOBase_close(aTHX_ f);
4269 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4270 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4273 b->ptr = b->end = b->buf = NULL;
4274 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4279 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4281 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4288 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4290 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4293 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4294 return (b->end - b->ptr);
4299 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4301 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4302 PERL_UNUSED_CONTEXT;
4306 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4307 Newxz(b->buf,b->bufsiz, STDCHAR);
4309 b->buf = (STDCHAR *) & b->oneword;
4310 b->bufsiz = sizeof(b->oneword);
4312 b->end = b->ptr = b->buf;
4318 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4320 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4323 return (b->end - b->buf);
4327 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4329 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4331 PERL_UNUSED_ARG(cnt);
4336 assert(PerlIO_get_cnt(f) == cnt);
4337 assert(b->ptr >= b->buf);
4338 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4342 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4344 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4349 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4350 sizeof(PerlIO_funcs),
4353 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4357 PerlIOBase_binmode, /* binmode */
4371 PerlIOBase_clearerr,
4372 PerlIOBase_setlinebuf,
4377 PerlIOBuf_set_ptrcnt,
4380 /*--------------------------------------------------------------------------------------*/
4382 * Temp layer to hold unread chars when cannot do it any other way
4386 PerlIOPending_fill(pTHX_ PerlIO *f)
4389 * Should never happen
4396 PerlIOPending_close(pTHX_ PerlIO *f)
4399 * A tad tricky - flush pops us, then we close new top
4402 return PerlIO_close(f);
4406 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4409 * A tad tricky - flush pops us, then we seek new top
4412 return PerlIO_seek(f, offset, whence);
4417 PerlIOPending_flush(pTHX_ PerlIO *f)
4419 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4420 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4424 PerlIO_pop(aTHX_ f);
4429 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4435 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4440 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4442 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4443 PerlIOl * const l = PerlIOBase(f);
4445 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4446 * etc. get muddled when it changes mid-string when we auto-pop.
4448 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4449 (PerlIOBase(PerlIONext(f))->
4450 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4455 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4457 SSize_t avail = PerlIO_get_cnt(f);
4459 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4462 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4463 if (got >= 0 && got < (SSize_t)count) {
4464 const SSize_t more =
4465 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4466 if (more >= 0 || got == 0)
4472 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4473 sizeof(PerlIO_funcs),
4476 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4477 PerlIOPending_pushed,
4480 PerlIOBase_binmode, /* binmode */
4489 PerlIOPending_close,
4490 PerlIOPending_flush,
4494 PerlIOBase_clearerr,
4495 PerlIOBase_setlinebuf,
4500 PerlIOPending_set_ptrcnt,
4505 /*--------------------------------------------------------------------------------------*/
4507 * crlf - translation On read translate CR,LF to "\n" we do this by
4508 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4509 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4511 * c->nl points on the first byte of CR LF pair when it is temporarily
4512 * replaced by LF, or to the last CR of the buffer. In the former case
4513 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4514 * that it ends at c->nl; these two cases can be distinguished by
4515 * *c->nl. c->nl is set during _getcnt() call, and unset during
4516 * _unread() and _flush() calls.
4517 * It only matters for read operations.
4521 PerlIOBuf base; /* PerlIOBuf stuff */
4522 STDCHAR *nl; /* Position of crlf we "lied" about in the
4526 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4527 * Otherwise the :crlf layer would always revert back to
4531 S_inherit_utf8_flag(PerlIO *f)
4533 PerlIO *g = PerlIONext(f);
4534 if (PerlIOValid(g)) {
4535 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4536 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4542 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4545 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4546 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4549 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4550 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4551 PerlIOBase(f)->flags);
4555 /* If the old top layer is a CRLF layer, reactivate it (if
4556 * necessary) and remove this new layer from the stack */
4557 PerlIO *g = PerlIONext(f);
4558 if (PerlIOValid(g)) {
4559 PerlIOl *b = PerlIOBase(g);
4560 if (b && b->tab == &PerlIO_crlf) {
4561 if (!(b->flags & PERLIO_F_CRLF))
4562 b->flags |= PERLIO_F_CRLF;
4563 S_inherit_utf8_flag(g);
4564 PerlIO_pop(aTHX_ f);
4569 S_inherit_utf8_flag(f);
4575 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4577 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4578 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4579 *(c->nl) = NATIVE_0xd;
4582 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4583 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4585 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4586 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4588 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4593 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4594 b->end = b->ptr = b->buf + b->bufsiz;
4595 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4596 b->posn -= b->bufsiz;
4598 while (count > 0 && b->ptr > b->buf) {
4599 const int ch = *--buf;
4601 if (b->ptr - 2 >= b->buf) {
4602 *--(b->ptr) = NATIVE_0xa;
4603 *--(b->ptr) = NATIVE_0xd;
4608 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4609 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4623 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4628 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4630 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4632 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4635 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4636 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4637 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4638 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4640 while (nl < b->end && *nl != NATIVE_0xd)
4642 if (nl < b->end && *nl == NATIVE_0xd) {
4644 if (nl + 1 < b->end) {
4645 if (nl[1] == NATIVE_0xa) {
4651 * Not CR,LF but just CR
4659 * Blast - found CR as last char in buffer
4664 * They may not care, defer work as long as
4668 return (nl - b->ptr);
4672 b->ptr++; /* say we have read it as far as
4673 * flush() is concerned */
4674 b->buf++; /* Leave space in front of buffer */
4675 /* Note as we have moved buf up flush's
4677 will naturally make posn point at CR
4679 b->bufsiz--; /* Buffer is thus smaller */
4680 code = PerlIO_fill(f); /* Fetch some more */
4681 b->bufsiz++; /* Restore size for next time */
4682 b->buf--; /* Point at space */
4683 b->ptr = nl = b->buf; /* Which is what we hand
4685 *nl = NATIVE_0xd; /* Fill in the CR */
4687 goto test; /* fill() call worked */
4689 * CR at EOF - just fall through
4691 /* Should we clear EOF though ??? */
4696 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4702 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4704 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4705 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4711 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4712 /* Deferred CR at end of buffer case - we lied about count */
4725 * Test code - delete when it works ...
4727 IV flags = PerlIOBase(f)->flags;
4728 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4729 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4730 /* Deferred CR at end of buffer case - we lied about count */
4736 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4737 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4738 flags, c->nl, b->end, cnt);
4745 * They have taken what we lied about
4747 *(c->nl) = NATIVE_0xd;
4753 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4757 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4759 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4760 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4762 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4763 const STDCHAR *buf = (const STDCHAR *) vbuf;
4764 const STDCHAR * const ebuf = buf + count;
4767 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4769 while (buf < ebuf) {
4770 const STDCHAR * const eptr = b->buf + b->bufsiz;
4771 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4772 while (buf < ebuf && b->ptr < eptr) {
4774 if ((b->ptr + 2) > eptr) {
4782 *(b->ptr)++ = NATIVE_0xd; /* CR */
4783 *(b->ptr)++ = NATIVE_0xa; /* LF */
4785 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4792 *(b->ptr)++ = *buf++;
4794 if (b->ptr >= eptr) {
4800 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4802 return (buf - (STDCHAR *) vbuf);
4807 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4809 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4811 *(c->nl) = NATIVE_0xd;
4814 return PerlIOBuf_flush(aTHX_ f);
4818 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4820 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4821 /* In text mode - flush any pending stuff and flip it */
4822 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4823 #ifndef PERLIO_USING_CRLF
4824 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4825 PerlIO_pop(aTHX_ f);
4831 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4832 sizeof(PerlIO_funcs),
4835 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4837 PerlIOBuf_popped, /* popped */
4839 PerlIOCrlf_binmode, /* binmode */
4843 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4844 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4845 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4853 PerlIOBase_clearerr,
4854 PerlIOBase_setlinebuf,
4859 PerlIOCrlf_set_ptrcnt,
4863 Perl_PerlIO_stdin(pTHX)
4866 PerlIO_stdstreams(aTHX);
4868 return (PerlIO*)&PL_perlio[1];
4872 Perl_PerlIO_stdout(pTHX)
4875 PerlIO_stdstreams(aTHX);
4877 return (PerlIO*)&PL_perlio[2];
4881 Perl_PerlIO_stderr(pTHX)
4884 PerlIO_stdstreams(aTHX);
4886 return (PerlIO*)&PL_perlio[3];
4889 /*--------------------------------------------------------------------------------------*/
4892 PerlIO_getname(PerlIO *f, char *buf)
4897 bool exported = FALSE;
4898 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4900 stdio = PerlIO_exportFILE(f,0);
4904 name = fgetname(stdio, buf);
4905 if (exported) PerlIO_releaseFILE(f,stdio);
4910 PERL_UNUSED_ARG(buf);
4911 Perl_croak_nocontext("Don't know how to get file name");
4917 /*--------------------------------------------------------------------------------------*/
4919 * Functions which can be called on any kind of PerlIO implemented in
4923 #undef PerlIO_fdopen
4925 PerlIO_fdopen(int fd, const char *mode)
4928 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4933 PerlIO_open(const char *path, const char *mode)
4936 SV *name = sv_2mortal(newSVpv(path, 0));
4937 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4940 #undef Perlio_reopen
4942 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4945 SV *name = sv_2mortal(newSVpv(path,0));
4946 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4951 PerlIO_getc(PerlIO *f)
4955 if ( 1 == PerlIO_read(f, buf, 1) ) {
4956 return (unsigned char) buf[0];
4961 #undef PerlIO_ungetc
4963 PerlIO_ungetc(PerlIO *f, int ch)
4968 if (PerlIO_unread(f, &buf, 1) == 1)
4976 PerlIO_putc(PerlIO *f, int ch)
4980 return PerlIO_write(f, &buf, 1);
4985 PerlIO_puts(PerlIO *f, const char *s)
4988 return PerlIO_write(f, s, strlen(s));
4991 #undef PerlIO_rewind
4993 PerlIO_rewind(PerlIO *f)
4996 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5000 #undef PerlIO_vprintf
5002 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5011 Perl_va_copy(ap, apc);
5012 sv = vnewSVpvf(fmt, &apc);
5015 sv = vnewSVpvf(fmt, &ap);
5017 s = SvPV_const(sv, len);
5018 wrote = PerlIO_write(f, s, len);
5023 #undef PerlIO_printf
5025 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5030 result = PerlIO_vprintf(f, fmt, ap);
5035 #undef PerlIO_stdoutf
5037 PerlIO_stdoutf(const char *fmt, ...)
5043 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5048 #undef PerlIO_tmpfile
5050 PerlIO_tmpfile(void)
5057 const int fd = win32_tmpfd();
5059 f = PerlIO_fdopen(fd, "w+b");
5061 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5063 char tempname[] = "/tmp/PerlIO_XXXXXX";
5064 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5066 int old_umask = umask(0177);
5068 * I have no idea how portable mkstemp() is ... NI-S
5070 if (tmpdir && *tmpdir) {
5071 /* if TMPDIR is set and not empty, we try that first */
5072 sv = newSVpv(tmpdir, 0);
5073 sv_catpv(sv, tempname + 4);
5074 fd = mkstemp(SvPVX(sv));
5079 /* else we try /tmp */
5080 fd = mkstemp(tempname);
5085 sv_catpv(sv, tempname + 4);
5086 fd = mkstemp(SvPVX(sv));
5090 f = PerlIO_fdopen(fd, "w+");
5092 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5093 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5096 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5097 FILE * const stdio = PerlSIO_tmpfile();
5100 f = PerlIO_fdopen(fileno(stdio), "w+");
5102 # endif /* else HAS_MKSTEMP */
5103 #endif /* else WIN32 */
5108 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5110 PERL_UNUSED_CONTEXT;
5111 if (!PerlIOValid(f))
5113 PerlIOBase(f)->err = errno;
5115 PerlIOBase(f)->os_err = vaxc$errno;
5117 PerlIOBase(f)->os_err = Perl_rc;
5118 #elif defined(WIN32)
5119 PerlIOBase(f)->os_err = GetLastError();
5124 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5126 PERL_UNUSED_CONTEXT;
5127 if (!PerlIOValid(f))
5129 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5131 Perl_rc = PerlIOBase(f)->os_err);
5132 #elif defined(WIN32)
5133 SetLastError(PerlIOBase(f)->os_err);
5141 /*======================================================================================*/
5143 * Now some functions in terms of above which may be needed even if we are
5144 * not in true PerlIO mode
5147 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5149 const char *direction = NULL;
5152 * Need to supply default layer info from open.pm
5158 if (mode && mode[0] != 'r') {
5159 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5160 direction = "open>";
5162 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5163 direction = "open<";
5168 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5171 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5176 #undef PerlIO_setpos
5178 PerlIO_setpos(PerlIO *f, SV *pos)
5184 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5185 if(len == sizeof(Off_t))
5186 return PerlIO_seek(f, *posn, SEEK_SET);
5189 SETERRNO(EINVAL, SS_IVCHAN);
5193 #undef PerlIO_setpos
5195 PerlIO_setpos(PerlIO *f, SV *pos)
5201 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5202 if(len == sizeof(Fpos_t))
5203 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5204 return fsetpos64(f, fpos);
5206 return fsetpos(f, fpos);
5210 SETERRNO(EINVAL, SS_IVCHAN);
5216 #undef PerlIO_getpos
5218 PerlIO_getpos(PerlIO *f, SV *pos)
5221 Off_t posn = PerlIO_tell(f);
5222 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5223 return (posn == (Off_t) - 1) ? -1 : 0;
5226 #undef PerlIO_getpos
5228 PerlIO_getpos(PerlIO *f, SV *pos)
5233 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5234 code = fgetpos64(f, &fpos);
5236 code = fgetpos(f, &fpos);
5238 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5243 #if !defined(HAS_VPRINTF)
5246 vprintf(char *pat, char *args)
5248 _doprnt(pat, args, stdout);
5249 return 0; /* wrong, but perl doesn't use the return
5254 vfprintf(FILE *fd, char *pat, char *args)
5256 _doprnt(pat, args, fd);
5257 return 0; /* wrong, but perl doesn't use the return
5263 /* print a failure format string message to stderr and fail exit the process
5264 using only libc without depending on any perl data structures being
5269 Perl_noperl_die(const char* pat, ...)
5272 PERL_ARGS_ASSERT_NOPERL_DIE;
5273 va_start(arglist, pat);
5274 vfprintf(stderr, pat, arglist);
5280 * ex: set ts=8 sts=4 sw=4 et: