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.
852 PERL_UNUSED_VAR(items);
855 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
859 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
860 XS(XS_PerlIO__Layer__find)
865 Perl_croak(aTHX_ "Usage class->find(name[,load])");
868 const char * const name = SvPV_const(ST(1), len);
869 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
870 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
872 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
879 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
881 if (!PL_known_layers)
882 PL_known_layers = PerlIO_list_alloc(aTHX);
883 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
884 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
888 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
891 const char *s = names;
893 while (isSPACE(*s) || *s == ':')
898 const char *as = NULL;
900 if (!isIDFIRST(*s)) {
902 * Message is consistent with how attribute lists are
903 * passed. Even though this means "foo : : bar" is
904 * seen as an invalid separator character.
906 const char q = ((*s == '\'') ? '"' : '\'');
907 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
908 "Invalid separator character %c%c%c in PerlIO layer specification %s",
910 SETERRNO(EINVAL, LIB_INVARG);
915 } while (isWORDCHAR(*e));
931 * It's a nul terminated string, not allowed
932 * to \ the terminating null. Anything other
933 * character is passed over.
943 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
944 "Argument list not closed for PerlIO layer \"%.*s\"",
956 PerlIO_funcs * const layer =
957 PerlIO_find_layer(aTHX_ s, llen, 1);
961 arg = newSVpvn(as, alen);
962 PerlIO_list_push(aTHX_ av, layer,
963 (arg) ? arg : &PL_sv_undef);
967 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
980 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
982 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
983 #ifdef PERLIO_USING_CRLF
986 if (PerlIO_stdio.Set_ptrcnt)
989 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
990 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
994 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
996 return av->array[n].arg;
1000 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1002 if (n >= 0 && n < av->cur) {
1003 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1004 av->array[n].funcs->name) );
1005 return av->array[n].funcs;
1008 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1013 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1015 PERL_UNUSED_ARG(mode);
1016 PERL_UNUSED_ARG(arg);
1017 PERL_UNUSED_ARG(tab);
1018 if (PerlIOValid(f)) {
1020 PerlIO_pop(aTHX_ f);
1026 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1027 sizeof(PerlIO_funcs),
1030 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1050 NULL, /* get_base */
1051 NULL, /* get_bufsiz */
1054 NULL, /* set_ptrcnt */
1058 PerlIO_default_layers(pTHX)
1060 if (!PL_def_layerlist) {
1061 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1062 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1063 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1064 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1068 osLayer = &PerlIO_win32;
1071 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1072 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1077 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1078 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1081 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1084 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1087 if (PL_def_layerlist->cur < 2) {
1088 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1090 return PL_def_layerlist;
1094 Perl_boot_core_PerlIO(pTHX)
1096 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1097 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1100 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1101 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1105 PerlIO_default_layer(pTHX_ I32 n)
1107 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1110 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1113 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1114 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1117 PerlIO_stdstreams(pTHX)
1120 PerlIO_init_table(aTHX);
1121 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1122 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1123 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1128 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1131 if (tab->fsize != sizeof(PerlIO_funcs)) {
1133 "%s (%"UVuf") does not match %s (%"UVuf")",
1134 "PerlIO layer function table size", (UV)tab->fsize,
1135 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1139 if (tab->size < sizeof(PerlIOl)) {
1141 "%s (%"UVuf") smaller than %s (%"UVuf")",
1142 "PerlIO layer instance size", (UV)tab->size,
1143 "size expected by this perl", (UV)sizeof(PerlIOl) );
1145 /* Real layer with a data area */
1148 Newxz(temp, tab->size, char);
1152 l->tab = (PerlIO_funcs*) tab;
1153 l->head = ((PerlIOl*)f)->head;
1155 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1156 (void*)f, tab->name,
1157 (mode) ? mode : "(Null)", (void*)arg) );
1158 if (*l->tab->Pushed &&
1160 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1161 PerlIO_pop(aTHX_ f);
1170 /* Pseudo-layer where push does its own stack adjust */
1171 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1172 (mode) ? mode : "(Null)", (void*)arg) );
1174 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1182 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1183 IV n, const char *mode, int fd, int imode, int perm,
1184 PerlIO *old, int narg, SV **args)
1186 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1187 if (tab && tab->Open) {
1188 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1189 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1195 SETERRNO(EINVAL, LIB_INVARG);
1200 PerlIOBase_binmode(pTHX_ PerlIO *f)
1202 if (PerlIOValid(f)) {
1203 /* Is layer suitable for raw stream ? */
1204 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1205 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1206 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1209 /* Not suitable - pop it */
1210 PerlIO_pop(aTHX_ f);
1218 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1220 PERL_UNUSED_ARG(mode);
1221 PERL_UNUSED_ARG(arg);
1222 PERL_UNUSED_ARG(tab);
1224 if (PerlIOValid(f)) {
1229 * Strip all layers that are not suitable for a raw stream
1232 while (t && (l = *t)) {
1233 if (l->tab && l->tab->Binmode) {
1234 /* Has a handler - normal case */
1235 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1237 /* Layer still there - move down a layer */
1246 /* No handler - pop it */
1247 PerlIO_pop(aTHX_ t);
1250 if (PerlIOValid(f)) {
1251 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1252 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1260 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1261 PerlIO_list_t *layers, IV n, IV max)
1265 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1267 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1278 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1282 save_scalar(PL_errgv);
1284 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1285 code = PerlIO_parse_layers(aTHX_ layers, names);
1287 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1289 PerlIO_list_free(aTHX_ layers);
1296 /*--------------------------------------------------------------------------------------*/
1298 * Given the abstraction above the public API functions
1302 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1304 PERL_UNUSED_ARG(iotype);
1305 PERL_UNUSED_ARG(mode);
1308 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1309 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1310 PerlIOBase(f)->tab->name : "(Null)",
1311 iotype, mode, (names) ? names : "(Null)") );
1314 /* Do not flush etc. if (e.g.) switching encodings.
1315 if a pushed layer knows it needs to flush lower layers
1316 (for example :unix which is never going to call them)
1317 it can do the flush when it is pushed.
1319 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1322 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1323 #ifdef PERLIO_USING_CRLF
1324 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1325 O_BINARY so we can look for it in mode.
1327 if (!(mode & O_BINARY)) {
1329 /* FIXME?: Looking down the layer stack seems wrong,
1330 but is a way of reaching past (say) an encoding layer
1331 to flip CRLF-ness of the layer(s) below
1334 /* Perhaps we should turn on bottom-most aware layer
1335 e.g. Ilya's idea that UNIX TTY could serve
1337 if (PerlIOBase(f)->tab &&
1338 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1340 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1341 /* Not in text mode - flush any pending stuff and flip it */
1343 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1345 /* Only need to turn it on in one layer so we are done */
1350 /* Not finding a CRLF aware layer presumably means we are binary
1351 which is not what was requested - so we failed
1352 We _could_ push :crlf layer but so could caller
1357 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1358 So code that used to be here is now in PerlIORaw_pushed().
1360 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1365 PerlIO__close(pTHX_ PerlIO *f)
1367 if (PerlIOValid(f)) {
1368 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1369 if (tab && tab->Close)
1370 return (*tab->Close)(aTHX_ f);
1372 return PerlIOBase_close(aTHX_ f);
1375 SETERRNO(EBADF, SS_IVCHAN);
1381 Perl_PerlIO_close(pTHX_ PerlIO *f)
1383 const int code = PerlIO__close(aTHX_ f);
1384 while (PerlIOValid(f)) {
1385 PerlIO_pop(aTHX_ f);
1386 if (PerlIO_lockcnt(f))
1387 /* we're in use; the 'pop' deferred freeing the structure */
1394 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1396 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1400 static PerlIO_funcs *
1401 PerlIO_layer_from_ref(pTHX_ SV *sv)
1404 * For any scalar type load the handler which is bundled with perl
1406 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1407 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1408 /* This isn't supposed to happen, since PerlIO::scalar is core,
1409 * but could happen anyway in smaller installs or with PAR */
1411 /* diag_listed_as: Unknown PerlIO layer "%s" */
1412 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1417 * For other types allow if layer is known but don't try and load it
1419 switch (SvTYPE(sv)) {
1421 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1423 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1425 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1427 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1434 PerlIO_resolve_layers(pTHX_ const char *layers,
1435 const char *mode, int narg, SV **args)
1437 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1440 PerlIO_stdstreams(aTHX);
1442 SV * const arg = *args;
1444 * If it is a reference but not an object see if we have a handler
1447 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1448 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1450 def = PerlIO_list_alloc(aTHX);
1451 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1455 * Don't fail if handler cannot be found :via(...) etc. may do
1456 * something sensible else we will just stringfy and open
1461 if (!layers || !*layers)
1462 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1463 if (layers && *layers) {
1466 av = PerlIO_clone_list(aTHX_ def, NULL);
1471 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1475 PerlIO_list_free(aTHX_ av);
1487 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1488 int imode, int perm, PerlIO *f, int narg, SV **args)
1490 if (!f && narg == 1 && *args == &PL_sv_undef) {
1491 if ((f = PerlIO_tmpfile())) {
1492 if (!layers || !*layers)
1493 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1494 if (layers && *layers)
1495 PerlIO_apply_layers(aTHX_ f, mode, layers);
1499 PerlIO_list_t *layera;
1501 PerlIO_funcs *tab = NULL;
1502 if (PerlIOValid(f)) {
1504 * This is "reopen" - it is not tested as perl does not use it
1508 layera = PerlIO_list_alloc(aTHX);
1511 if (l->tab && l->tab->Getarg)
1512 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1513 PerlIO_list_push(aTHX_ layera, l->tab,
1514 (arg) ? arg : &PL_sv_undef);
1516 l = *PerlIONext(&l);
1520 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1526 * Start at "top" of layer stack
1528 n = layera->cur - 1;
1530 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1539 * Found that layer 'n' can do opens - call it
1541 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1542 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1544 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1545 tab->name, layers ? layers : "(Null)", mode, fd,
1546 imode, perm, (void*)f, narg, (void*)args) );
1548 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1551 SETERRNO(EINVAL, LIB_INVARG);
1555 if (n + 1 < layera->cur) {
1557 * More layers above the one that we used to open -
1560 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1561 /* If pushing layers fails close the file */
1568 PerlIO_list_free(aTHX_ layera);
1575 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1577 PERL_ARGS_ASSERT_PERLIO_READ;
1579 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1583 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1585 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1587 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1591 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1593 PERL_ARGS_ASSERT_PERLIO_WRITE;
1595 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1599 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1601 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1605 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1607 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1611 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1615 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1617 if (tab && tab->Flush)
1618 return (*tab->Flush) (aTHX_ f);
1620 return 0; /* If no Flush defined, silently succeed. */
1623 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1624 SETERRNO(EBADF, SS_IVCHAN);
1630 * Is it good API design to do flush-all on NULL, a potentially
1631 * erroneous input? Maybe some magical value (PerlIO*
1632 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1633 * things on fflush(NULL), but should we be bound by their design
1636 PerlIOl **table = &PL_perlio;
1639 while ((ff = *table)) {
1641 table = (PerlIOl **) (ff++);
1642 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1643 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1653 PerlIOBase_flush_linebuf(pTHX)
1655 PerlIOl **table = &PL_perlio;
1657 while ((f = *table)) {
1659 table = (PerlIOl **) (f++);
1660 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1662 && (PerlIOBase(&(f->next))->
1663 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1664 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1665 PerlIO_flush(&(f->next));
1672 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1674 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1678 PerlIO_isutf8(PerlIO *f)
1681 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1683 SETERRNO(EBADF, SS_IVCHAN);
1689 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1691 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1695 Perl_PerlIO_error(pTHX_ PerlIO *f)
1697 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1701 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1703 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1707 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1709 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1713 PerlIO_has_base(PerlIO *f)
1715 if (PerlIOValid(f)) {
1716 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1719 return (tab->Get_base != NULL);
1726 PerlIO_fast_gets(PerlIO *f)
1728 if (PerlIOValid(f)) {
1729 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1730 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1733 return (tab->Set_ptrcnt != NULL);
1741 PerlIO_has_cntptr(PerlIO *f)
1743 if (PerlIOValid(f)) {
1744 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1747 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1754 PerlIO_canset_cnt(PerlIO *f)
1756 if (PerlIOValid(f)) {
1757 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1760 return (tab->Set_ptrcnt != NULL);
1767 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1769 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1773 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1775 /* Note that Get_bufsiz returns a Size_t */
1776 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1780 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1782 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1786 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1788 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1792 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1794 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1798 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1800 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1804 /*--------------------------------------------------------------------------------------*/
1806 * utf8 and raw dummy layers
1810 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1812 PERL_UNUSED_CONTEXT;
1813 PERL_UNUSED_ARG(mode);
1814 PERL_UNUSED_ARG(arg);
1815 if (PerlIOValid(f)) {
1816 if (tab && tab->kind & PERLIO_K_UTF8)
1817 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1819 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1825 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1826 sizeof(PerlIO_funcs),
1829 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1849 NULL, /* get_base */
1850 NULL, /* get_bufsiz */
1853 NULL, /* set_ptrcnt */
1856 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1857 sizeof(PerlIO_funcs),
1860 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1880 NULL, /* get_base */
1881 NULL, /* get_bufsiz */
1884 NULL, /* set_ptrcnt */
1887 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1888 sizeof(PerlIO_funcs),
1911 NULL, /* get_base */
1912 NULL, /* get_bufsiz */
1915 NULL, /* set_ptrcnt */
1917 /*--------------------------------------------------------------------------------------*/
1918 /*--------------------------------------------------------------------------------------*/
1920 * "Methods" of the "base class"
1924 PerlIOBase_fileno(pTHX_ PerlIO *f)
1926 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1930 PerlIO_modestr(PerlIO * f, char *buf)
1933 if (PerlIOValid(f)) {
1934 const IV flags = PerlIOBase(f)->flags;
1935 if (flags & PERLIO_F_APPEND) {
1937 if (flags & PERLIO_F_CANREAD) {
1941 else if (flags & PERLIO_F_CANREAD) {
1943 if (flags & PERLIO_F_CANWRITE)
1946 else if (flags & PERLIO_F_CANWRITE) {
1948 if (flags & PERLIO_F_CANREAD) {
1952 #ifdef PERLIO_USING_CRLF
1953 if (!(flags & PERLIO_F_CRLF))
1963 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1965 PerlIOl * const l = PerlIOBase(f);
1966 PERL_UNUSED_CONTEXT;
1967 PERL_UNUSED_ARG(arg);
1969 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1970 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1971 if (tab && tab->Set_ptrcnt != NULL)
1972 l->flags |= PERLIO_F_FASTGETS;
1974 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1978 l->flags |= PERLIO_F_CANREAD;
1981 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1984 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1987 SETERRNO(EINVAL, LIB_INVARG);
1992 /* The mode variable contains one positional parameter followed by
1993 * optional keyword parameters. The positional parameters must be
1994 * passed as lowercase characters. The keyword parameters can be
1995 * passed in mixed case. They must be separated by commas. Only one
1996 * instance of a keyword can be specified. */
2002 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2006 l->flags &= ~PERLIO_F_CRLF;
2010 l->flags |= PERLIO_F_CRLF;
2024 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2027 l->flags &= ~PERLIO_F_CRLF;
2030 l->flags |= PERLIO_F_CRLF;
2033 SETERRNO(EINVAL, LIB_INVARG);
2041 l->flags |= l->next->flags &
2042 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2048 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2049 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2050 l->flags, PerlIO_modestr(f, temp));
2057 PerlIOBase_popped(pTHX_ PerlIO *f)
2059 PERL_UNUSED_CONTEXT;
2065 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2068 * Save the position as current head considers it
2070 const Off_t old = PerlIO_tell(f);
2071 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2072 PerlIOSelf(f, PerlIOBuf)->posn = old;
2073 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2077 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2079 STDCHAR *buf = (STDCHAR *) vbuf;
2081 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2082 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2083 SETERRNO(EBADF, SS_IVCHAN);
2084 PerlIO_save_errno(f);
2090 SSize_t avail = PerlIO_get_cnt(f);
2093 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2095 STDCHAR *ptr = PerlIO_get_ptr(f);
2096 Copy(ptr, buf, take, STDCHAR);
2097 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2100 if (avail == 0) /* set_ptrcnt could have reset avail */
2103 if (count > 0 && avail <= 0) {
2104 if (PerlIO_fill(f) != 0)
2109 return (buf - (STDCHAR *) vbuf);
2115 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2117 PERL_UNUSED_CONTEXT;
2123 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2125 PERL_UNUSED_CONTEXT;
2131 PerlIOBase_close(pTHX_ PerlIO *f)
2134 if (PerlIOValid(f)) {
2135 PerlIO *n = PerlIONext(f);
2136 code = PerlIO_flush(f);
2137 PerlIOBase(f)->flags &=
2138 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2139 while (PerlIOValid(n)) {
2140 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2141 if (tab && tab->Close) {
2142 if ((*tab->Close)(aTHX_ n) != 0)
2147 PerlIOBase(n)->flags &=
2148 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2154 SETERRNO(EBADF, SS_IVCHAN);
2160 PerlIOBase_eof(pTHX_ PerlIO *f)
2162 PERL_UNUSED_CONTEXT;
2163 if (PerlIOValid(f)) {
2164 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2170 PerlIOBase_error(pTHX_ PerlIO *f)
2172 PERL_UNUSED_CONTEXT;
2173 if (PerlIOValid(f)) {
2174 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2180 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2182 if (PerlIOValid(f)) {
2183 PerlIO * const n = PerlIONext(f);
2184 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2191 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2193 PERL_UNUSED_CONTEXT;
2194 if (PerlIOValid(f)) {
2195 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2200 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2206 arg = sv_dup(arg, param);
2207 SvREFCNT_inc_simple_void_NN(arg);
2211 return newSVsv(arg);
2214 PERL_UNUSED_ARG(param);
2215 return newSVsv(arg);
2220 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2222 PerlIO * const nexto = PerlIONext(o);
2223 if (PerlIOValid(nexto)) {
2224 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2225 if (tab && tab->Dup)
2226 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2228 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2231 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2235 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2237 (void*)f, (void*)o, (void*)param) );
2239 arg = (*self->Getarg)(aTHX_ o, param, flags);
2240 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2241 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2242 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2248 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2250 /* Must be called with PL_perlio_mutex locked. */
2252 S_more_refcounted_fds(pTHX_ const int new_fd)
2253 PERL_TSA_REQUIRES(PL_perlio_mutex)
2256 const int old_max = PL_perlio_fd_refcnt_size;
2257 const int new_max = 16 + (new_fd & ~15);
2260 #ifndef PERL_IMPLICIT_SYS
2261 PERL_UNUSED_CONTEXT;
2264 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2265 old_max, new_fd, new_max) );
2267 if (new_fd < old_max) {
2271 assert (new_max > new_fd);
2273 /* Use plain realloc() since we need this memory to be really
2274 * global and visible to all the interpreters and/or threads. */
2275 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2279 MUTEX_UNLOCK(&PL_perlio_mutex);
2284 PL_perlio_fd_refcnt_size = new_max;
2285 PL_perlio_fd_refcnt = new_array;
2287 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2288 (void*)(new_array + old_max),
2289 new_max - old_max) );
2291 Zero(new_array + old_max, new_max - old_max, int);
2298 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2299 PERL_UNUSED_CONTEXT;
2303 PerlIOUnix_refcnt_inc(int fd)
2310 MUTEX_LOCK(&PL_perlio_mutex);
2312 if (fd >= PL_perlio_fd_refcnt_size)
2313 S_more_refcounted_fds(aTHX_ fd);
2315 PL_perlio_fd_refcnt[fd]++;
2316 if (PL_perlio_fd_refcnt[fd] <= 0) {
2317 /* diag_listed_as: refcnt_inc: fd %d%s */
2318 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2319 fd, PL_perlio_fd_refcnt[fd]);
2321 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2322 fd, PL_perlio_fd_refcnt[fd]) );
2325 MUTEX_UNLOCK(&PL_perlio_mutex);
2328 /* diag_listed_as: refcnt_inc: fd %d%s */
2329 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2334 PerlIOUnix_refcnt_dec(int fd)
2344 MUTEX_LOCK(&PL_perlio_mutex);
2346 if (fd >= PL_perlio_fd_refcnt_size) {
2347 /* diag_listed_as: refcnt_dec: fd %d%s */
2348 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2349 fd, PL_perlio_fd_refcnt_size);
2351 if (PL_perlio_fd_refcnt[fd] <= 0) {
2352 /* diag_listed_as: refcnt_dec: fd %d%s */
2353 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2354 fd, PL_perlio_fd_refcnt[fd]);
2356 cnt = --PL_perlio_fd_refcnt[fd];
2357 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2359 MUTEX_UNLOCK(&PL_perlio_mutex);
2362 /* diag_listed_as: refcnt_dec: fd %d%s */
2363 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2369 PerlIOUnix_refcnt(int fd)
2376 MUTEX_LOCK(&PL_perlio_mutex);
2378 if (fd >= PL_perlio_fd_refcnt_size) {
2379 /* diag_listed_as: refcnt: fd %d%s */
2380 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2381 fd, PL_perlio_fd_refcnt_size);
2383 if (PL_perlio_fd_refcnt[fd] <= 0) {
2384 /* diag_listed_as: refcnt: fd %d%s */
2385 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2386 fd, PL_perlio_fd_refcnt[fd]);
2388 cnt = PL_perlio_fd_refcnt[fd];
2390 MUTEX_UNLOCK(&PL_perlio_mutex);
2393 /* diag_listed_as: refcnt: fd %d%s */
2394 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2400 PerlIO_cleanup(pTHX)
2404 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2406 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2409 /* Raise STDIN..STDERR refcount so we don't close them */
2410 for (i=0; i < 3; i++)
2411 PerlIOUnix_refcnt_inc(i);
2412 PerlIO_cleantable(aTHX_ &PL_perlio);
2413 /* Restore STDIN..STDERR refcount */
2414 for (i=0; i < 3; i++)
2415 PerlIOUnix_refcnt_dec(i);
2417 if (PL_known_layers) {
2418 PerlIO_list_free(aTHX_ PL_known_layers);
2419 PL_known_layers = NULL;
2421 if (PL_def_layerlist) {
2422 PerlIO_list_free(aTHX_ PL_def_layerlist);
2423 PL_def_layerlist = NULL;
2427 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2431 /* XXX we can't rely on an interpreter being present at this late stage,
2432 XXX so we can't use a function like PerlLIO_write that relies on one
2433 being present (at least in win32) :-(.
2438 /* By now all filehandles should have been closed, so any
2439 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2441 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2442 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2443 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2445 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2446 if (PL_perlio_fd_refcnt[i]) {
2448 my_snprintf(buf, sizeof(buf),
2449 "PerlIO_teardown: fd %d refcnt=%d\n",
2450 i, PL_perlio_fd_refcnt[i]);
2451 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2457 /* Not bothering with PL_perlio_mutex since by now
2458 * all the interpreters are gone. */
2459 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2460 && PL_perlio_fd_refcnt) {
2461 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2462 PL_perlio_fd_refcnt = NULL;
2463 PL_perlio_fd_refcnt_size = 0;
2467 /*--------------------------------------------------------------------------------------*/
2469 * Bottom-most level for UNIX-like case
2473 struct _PerlIO base; /* The generic part */
2474 int fd; /* UNIX like file descriptor */
2475 int oflags; /* open/fcntl flags */
2479 S_lockcnt_dec(pTHX_ const void* f)
2481 #ifndef PERL_IMPLICIT_SYS
2482 PERL_UNUSED_CONTEXT;
2484 PerlIO_lockcnt((PerlIO*)f)--;
2488 /* call the signal handler, and if that handler happens to clear
2489 * this handle, free what we can and return true */
2492 S_perlio_async_run(pTHX_ PerlIO* f) {
2494 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2495 PerlIO_lockcnt(f)++;
2497 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2501 /* we've just run some perl-level code that could have done
2502 * anything, including closing the file or clearing this layer.
2503 * If so, free any lower layers that have already been
2504 * cleared, then return an error. */
2505 while (PerlIOValid(f) &&
2506 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2508 const PerlIOl *l = *f;
2517 PerlIOUnix_oflags(const char *mode)
2520 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2525 if (*++mode == '+') {
2532 oflags = O_CREAT | O_TRUNC;
2533 if (*++mode == '+') {
2542 oflags = O_CREAT | O_APPEND;
2543 if (*++mode == '+') {
2552 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2554 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2555 * of them in, and then bit-and-masking the other them away, won't
2556 * have much of an effect. */
2559 #if O_TEXT != O_BINARY
2566 #if O_TEXT != O_BINARY
2568 oflags &= ~O_BINARY;
2574 /* bit-or:ing with zero O_BINARY would be useless. */
2576 * If neither "t" nor "b" was specified, open the file
2579 * Note that if something else than the zero byte was seen
2580 * here (e.g. bogus mode "rx"), just few lines later we will
2581 * set the errno and invalidate the flags.
2587 if (*mode || oflags == -1) {
2588 SETERRNO(EINVAL, LIB_INVARG);
2595 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2597 PERL_UNUSED_CONTEXT;
2598 return PerlIOSelf(f, PerlIOUnix)->fd;
2602 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2604 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2607 if (PerlLIO_fstat(fd, &st) == 0) {
2608 if (!S_ISREG(st.st_mode)) {
2609 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2610 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2613 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2619 PerlIOUnix_refcnt_inc(fd);
2620 PERL_UNUSED_CONTEXT;
2624 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2626 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2627 if (*PerlIONext(f)) {
2628 /* We never call down so do any pending stuff now */
2629 PerlIO_flush(PerlIONext(f));
2631 * XXX could (or should) we retrieve the oflags from the open file
2632 * handle rather than believing the "mode" we are passed in? XXX
2633 * Should the value on NULL mode be 0 or -1?
2635 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2636 mode ? PerlIOUnix_oflags(mode) : -1);
2638 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2644 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2646 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2648 PERL_UNUSED_CONTEXT;
2649 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2651 SETERRNO(ESPIPE, LIB_INVARG);
2653 SETERRNO(EINVAL, LIB_INVARG);
2657 new_loc = PerlLIO_lseek(fd, offset, whence);
2658 if (new_loc == (Off_t) - 1)
2660 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2665 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2666 IV n, const char *mode, int fd, int imode,
2667 int perm, PerlIO *f, int narg, SV **args)
2669 if (PerlIOValid(f)) {
2670 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2671 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2674 if (*mode == IoTYPE_NUMERIC)
2677 imode = PerlIOUnix_oflags(mode);
2679 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2686 const char *path = SvPV_const(*args, len);
2687 if (!IS_SAFE_PATHNAME(path, len, "open"))
2689 fd = PerlLIO_open3(path, imode, perm);
2693 if (*mode == IoTYPE_IMPLICIT)
2696 f = PerlIO_allocate(aTHX);
2698 if (!PerlIOValid(f)) {
2699 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2704 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2705 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2706 if (*mode == IoTYPE_APPEND)
2707 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2714 * FIXME: pop layers ???
2722 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2724 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2726 if (flags & PERLIO_DUP_FD) {
2727 fd = PerlLIO_dup(fd);
2730 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2732 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2733 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2743 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2746 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2748 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2749 #ifdef PERLIO_STD_SPECIAL
2751 return PERLIO_STD_IN(fd, vbuf, count);
2753 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2754 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2758 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2759 if (len >= 0 || errno != EINTR) {
2761 if (errno != EAGAIN) {
2762 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2763 PerlIO_save_errno(f);
2766 else if (len == 0 && count != 0) {
2767 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2773 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2776 NOT_REACHED; /*NOTREACHED*/
2780 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2783 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2785 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2786 #ifdef PERLIO_STD_SPECIAL
2787 if (fd == 1 || fd == 2)
2788 return PERLIO_STD_OUT(fd, vbuf, count);
2791 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2792 if (len >= 0 || errno != EINTR) {
2794 if (errno != EAGAIN) {
2795 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2796 PerlIO_save_errno(f);
2802 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2805 NOT_REACHED; /*NOTREACHED*/
2809 PerlIOUnix_tell(pTHX_ PerlIO *f)
2811 PERL_UNUSED_CONTEXT;
2813 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2818 PerlIOUnix_close(pTHX_ PerlIO *f)
2820 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2822 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2823 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2824 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2829 SETERRNO(EBADF,SS_IVCHAN);
2832 while (PerlLIO_close(fd) != 0) {
2833 if (errno != EINTR) {
2838 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2842 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2847 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2848 sizeof(PerlIO_funcs),
2855 PerlIOBase_binmode, /* binmode */
2865 PerlIOBase_noop_ok, /* flush */
2866 PerlIOBase_noop_fail, /* fill */
2869 PerlIOBase_clearerr,
2870 PerlIOBase_setlinebuf,
2871 NULL, /* get_base */
2872 NULL, /* get_bufsiz */
2875 NULL, /* set_ptrcnt */
2878 /*--------------------------------------------------------------------------------------*/
2883 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2884 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2885 broken by the last second glibc 2.3 fix
2887 #define STDIO_BUFFER_WRITABLE
2892 struct _PerlIO base;
2893 FILE *stdio; /* The stream */
2897 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2899 PERL_UNUSED_CONTEXT;
2901 if (PerlIOValid(f)) {
2902 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2904 return PerlSIO_fileno(s);
2911 PerlIOStdio_mode(const char *mode, char *tmode)
2913 char * const ret = tmode;
2919 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2927 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2930 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2931 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2932 if (toptab == tab) {
2933 /* Top is already stdio - pop self (duplicate) and use original */
2934 PerlIO_pop(aTHX_ f);
2937 const int fd = PerlIO_fileno(n);
2940 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2941 mode = PerlIOStdio_mode(mode, tmode)))) {
2942 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2943 /* We never call down so do any pending stuff now */
2944 PerlIO_flush(PerlIONext(f));
2945 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2952 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2957 PerlIO_importFILE(FILE *stdio, const char *mode)
2963 char filename[FILENAME_MAX];
2968 int fd0 = fileno(stdio);
2971 rc = fldata(stdio,filename,&fileinfo);
2975 if(fileinfo.__dsorgHFS){
2978 /*This MVS dataset , OK!*/
2983 if (!mode || !*mode) {
2984 /* We need to probe to see how we can open the stream
2985 so start with read/write and then try write and read
2986 we dup() so that we can fclose without loosing the fd.
2988 Note that the errno value set by a failing fdopen
2989 varies between stdio implementations.
2991 const int fd = PerlLIO_dup(fd0);
2996 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2998 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3001 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3004 /* Don't seem to be able to open */
3010 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3011 s = PerlIOSelf(f, PerlIOStdio);
3014 fd0 = fileno(stdio);
3016 PerlIOUnix_refcnt_inc(fd0);
3019 rc = fldata(stdio,filename,&fileinfo);
3021 PerlIOUnix_refcnt_inc(fd0);
3023 if(fileinfo.__dsorgHFS){
3024 PerlIOUnix_refcnt_inc(fd0);
3026 /*This MVS dataset , OK!*/
3029 PerlIOUnix_refcnt_inc(fileno(stdio));
3037 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3038 IV n, const char *mode, int fd, int imode,
3039 int perm, PerlIO *f, int narg, SV **args)
3042 if (PerlIOValid(f)) {
3044 const char * const path = SvPV_const(*args, len);
3045 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3047 if (!IS_SAFE_PATHNAME(path, len, "open"))
3049 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3050 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3055 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3061 const char * const path = SvPV_const(*args, len);
3062 if (!IS_SAFE_PATHNAME(path, len, "open"))
3064 if (*mode == IoTYPE_NUMERIC) {
3066 fd = PerlLIO_open3(path, imode, perm);
3070 bool appended = FALSE;
3072 /* Cygwin wants its 'b' early. */
3074 mode = PerlIOStdio_mode(mode, tmode);
3076 stdio = PerlSIO_fopen(path, mode);
3079 f = PerlIO_allocate(aTHX);
3082 mode = PerlIOStdio_mode(mode, tmode);
3083 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3085 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3086 PerlIOUnix_refcnt_inc(fileno(stdio));
3088 PerlSIO_fclose(stdio);
3100 if (*mode == IoTYPE_IMPLICIT) {
3107 stdio = PerlSIO_stdin;
3110 stdio = PerlSIO_stdout;
3113 stdio = PerlSIO_stderr;
3118 stdio = PerlSIO_fdopen(fd, mode =
3119 PerlIOStdio_mode(mode, tmode));
3123 f = PerlIO_allocate(aTHX);
3125 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3126 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3127 PerlIOUnix_refcnt_inc(fileno(stdio));
3138 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3140 /* This assumes no layers underneath - which is what
3141 happens, but is not how I remember it. NI-S 2001/10/16
3143 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3144 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3145 const int fd = fileno(stdio);
3147 if (flags & PERLIO_DUP_FD) {
3148 const int dfd = PerlLIO_dup(fileno(stdio));
3150 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3155 /* FIXME: To avoid messy error recovery if dup fails
3156 re-use the existing stdio as though flag was not set
3160 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3162 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3164 PerlIOUnix_refcnt_inc(fileno(stdio));
3171 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3173 PERL_UNUSED_CONTEXT;
3175 /* XXX this could use PerlIO_canset_fileno() and
3176 * PerlIO_set_fileno() support from Configure
3178 # if defined(HAS_FDCLOSE)
3179 return fdclose(f, NULL) == 0 ? 1 : 0;
3180 # elif defined(__UCLIBC__)
3181 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3184 # elif defined(__GLIBC__)
3185 /* There may be a better way for GLIBC:
3186 - libio.h defines a flag to not close() on cleanup
3190 # elif defined(__sun)
3193 # elif defined(__hpux)
3197 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3198 your platform does not have special entry try this one.
3199 [For OSF only have confirmation for Tru64 (alpha)
3200 but assume other OSFs will be similar.]
3202 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3205 # elif defined(__FreeBSD__)
3206 /* There may be a better way on FreeBSD:
3207 - we could insert a dummy func in the _close function entry
3208 f->_close = (int (*)(void *)) dummy_close;
3212 # elif defined(__OpenBSD__)
3213 /* There may be a better way on OpenBSD:
3214 - we could insert a dummy func in the _close function entry
3215 f->_close = (int (*)(void *)) dummy_close;
3219 # elif defined(__EMX__)
3220 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3223 # elif defined(__CYGWIN__)
3224 /* There may be a better way on CYGWIN:
3225 - we could insert a dummy func in the _close function entry
3226 f->_close = (int (*)(void *)) dummy_close;
3230 # elif defined(WIN32)
3231 # if defined(UNDER_CE)
3232 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3241 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3242 (which isn't thread safe) instead
3244 # error "Don't know how to set FILE.fileno on your platform"
3252 PerlIOStdio_close(pTHX_ PerlIO *f)
3254 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3260 const int fd = fileno(stdio);
3268 #ifdef SOCKS5_VERSION_NAME
3269 /* Socks lib overrides close() but stdio isn't linked to
3270 that library (though we are) - so we must call close()
3271 on sockets on stdio's behalf.
3274 Sock_size_t optlen = sizeof(int);
3275 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3278 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3279 that a subsequent fileno() on it returns -1. Don't want to croak()
3280 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3281 trying to close an already closed handle which somehow it still has
3282 a reference to. (via.xs, I'm looking at you). */
3283 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3284 /* File descriptor still in use */
3288 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3289 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3291 if (stdio == stdout || stdio == stderr)
3292 return PerlIO_flush(f);
3295 MUTEX_LOCK(&PL_perlio_mutex);
3296 /* Right. We need a mutex here because for a brief while we
3297 will have the situation that fd is actually closed. Hence if
3298 a second thread were to get into this block, its dup() would
3299 likely return our fd as its dupfd. (after all, it is closed)
3300 Then if we get to the dup2() first, we blat the fd back
3301 (messing up its temporary as a side effect) only for it to
3302 then close its dupfd (== our fd) in its close(dupfd) */
3304 /* There is, of course, a race condition, that any other thread
3305 trying to input/output/whatever on this fd will be stuffed
3306 for the duration of this little manoeuvrer. Perhaps we
3307 should hold an IO mutex for the duration of every IO
3308 operation if we know that invalidate doesn't work on this
3309 platform, but that would suck, and could kill performance.
3311 Except that correctness trumps speed.
3312 Advice from klortho #11912. */
3315 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3316 Use Sarathy's trick from maint-5.6 to invalidate the
3317 fileno slot of the FILE *
3319 result = PerlIO_flush(f);
3321 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3323 dupfd = PerlLIO_dup(fd);
3326 /* Oh cXap. This isn't going to go well. Not sure if we can
3327 recover from here, or if closing this particular FILE *
3328 is a good idea now. */
3333 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3335 result = PerlSIO_fclose(stdio);
3336 /* We treat error from stdio as success if we invalidated
3337 errno may NOT be expected EBADF
3339 if (invalidate && result != 0) {
3343 #ifdef SOCKS5_VERSION_NAME
3344 /* in SOCKS' case, let close() determine return value */
3348 PerlLIO_dup2(dupfd,fd);
3349 PerlLIO_close(dupfd);
3352 MUTEX_UNLOCK(&PL_perlio_mutex);
3359 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3363 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3365 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3368 STDCHAR *buf = (STDCHAR *) vbuf;
3370 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3371 * stdio does not do that for fread()
3373 const int ch = PerlSIO_fgetc(s);
3380 got = PerlSIO_fread(vbuf, 1, count, s);
3381 if (got == 0 && PerlSIO_ferror(s))
3383 if (got >= 0 || errno != EINTR)
3385 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3387 SETERRNO(0,0); /* just in case */
3390 /* Under some circumstances IRIX stdio fgetc() and fread()
3391 * set the errno to ENOENT, which makes no sense according
3392 * to either IRIX or POSIX. [rt.perl.org #123977] */
3393 if (errno == ENOENT) SETERRNO(0,0);
3399 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3402 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3404 #ifdef STDIO_BUFFER_WRITABLE
3405 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3406 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3407 STDCHAR *base = PerlIO_get_base(f);
3408 SSize_t cnt = PerlIO_get_cnt(f);
3409 STDCHAR *ptr = PerlIO_get_ptr(f);
3410 SSize_t avail = ptr - base;
3412 if (avail > count) {
3416 Move(buf-avail,ptr,avail,STDCHAR);
3419 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3420 if (PerlSIO_feof(s) && unread >= 0)
3421 PerlSIO_clearerr(s);
3426 if (PerlIO_has_cntptr(f)) {
3427 /* We can get pointer to buffer but not its base
3428 Do ungetc() but check chars are ending up in the
3431 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3432 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3434 const int ch = *--buf & 0xFF;
3435 if (ungetc(ch,s) != ch) {
3436 /* ungetc did not work */
3439 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3440 /* Did not change pointer as expected */
3441 if (fgetc(s) != EOF) /* get char back again */
3451 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3457 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3460 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3463 got = PerlSIO_fwrite(vbuf, 1, count,
3464 PerlIOSelf(f, PerlIOStdio)->stdio);
3465 if (got >= 0 || errno != EINTR)
3467 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3469 SETERRNO(0,0); /* just in case */
3475 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3477 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3478 PERL_UNUSED_CONTEXT;
3480 return PerlSIO_fseek(stdio, offset, whence);
3484 PerlIOStdio_tell(pTHX_ PerlIO *f)
3486 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3487 PERL_UNUSED_CONTEXT;
3489 return PerlSIO_ftell(stdio);
3493 PerlIOStdio_flush(pTHX_ PerlIO *f)
3495 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3496 PERL_UNUSED_CONTEXT;
3498 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3499 return PerlSIO_fflush(stdio);
3505 * FIXME: This discards ungetc() and pre-read stuff which is not
3506 * right if this is just a "sync" from a layer above Suspect right
3507 * design is to do _this_ but not have layer above flush this
3508 * layer read-to-read
3511 * Not writeable - sync by attempting a seek
3514 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3522 PerlIOStdio_eof(pTHX_ PerlIO *f)
3524 PERL_UNUSED_CONTEXT;
3526 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3530 PerlIOStdio_error(pTHX_ PerlIO *f)
3532 PERL_UNUSED_CONTEXT;
3534 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3538 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3540 PERL_UNUSED_CONTEXT;
3542 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3546 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3548 PERL_UNUSED_CONTEXT;
3550 #ifdef HAS_SETLINEBUF
3551 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3553 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3559 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3561 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3562 return (STDCHAR*)PerlSIO_get_base(stdio);
3566 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3568 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
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 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3582 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3584 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3585 return PerlSIO_get_cnt(stdio);
3589 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3591 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3593 #ifdef STDIO_PTR_LVALUE
3594 /* This is a long-standing infamous mess. The root of the
3595 * problem is that one cannot know the signedness of char, and
3596 * more precisely the signedness of FILE._ptr. The following
3597 * things have been tried, and they have all failed (across
3598 * different compilers (remember that core needs to to build
3599 * also with c++) and compiler options:
3601 * - casting the RHS to (void*) -- works in *some* places
3602 * - casting the LHS to (void*) -- totally unportable
3604 * So let's try silencing the warning at least for gcc. */
3605 GCC_DIAG_IGNORE(-Wpointer-sign);
3606 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3608 #ifdef STDIO_PTR_LVAL_SETS_CNT
3609 assert(PerlSIO_get_cnt(stdio) == (cnt));
3611 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3613 * Setting ptr _does_ change cnt - we are done
3617 #else /* STDIO_PTR_LVALUE */
3619 #endif /* STDIO_PTR_LVALUE */
3622 * Now (or only) set cnt
3624 #ifdef STDIO_CNT_LVALUE
3625 PerlSIO_set_cnt(stdio, cnt);
3626 #else /* STDIO_CNT_LVALUE */
3627 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3628 PerlSIO_set_ptr(stdio,
3629 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3631 #else /* STDIO_PTR_LVAL_SETS_CNT */
3633 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3634 #endif /* STDIO_CNT_LVALUE */
3641 PerlIOStdio_fill(pTHX_ PerlIO *f)
3645 PERL_UNUSED_CONTEXT;
3646 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3648 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3651 * fflush()ing read-only streams can cause trouble on some stdio-s
3653 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3654 if (PerlSIO_fflush(stdio) != 0)
3658 c = PerlSIO_fgetc(stdio);
3661 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3663 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3668 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3670 #ifdef STDIO_BUFFER_WRITABLE
3671 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3672 /* Fake ungetc() to the real buffer in case system's ungetc
3675 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3676 SSize_t cnt = PerlSIO_get_cnt(stdio);
3677 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3678 if (ptr == base+1) {
3679 *--ptr = (STDCHAR) c;
3680 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3681 if (PerlSIO_feof(stdio))
3682 PerlSIO_clearerr(stdio);
3688 if (PerlIO_has_cntptr(f)) {
3690 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3696 /* If buffer snoop scheme above fails fall back to
3699 if (PerlSIO_ungetc(c, stdio) != c)
3707 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3708 sizeof(PerlIO_funcs),
3710 sizeof(PerlIOStdio),
3711 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3715 PerlIOBase_binmode, /* binmode */
3729 PerlIOStdio_clearerr,
3730 PerlIOStdio_setlinebuf,
3732 PerlIOStdio_get_base,
3733 PerlIOStdio_get_bufsiz,
3738 #ifdef USE_STDIO_PTR
3739 PerlIOStdio_get_ptr,
3740 PerlIOStdio_get_cnt,
3741 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3742 PerlIOStdio_set_ptrcnt,
3745 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3750 #endif /* USE_STDIO_PTR */
3753 /* Note that calls to PerlIO_exportFILE() are reversed using
3754 * PerlIO_releaseFILE(), not importFILE. */
3756 PerlIO_exportFILE(PerlIO * f, const char *mode)
3760 if (PerlIOValid(f)) {
3762 int fd = PerlIO_fileno(f);
3767 if (!mode || !*mode) {
3768 mode = PerlIO_modestr(f, buf);
3770 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3774 /* De-link any lower layers so new :stdio sticks */
3776 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3777 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3779 PerlIOUnix_refcnt_inc(fileno(stdio));
3780 /* Link previous lower layers under new one */
3784 /* restore layers list */
3794 PerlIO_findFILE(PerlIO *f)
3799 if (l->tab == &PerlIO_stdio) {
3800 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3803 l = *PerlIONext(&l);
3805 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3806 /* However, we're not really exporting a FILE * to someone else (who
3807 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3808 So we need to undo its reference count increase on the underlying file
3809 descriptor. We have to do this, because if the loop above returns you
3810 the FILE *, then *it* didn't increase any reference count. So there's
3811 only one way to be consistent. */
3812 stdio = PerlIO_exportFILE(f, NULL);
3814 const int fd = fileno(stdio);
3816 PerlIOUnix_refcnt_dec(fd);
3821 /* Use this to reverse PerlIO_exportFILE calls. */
3823 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3827 if (l->tab == &PerlIO_stdio) {
3828 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3829 if (s->stdio == f) { /* not in a loop */
3830 const int fd = fileno(f);
3832 PerlIOUnix_refcnt_dec(fd);
3835 PerlIO_pop(aTHX_ p);
3845 /*--------------------------------------------------------------------------------------*/
3847 * perlio buffer layer
3851 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3853 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3854 const int fd = PerlIO_fileno(f);
3855 if (fd >= 0 && PerlLIO_isatty(fd)) {
3856 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3858 if (*PerlIONext(f)) {
3859 const Off_t posn = PerlIO_tell(PerlIONext(f));
3860 if (posn != (Off_t) - 1) {
3864 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3868 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3869 IV n, const char *mode, int fd, int imode, int perm,
3870 PerlIO *f, int narg, SV **args)
3872 if (PerlIOValid(f)) {
3873 PerlIO *next = PerlIONext(f);
3875 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3876 if (tab && tab->Open)
3878 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3880 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3885 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3887 if (*mode == IoTYPE_IMPLICIT) {
3893 if (tab && tab->Open)
3894 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3897 SETERRNO(EINVAL, LIB_INVARG);
3899 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3901 * if push fails during open, open fails. close will pop us.
3906 fd = PerlIO_fileno(f);
3907 if (init && fd == 2) {
3909 * Initial stderr is unbuffered
3911 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3913 #ifdef PERLIO_USING_CRLF
3914 # ifdef PERLIO_IS_BINMODE_FD
3915 if (PERLIO_IS_BINMODE_FD(fd))
3916 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3920 * do something about failing setmode()? --jhi
3922 PerlLIO_setmode(fd, O_BINARY);
3925 /* Enable line buffering with record-oriented regular files
3926 * so we don't introduce an extraneous record boundary when
3927 * the buffer fills up.
3929 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3931 if (PerlLIO_fstat(fd, &st) == 0
3932 && S_ISREG(st.st_mode)
3933 && (st.st_fab_rfm == FAB$C_VAR
3934 || st.st_fab_rfm == FAB$C_VFC)) {
3935 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3946 * This "flush" is akin to sfio's sync in that it handles files in either
3947 * read or write state. For write state, we put the postponed data through
3948 * the next layers. For read state, we seek() the next layers to the
3949 * offset given by current position in the buffer, and discard the buffer
3950 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3951 * in any case?). Then the pass the stick further in chain.
3954 PerlIOBuf_flush(pTHX_ PerlIO *f)
3956 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3958 PerlIO *n = PerlIONext(f);
3959 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3961 * write() the buffer
3963 const STDCHAR *buf = b->buf;
3964 const STDCHAR *p = buf;
3965 while (p < b->ptr) {
3966 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3970 else if (count < 0 || PerlIO_error(n)) {
3971 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3972 PerlIO_save_errno(f);
3977 b->posn += (p - buf);
3979 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3980 STDCHAR *buf = PerlIO_get_base(f);
3982 * Note position change
3984 b->posn += (b->ptr - buf);
3985 if (b->ptr < b->end) {
3986 /* We did not consume all of it - try and seek downstream to
3987 our logical position
3989 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3990 /* Reload n as some layers may pop themselves on seek */
3991 b->posn = PerlIO_tell(n = PerlIONext(f));
3994 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3995 data is lost for good - so return saying "ok" having undone
3998 b->posn -= (b->ptr - buf);
4003 b->ptr = b->end = b->buf;
4004 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4005 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4006 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4011 /* This discards the content of the buffer after b->ptr, and rereads
4012 * the buffer from the position off in the layer downstream; here off
4013 * is at offset corresponding to b->ptr - b->buf.
4016 PerlIOBuf_fill(pTHX_ PerlIO *f)
4018 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4019 PerlIO *n = PerlIONext(f);
4022 * Down-stream flush is defined not to loose read data so is harmless.
4023 * we would not normally be fill'ing if there was data left in anycase.
4025 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4027 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4028 PerlIOBase_flush_linebuf(aTHX);
4031 PerlIO_get_base(f); /* allocate via vtable */
4033 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4035 b->ptr = b->end = b->buf;
4037 if (!PerlIOValid(n)) {
4038 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4042 if (PerlIO_fast_gets(n)) {
4044 * Layer below is also buffered. We do _NOT_ want to call its
4045 * ->Read() because that will loop till it gets what we asked for
4046 * which may hang on a pipe etc. Instead take anything it has to
4047 * hand, or ask it to fill _once_.
4049 avail = PerlIO_get_cnt(n);
4051 avail = PerlIO_fill(n);
4053 avail = PerlIO_get_cnt(n);
4055 if (!PerlIO_error(n) && PerlIO_eof(n))
4060 STDCHAR *ptr = PerlIO_get_ptr(n);
4061 const SSize_t cnt = avail;
4062 if (avail > (SSize_t)b->bufsiz)
4064 Copy(ptr, b->buf, avail, STDCHAR);
4065 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4069 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4073 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4076 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4077 PerlIO_save_errno(f);
4081 b->end = b->buf + avail;
4082 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4087 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4089 if (PerlIOValid(f)) {
4090 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4093 return PerlIOBase_read(aTHX_ f, vbuf, count);
4099 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4101 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4102 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4105 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4110 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4112 * Buffer is already a read buffer, we can overwrite any chars
4113 * which have been read back to buffer start
4115 avail = (b->ptr - b->buf);
4119 * Buffer is idle, set it up so whole buffer is available for
4123 b->end = b->buf + avail;
4125 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4127 * Buffer extends _back_ from where we are now
4129 b->posn -= b->bufsiz;
4131 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4133 * If we have space for more than count, just move count
4141 * In simple stdio-like ungetc() case chars will be already
4144 if (buf != b->ptr) {
4145 Copy(buf, b->ptr, avail, STDCHAR);
4149 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4153 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4159 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4161 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4162 const STDCHAR *buf = (const STDCHAR *) vbuf;
4163 const STDCHAR *flushptr = buf;
4167 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4169 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4170 if (PerlIO_flush(f) != 0) {
4174 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4175 flushptr = buf + count;
4176 while (flushptr > buf && *(flushptr - 1) != '\n')
4180 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4181 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4183 if (flushptr > buf && flushptr <= buf + avail)
4184 avail = flushptr - buf;
4185 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4187 Copy(buf, b->ptr, avail, STDCHAR);
4192 if (buf == flushptr)
4195 if (b->ptr >= (b->buf + b->bufsiz))
4196 if (PerlIO_flush(f) == -1)
4199 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4205 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4208 if ((code = PerlIO_flush(f)) == 0) {
4209 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4210 code = PerlIO_seek(PerlIONext(f), offset, whence);
4212 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4213 b->posn = PerlIO_tell(PerlIONext(f));
4220 PerlIOBuf_tell(pTHX_ PerlIO *f)
4222 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4224 * b->posn is file position where b->buf was read, or will be written
4226 Off_t posn = b->posn;
4227 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4228 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4230 /* As O_APPEND files are normally shared in some sense it is better
4235 /* when file is NOT shared then this is sufficient */
4236 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4238 posn = b->posn = PerlIO_tell(PerlIONext(f));
4242 * If buffer is valid adjust position by amount in buffer
4244 posn += (b->ptr - b->buf);
4250 PerlIOBuf_popped(pTHX_ PerlIO *f)
4252 const IV code = PerlIOBase_popped(aTHX_ f);
4253 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4254 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4257 b->ptr = b->end = b->buf = NULL;
4258 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4263 PerlIOBuf_close(pTHX_ PerlIO *f)
4265 const IV code = PerlIOBase_close(aTHX_ f);
4266 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4267 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4270 b->ptr = b->end = b->buf = NULL;
4271 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4276 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4278 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4285 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4287 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4290 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4291 return (b->end - b->ptr);
4296 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4298 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4299 PERL_UNUSED_CONTEXT;
4303 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4304 Newxz(b->buf,b->bufsiz, STDCHAR);
4306 b->buf = (STDCHAR *) & b->oneword;
4307 b->bufsiz = sizeof(b->oneword);
4309 b->end = b->ptr = b->buf;
4315 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4317 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4320 return (b->end - b->buf);
4324 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4326 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4328 PERL_UNUSED_ARG(cnt);
4333 assert(PerlIO_get_cnt(f) == cnt);
4334 assert(b->ptr >= b->buf);
4335 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4339 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4341 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4346 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4347 sizeof(PerlIO_funcs),
4350 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4354 PerlIOBase_binmode, /* binmode */
4368 PerlIOBase_clearerr,
4369 PerlIOBase_setlinebuf,
4374 PerlIOBuf_set_ptrcnt,
4377 /*--------------------------------------------------------------------------------------*/
4379 * Temp layer to hold unread chars when cannot do it any other way
4383 PerlIOPending_fill(pTHX_ PerlIO *f)
4386 * Should never happen
4393 PerlIOPending_close(pTHX_ PerlIO *f)
4396 * A tad tricky - flush pops us, then we close new top
4399 return PerlIO_close(f);
4403 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4406 * A tad tricky - flush pops us, then we seek new top
4409 return PerlIO_seek(f, offset, whence);
4414 PerlIOPending_flush(pTHX_ PerlIO *f)
4416 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4417 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4421 PerlIO_pop(aTHX_ f);
4426 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4432 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4437 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4439 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4440 PerlIOl * const l = PerlIOBase(f);
4442 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4443 * etc. get muddled when it changes mid-string when we auto-pop.
4445 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4446 (PerlIOBase(PerlIONext(f))->
4447 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4452 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4454 SSize_t avail = PerlIO_get_cnt(f);
4456 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4459 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4460 if (got >= 0 && got < (SSize_t)count) {
4461 const SSize_t more =
4462 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4463 if (more >= 0 || got == 0)
4469 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4470 sizeof(PerlIO_funcs),
4473 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4474 PerlIOPending_pushed,
4477 PerlIOBase_binmode, /* binmode */
4486 PerlIOPending_close,
4487 PerlIOPending_flush,
4491 PerlIOBase_clearerr,
4492 PerlIOBase_setlinebuf,
4497 PerlIOPending_set_ptrcnt,
4502 /*--------------------------------------------------------------------------------------*/
4504 * crlf - translation On read translate CR,LF to "\n" we do this by
4505 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4506 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4508 * c->nl points on the first byte of CR LF pair when it is temporarily
4509 * replaced by LF, or to the last CR of the buffer. In the former case
4510 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4511 * that it ends at c->nl; these two cases can be distinguished by
4512 * *c->nl. c->nl is set during _getcnt() call, and unset during
4513 * _unread() and _flush() calls.
4514 * It only matters for read operations.
4518 PerlIOBuf base; /* PerlIOBuf stuff */
4519 STDCHAR *nl; /* Position of crlf we "lied" about in the
4523 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4524 * Otherwise the :crlf layer would always revert back to
4528 S_inherit_utf8_flag(PerlIO *f)
4530 PerlIO *g = PerlIONext(f);
4531 if (PerlIOValid(g)) {
4532 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4533 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4539 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4542 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4543 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4546 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4547 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4548 PerlIOBase(f)->flags);
4552 /* If the old top layer is a CRLF layer, reactivate it (if
4553 * necessary) and remove this new layer from the stack */
4554 PerlIO *g = PerlIONext(f);
4555 if (PerlIOValid(g)) {
4556 PerlIOl *b = PerlIOBase(g);
4557 if (b && b->tab == &PerlIO_crlf) {
4558 if (!(b->flags & PERLIO_F_CRLF))
4559 b->flags |= PERLIO_F_CRLF;
4560 S_inherit_utf8_flag(g);
4561 PerlIO_pop(aTHX_ f);
4566 S_inherit_utf8_flag(f);
4572 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4574 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4575 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4576 *(c->nl) = NATIVE_0xd;
4579 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4580 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4582 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4583 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4585 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4590 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4591 b->end = b->ptr = b->buf + b->bufsiz;
4592 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4593 b->posn -= b->bufsiz;
4595 while (count > 0 && b->ptr > b->buf) {
4596 const int ch = *--buf;
4598 if (b->ptr - 2 >= b->buf) {
4599 *--(b->ptr) = NATIVE_0xa;
4600 *--(b->ptr) = NATIVE_0xd;
4605 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4606 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4620 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4625 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4627 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4629 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4632 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4633 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4634 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4635 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4637 while (nl < b->end && *nl != NATIVE_0xd)
4639 if (nl < b->end && *nl == NATIVE_0xd) {
4641 if (nl + 1 < b->end) {
4642 if (nl[1] == NATIVE_0xa) {
4648 * Not CR,LF but just CR
4656 * Blast - found CR as last char in buffer
4661 * They may not care, defer work as long as
4665 return (nl - b->ptr);
4669 b->ptr++; /* say we have read it as far as
4670 * flush() is concerned */
4671 b->buf++; /* Leave space in front of buffer */
4672 /* Note as we have moved buf up flush's
4674 will naturally make posn point at CR
4676 b->bufsiz--; /* Buffer is thus smaller */
4677 code = PerlIO_fill(f); /* Fetch some more */
4678 b->bufsiz++; /* Restore size for next time */
4679 b->buf--; /* Point at space */
4680 b->ptr = nl = b->buf; /* Which is what we hand
4682 *nl = NATIVE_0xd; /* Fill in the CR */
4684 goto test; /* fill() call worked */
4686 * CR at EOF - just fall through
4688 /* Should we clear EOF though ??? */
4693 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4699 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4701 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4702 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4708 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4709 /* Deferred CR at end of buffer case - we lied about count */
4722 * Test code - delete when it works ...
4724 IV flags = PerlIOBase(f)->flags;
4725 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4726 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4727 /* Deferred CR at end of buffer case - we lied about count */
4733 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4734 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4735 flags, c->nl, b->end, cnt);
4742 * They have taken what we lied about
4744 *(c->nl) = NATIVE_0xd;
4750 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4754 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4756 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4757 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4759 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4760 const STDCHAR *buf = (const STDCHAR *) vbuf;
4761 const STDCHAR * const ebuf = buf + count;
4764 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4766 while (buf < ebuf) {
4767 const STDCHAR * const eptr = b->buf + b->bufsiz;
4768 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4769 while (buf < ebuf && b->ptr < eptr) {
4771 if ((b->ptr + 2) > eptr) {
4779 *(b->ptr)++ = NATIVE_0xd; /* CR */
4780 *(b->ptr)++ = NATIVE_0xa; /* LF */
4782 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4789 *(b->ptr)++ = *buf++;
4791 if (b->ptr >= eptr) {
4797 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4799 return (buf - (STDCHAR *) vbuf);
4804 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4806 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4808 *(c->nl) = NATIVE_0xd;
4811 return PerlIOBuf_flush(aTHX_ f);
4815 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4817 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4818 /* In text mode - flush any pending stuff and flip it */
4819 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4820 #ifndef PERLIO_USING_CRLF
4821 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4822 PerlIO_pop(aTHX_ f);
4828 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4829 sizeof(PerlIO_funcs),
4832 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4834 PerlIOBuf_popped, /* popped */
4836 PerlIOCrlf_binmode, /* binmode */
4840 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4841 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4842 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4850 PerlIOBase_clearerr,
4851 PerlIOBase_setlinebuf,
4856 PerlIOCrlf_set_ptrcnt,
4860 Perl_PerlIO_stdin(pTHX)
4863 PerlIO_stdstreams(aTHX);
4865 return (PerlIO*)&PL_perlio[1];
4869 Perl_PerlIO_stdout(pTHX)
4872 PerlIO_stdstreams(aTHX);
4874 return (PerlIO*)&PL_perlio[2];
4878 Perl_PerlIO_stderr(pTHX)
4881 PerlIO_stdstreams(aTHX);
4883 return (PerlIO*)&PL_perlio[3];
4886 /*--------------------------------------------------------------------------------------*/
4889 PerlIO_getname(PerlIO *f, char *buf)
4894 bool exported = FALSE;
4895 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4897 stdio = PerlIO_exportFILE(f,0);
4901 name = fgetname(stdio, buf);
4902 if (exported) PerlIO_releaseFILE(f,stdio);
4907 PERL_UNUSED_ARG(buf);
4908 Perl_croak_nocontext("Don't know how to get file name");
4914 /*--------------------------------------------------------------------------------------*/
4916 * Functions which can be called on any kind of PerlIO implemented in
4920 #undef PerlIO_fdopen
4922 PerlIO_fdopen(int fd, const char *mode)
4925 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4930 PerlIO_open(const char *path, const char *mode)
4933 SV *name = sv_2mortal(newSVpv(path, 0));
4934 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4937 #undef Perlio_reopen
4939 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4942 SV *name = sv_2mortal(newSVpv(path,0));
4943 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4948 PerlIO_getc(PerlIO *f)
4952 if ( 1 == PerlIO_read(f, buf, 1) ) {
4953 return (unsigned char) buf[0];
4958 #undef PerlIO_ungetc
4960 PerlIO_ungetc(PerlIO *f, int ch)
4965 if (PerlIO_unread(f, &buf, 1) == 1)
4973 PerlIO_putc(PerlIO *f, int ch)
4977 return PerlIO_write(f, &buf, 1);
4982 PerlIO_puts(PerlIO *f, const char *s)
4985 return PerlIO_write(f, s, strlen(s));
4988 #undef PerlIO_rewind
4990 PerlIO_rewind(PerlIO *f)
4993 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4997 #undef PerlIO_vprintf
4999 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5008 Perl_va_copy(ap, apc);
5009 sv = vnewSVpvf(fmt, &apc);
5012 sv = vnewSVpvf(fmt, &ap);
5014 s = SvPV_const(sv, len);
5015 wrote = PerlIO_write(f, s, len);
5020 #undef PerlIO_printf
5022 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5027 result = PerlIO_vprintf(f, fmt, ap);
5032 #undef PerlIO_stdoutf
5034 PerlIO_stdoutf(const char *fmt, ...)
5040 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5045 #undef PerlIO_tmpfile
5047 PerlIO_tmpfile(void)
5054 const int fd = win32_tmpfd();
5056 f = PerlIO_fdopen(fd, "w+b");
5058 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5060 char tempname[] = "/tmp/PerlIO_XXXXXX";
5061 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5063 int old_umask = umask(0177);
5065 * I have no idea how portable mkstemp() is ... NI-S
5067 if (tmpdir && *tmpdir) {
5068 /* if TMPDIR is set and not empty, we try that first */
5069 sv = newSVpv(tmpdir, 0);
5070 sv_catpv(sv, tempname + 4);
5071 fd = mkstemp(SvPVX(sv));
5076 /* else we try /tmp */
5077 fd = mkstemp(tempname);
5082 sv_catpv(sv, tempname + 4);
5083 fd = mkstemp(SvPVX(sv));
5087 f = PerlIO_fdopen(fd, "w+");
5089 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5090 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5093 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5094 FILE * const stdio = PerlSIO_tmpfile();
5097 f = PerlIO_fdopen(fileno(stdio), "w+");
5099 # endif /* else HAS_MKSTEMP */
5100 #endif /* else WIN32 */
5105 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5107 if (!PerlIOValid(f))
5109 PerlIOBase(f)->err = errno;
5111 PerlIOBase(f)->os_err = vaxc$errno;
5113 PerlIOBase(f)->os_err = Perl_rc;
5114 #elif defined(WIN32)
5115 PerlIOBase(f)->os_err = GetLastError();
5120 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5122 if (!PerlIOValid(f))
5124 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5126 Perl_rc = PerlIOBase(f)->os_err);
5127 #elif defined(WIN32)
5128 SetLastError(PerlIOBase(f)->os_err);
5136 /*======================================================================================*/
5138 * Now some functions in terms of above which may be needed even if we are
5139 * not in true PerlIO mode
5142 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5144 const char *direction = NULL;
5147 * Need to supply default layer info from open.pm
5153 if (mode && mode[0] != 'r') {
5154 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5155 direction = "open>";
5157 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5158 direction = "open<";
5163 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5166 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5171 #undef PerlIO_setpos
5173 PerlIO_setpos(PerlIO *f, SV *pos)
5179 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5180 if(len == sizeof(Off_t))
5181 return PerlIO_seek(f, *posn, SEEK_SET);
5184 SETERRNO(EINVAL, SS_IVCHAN);
5188 #undef PerlIO_setpos
5190 PerlIO_setpos(PerlIO *f, SV *pos)
5196 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5197 if(len == sizeof(Fpos_t))
5198 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5199 return fsetpos64(f, fpos);
5201 return fsetpos(f, fpos);
5205 SETERRNO(EINVAL, SS_IVCHAN);
5211 #undef PerlIO_getpos
5213 PerlIO_getpos(PerlIO *f, SV *pos)
5216 Off_t posn = PerlIO_tell(f);
5217 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5218 return (posn == (Off_t) - 1) ? -1 : 0;
5221 #undef PerlIO_getpos
5223 PerlIO_getpos(PerlIO *f, SV *pos)
5228 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5229 code = fgetpos64(f, &fpos);
5231 code = fgetpos(f, &fpos);
5233 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5238 #if !defined(HAS_VPRINTF)
5241 vprintf(char *pat, char *args)
5243 _doprnt(pat, args, stdout);
5244 return 0; /* wrong, but perl doesn't use the return
5249 vfprintf(FILE *fd, char *pat, char *args)
5251 _doprnt(pat, args, fd);
5252 return 0; /* wrong, but perl doesn't use the return
5258 /* print a failure format string message to stderr and fail exit the process
5259 using only libc without depending on any perl data structures being
5264 Perl_noperl_die(const char* pat, ...)
5267 PERL_ARGS_ASSERT_NOPERL_DIE;
5268 va_start(arglist, pat);
5269 vfprintf(stderr, pat, arglist);
5275 * ex: set ts=8 sts=4 sw=4 et: