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__)
246 #elif defined(PERL_IMPLICIT_SYS)
247 return PerlSIO_fdupopen(f);
250 return win32_fdupopen(f);
253 const int fd = PerlLIO_dup(PerlIO_fileno(f));
257 const int omode = djgpp_get_stream_mode(f);
259 const int omode = fcntl(fd, F_GETFL);
261 PerlIO_intmode2str(omode,mode,NULL);
262 /* the r+ is a hack */
263 return PerlIO_fdopen(fd, mode);
268 SETERRNO(EBADF, SS_IVCHAN);
277 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
281 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
282 int imode, int perm, PerlIO *old, int narg, SV **args)
286 Perl_croak(aTHX_ "More than one argument to open");
288 if (*args == &PL_sv_undef)
289 return PerlIO_tmpfile();
292 const char *name = SvPV_const(*args, len);
293 if (!IS_SAFE_PATHNAME(name, len, "open"))
296 if (*mode == IoTYPE_NUMERIC) {
297 fd = PerlLIO_open3(name, imode, perm);
299 return PerlIO_fdopen(fd, mode + 1);
302 return PerlIO_reopen(name, mode, old);
305 return PerlIO_open(name, mode);
310 return PerlIO_fdopen(fd, (char *) mode);
315 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
316 XS(XS_PerlIO__Layer__find)
320 Perl_croak(aTHX_ "Usage class->find(name[,load])");
322 const char * const name = SvPV_nolen_const(ST(1));
323 ST(0) = (strEQ(name, "crlf")
324 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
331 Perl_boot_core_PerlIO(pTHX)
333 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
339 /*======================================================================================*/
341 * Implement all the PerlIO interface ourselves.
347 PerlIO_debug(const char *fmt, ...)
357 if (!PL_perlio_debug_fd) {
359 PerlProc_getuid() == PerlProc_geteuid() &&
360 PerlProc_getgid() == PerlProc_getegid()) {
361 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
364 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
366 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
368 /* tainting or set*id, so ignore the environment and send the
369 debug output to stderr, like other -D switches. */
370 PL_perlio_debug_fd = PerlLIO_dup(2); /* stderr */
373 if (PL_perlio_debug_fd > 0) {
375 const char * const s = CopFILE(PL_curcop);
376 /* Use fixed buffer as sv_catpvf etc. needs SVs */
378 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
379 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
380 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
382 const char *s = CopFILE(PL_curcop);
384 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
385 (IV) CopLINE(PL_curcop));
386 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
388 s = SvPV_const(sv, len);
389 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
396 /*--------------------------------------------------------------------------------------*/
399 * Inner level routines
402 /* check that the head field of each layer points back to the head */
405 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
407 PerlIO_verify_head(pTHX_ PerlIO *f)
411 #ifndef PERL_IMPLICIT_SYS
416 p = head = PerlIOBase(f)->head;
419 assert(p->head == head);
420 if (p == (PerlIOl*)f)
427 # define VERIFY_HEAD(f)
432 * Table of pointers to the PerlIO structs (malloc'ed)
434 #define PERLIO_TABLE_SIZE 64
437 PerlIO_init_table(pTHX)
441 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
447 PerlIO_allocate(pTHX)
450 * Find a free slot in the table, allocating new table as necessary
455 while ((f = *last)) {
457 last = (PerlIOl **) (f);
458 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
459 if (!((++f)->next)) {
464 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
468 *last = (PerlIOl*) f++;
471 f->flags = 0; /* lockcnt */
477 #undef PerlIO_fdupopen
479 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
481 if (PerlIOValid(f)) {
482 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
483 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
485 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
487 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
491 SETERRNO(EBADF, SS_IVCHAN);
497 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
499 PerlIOl * const table = *tablep;
502 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
503 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
504 PerlIOl * const f = table + i;
506 PerlIO_close(&(f->next));
516 PerlIO_list_alloc(pTHX)
520 Newxz(list, 1, PerlIO_list_t);
526 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
529 if (--list->refcnt == 0) {
532 for (i = 0; i < list->cur; i++)
533 SvREFCNT_dec(list->array[i].arg);
534 Safefree(list->array);
542 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
547 if (list->cur >= list->len) {
548 const IV new_len = list->len + 8;
550 Renew(list->array, new_len, PerlIO_pair_t);
552 Newx(list->array, new_len, PerlIO_pair_t);
555 p = &(list->array[list->cur++]);
557 if ((p->arg = arg)) {
558 SvREFCNT_inc_simple_void_NN(arg);
563 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
565 PerlIO_list_t *list = NULL;
568 list = PerlIO_list_alloc(aTHX);
569 for (i=0; i < proto->cur; i++) {
570 SV *arg = proto->array[i].arg;
573 arg = sv_dup(arg, param);
575 PERL_UNUSED_ARG(param);
577 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
584 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
587 PerlIOl **table = &proto->Iperlio;
590 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
591 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
592 PerlIO_init_table(aTHX);
593 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
594 while ((f = *table)) {
596 table = (PerlIOl **) (f++);
597 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
599 (void) fp_dup(&(f->next), 0, param);
606 PERL_UNUSED_ARG(proto);
607 PERL_UNUSED_ARG(param);
612 PerlIO_destruct(pTHX)
614 PerlIOl **table = &PL_perlio;
617 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
619 while ((f = *table)) {
621 table = (PerlIOl **) (f++);
622 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
623 PerlIO *x = &(f->next);
626 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
627 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
641 PerlIO_pop(pTHX_ PerlIO *f)
643 const PerlIOl *l = *f;
646 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
647 l->tab ? l->tab->name : "(Null)") );
648 if (l->tab && l->tab->Popped) {
650 * If popped returns non-zero do not free its layer structure
651 * it has either done so itself, or it is shared and still in
654 if ((*l->tab->Popped) (aTHX_ f) != 0)
657 if (PerlIO_lockcnt(f)) {
658 /* we're in use; defer freeing the structure */
659 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
660 PerlIOBase(f)->tab = NULL;
670 /* Return as an array the stack of layers on a filehandle. Note that
671 * the stack is returned top-first in the array, and there are three
672 * times as many array elements as there are layers in the stack: the
673 * first element of a layer triplet is the name, the second one is the
674 * arguments, and the third one is the flags. */
677 PerlIO_get_layers(pTHX_ PerlIO *f)
679 AV * const av = newAV();
681 if (PerlIOValid(f)) {
682 PerlIOl *l = PerlIOBase(f);
685 /* There is some collusion in the implementation of
686 XS_PerlIO_get_layers - it knows that name and flags are
687 generated as fresh SVs here, and takes advantage of that to
688 "copy" them by taking a reference. If it changes here, it needs
689 to change there too. */
690 SV * const name = l->tab && l->tab->name ?
691 newSVpv(l->tab->name, 0) : &PL_sv_undef;
692 SV * const arg = l->tab && l->tab->Getarg ?
693 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
696 av_push(av, newSViv((IV)l->flags));
704 /*--------------------------------------------------------------------------------------*/
706 * XS Interface for perl code
710 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
714 if ((SSize_t) len <= 0)
716 for (i = 0; i < PL_known_layers->cur; i++) {
717 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
718 const STRLEN this_len = strlen(f->name);
719 if (this_len == len && memEQ(f->name, name, len)) {
720 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
724 if (load && PL_subname && PL_def_layerlist
725 && PL_def_layerlist->cur >= 2) {
726 if (PL_in_load_module) {
727 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
730 SV * const pkgsv = newSVpvs("PerlIO");
731 SV * const layer = newSVpvn(name, len);
732 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
734 SAVEBOOL(PL_in_load_module);
736 SAVEGENERICSV(PL_warnhook);
737 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
739 PL_in_load_module = TRUE;
741 * The two SVs are magically freed by load_module
743 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
745 return PerlIO_find_layer(aTHX_ name, len, 0);
748 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
752 #ifdef USE_ATTRIBUTES_FOR_PERLIO
755 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
758 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
759 PerlIO * const ifp = IoIFP(io);
760 PerlIO * const ofp = IoOFP(io);
761 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
762 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
768 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
771 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
772 PerlIO * const ifp = IoIFP(io);
773 PerlIO * const ofp = IoOFP(io);
774 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
775 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
781 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
783 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
788 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
790 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
794 MGVTBL perlio_vtab = {
802 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
803 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
806 SV * const sv = SvRV(ST(1));
807 AV * const av = newAV();
811 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
813 mg = mg_find(sv, PERL_MAGIC_ext);
814 mg->mg_virtual = &perlio_vtab;
816 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
817 for (i = 2; i < items; i++) {
819 const char * const name = SvPV_const(ST(i), len);
820 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
822 av_push(av, SvREFCNT_inc_simple_NN(layer));
833 #endif /* USE_ATTRIBUTES_FOR_PERLIO */
836 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
838 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
839 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
843 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
844 XS(XS_PerlIO__Layer__NoWarnings)
846 /* This is used as a %SIG{__WARN__} handler to suppress warnings
847 during loading of layers.
850 PERL_UNUSED_VAR(items);
853 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
857 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
858 XS(XS_PerlIO__Layer__find)
862 Perl_croak(aTHX_ "Usage class->find(name[,load])");
865 const char * const name = SvPV_const(ST(1), len);
866 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
867 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
869 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
876 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
878 if (!PL_known_layers)
879 PL_known_layers = PerlIO_list_alloc(aTHX);
880 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
881 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
885 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
888 const char *s = names;
890 while (isSPACE(*s) || *s == ':')
895 const char *as = NULL;
897 if (!isIDFIRST(*s)) {
899 * Message is consistent with how attribute lists are
900 * passed. Even though this means "foo : : bar" is
901 * seen as an invalid separator character.
903 const char q = ((*s == '\'') ? '"' : '\'');
904 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
905 "Invalid separator character %c%c%c in PerlIO layer specification %s",
907 SETERRNO(EINVAL, LIB_INVARG);
912 } while (isWORDCHAR(*e));
928 * It's a nul terminated string, not allowed
929 * to \ the terminating null. Anything other
930 * character is passed over.
938 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
939 "Argument list not closed for PerlIO layer \"%.*s\"",
951 PerlIO_funcs * const layer =
952 PerlIO_find_layer(aTHX_ s, llen, 1);
956 arg = newSVpvn(as, alen);
957 PerlIO_list_push(aTHX_ av, layer,
958 (arg) ? arg : &PL_sv_undef);
962 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
975 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
977 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
978 #ifdef PERLIO_USING_CRLF
981 if (PerlIO_stdio.Set_ptrcnt)
984 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
985 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
989 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
991 return av->array[n].arg;
995 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
997 if (n >= 0 && n < av->cur) {
998 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
999 av->array[n].funcs->name) );
1000 return av->array[n].funcs;
1003 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1008 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1010 PERL_UNUSED_ARG(mode);
1011 PERL_UNUSED_ARG(arg);
1012 PERL_UNUSED_ARG(tab);
1013 if (PerlIOValid(f)) {
1015 PerlIO_pop(aTHX_ f);
1021 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1022 sizeof(PerlIO_funcs),
1025 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1045 NULL, /* get_base */
1046 NULL, /* get_bufsiz */
1049 NULL, /* set_ptrcnt */
1053 PerlIO_default_layers(pTHX)
1055 if (!PL_def_layerlist) {
1056 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1057 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1058 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1059 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1061 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1063 osLayer = &PerlIO_win32;
1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1067 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1068 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1069 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1070 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1071 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1072 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1073 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1076 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1079 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1082 if (PL_def_layerlist->cur < 2) {
1083 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1085 return PL_def_layerlist;
1089 Perl_boot_core_PerlIO(pTHX)
1091 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1092 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1095 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1096 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1100 PerlIO_default_layer(pTHX_ I32 n)
1102 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1105 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1108 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1109 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1112 PerlIO_stdstreams(pTHX)
1115 PerlIO_init_table(aTHX);
1116 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1117 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1118 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1123 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1126 if (tab->fsize != sizeof(PerlIO_funcs)) {
1128 "%s (%" UVuf ") does not match %s (%" UVuf ")",
1129 "PerlIO layer function table size", (UV)tab->fsize,
1130 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1134 if (tab->size < sizeof(PerlIOl)) {
1136 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1137 "PerlIO layer instance size", (UV)tab->size,
1138 "size expected by this perl", (UV)sizeof(PerlIOl) );
1140 /* Real layer with a data area */
1143 Newxz(temp, tab->size, char);
1147 l->tab = (PerlIO_funcs*) tab;
1148 l->head = ((PerlIOl*)f)->head;
1150 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1151 (void*)f, tab->name,
1152 (mode) ? mode : "(Null)", (void*)arg) );
1153 if (*l->tab->Pushed &&
1155 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1156 PerlIO_pop(aTHX_ f);
1165 /* Pseudo-layer where push does its own stack adjust */
1166 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1167 (mode) ? mode : "(Null)", (void*)arg) );
1169 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1177 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1178 IV n, const char *mode, int fd, int imode, int perm,
1179 PerlIO *old, int narg, SV **args)
1181 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1182 if (tab && tab->Open) {
1183 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1184 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1190 SETERRNO(EINVAL, LIB_INVARG);
1195 PerlIOBase_binmode(pTHX_ PerlIO *f)
1197 if (PerlIOValid(f)) {
1198 /* Is layer suitable for raw stream ? */
1199 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1200 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1201 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1204 /* Not suitable - pop it */
1205 PerlIO_pop(aTHX_ f);
1213 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1215 PERL_UNUSED_ARG(mode);
1216 PERL_UNUSED_ARG(arg);
1217 PERL_UNUSED_ARG(tab);
1219 if (PerlIOValid(f)) {
1224 * Strip all layers that are not suitable for a raw stream
1227 while (t && (l = *t)) {
1228 if (l->tab && l->tab->Binmode) {
1229 /* Has a handler - normal case */
1230 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1232 /* Layer still there - move down a layer */
1241 /* No handler - pop it */
1242 PerlIO_pop(aTHX_ t);
1245 if (PerlIOValid(f)) {
1246 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1247 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1255 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1256 PerlIO_list_t *layers, IV n, IV max)
1260 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1262 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1273 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1277 save_scalar(PL_errgv);
1279 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1280 code = PerlIO_parse_layers(aTHX_ layers, names);
1282 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1284 PerlIO_list_free(aTHX_ layers);
1291 /*--------------------------------------------------------------------------------------*/
1293 * Given the abstraction above the public API functions
1297 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1299 PERL_UNUSED_ARG(iotype);
1300 PERL_UNUSED_ARG(mode);
1303 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1304 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1305 PerlIOBase(f)->tab->name : "(Null)",
1306 iotype, mode, (names) ? names : "(Null)") );
1309 /* Do not flush etc. if (e.g.) switching encodings.
1310 if a pushed layer knows it needs to flush lower layers
1311 (for example :unix which is never going to call them)
1312 it can do the flush when it is pushed.
1314 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1317 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1318 #ifdef PERLIO_USING_CRLF
1319 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1320 O_BINARY so we can look for it in mode.
1322 if (!(mode & O_BINARY)) {
1324 /* FIXME?: Looking down the layer stack seems wrong,
1325 but is a way of reaching past (say) an encoding layer
1326 to flip CRLF-ness of the layer(s) below
1329 /* Perhaps we should turn on bottom-most aware layer
1330 e.g. Ilya's idea that UNIX TTY could serve
1332 if (PerlIOBase(f)->tab &&
1333 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1335 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1336 /* Not in text mode - flush any pending stuff and flip it */
1338 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1340 /* Only need to turn it on in one layer so we are done */
1345 /* Not finding a CRLF aware layer presumably means we are binary
1346 which is not what was requested - so we failed
1347 We _could_ push :crlf layer but so could caller
1352 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1353 So code that used to be here is now in PerlIORaw_pushed().
1355 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1360 PerlIO__close(pTHX_ PerlIO *f)
1362 if (PerlIOValid(f)) {
1363 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1364 if (tab && tab->Close)
1365 return (*tab->Close)(aTHX_ f);
1367 return PerlIOBase_close(aTHX_ f);
1370 SETERRNO(EBADF, SS_IVCHAN);
1376 Perl_PerlIO_close(pTHX_ PerlIO *f)
1378 const int code = PerlIO__close(aTHX_ f);
1379 while (PerlIOValid(f)) {
1380 PerlIO_pop(aTHX_ f);
1381 if (PerlIO_lockcnt(f))
1382 /* we're in use; the 'pop' deferred freeing the structure */
1389 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1391 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1395 static PerlIO_funcs *
1396 PerlIO_layer_from_ref(pTHX_ SV *sv)
1399 * For any scalar type load the handler which is bundled with perl
1401 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1402 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1403 /* This isn't supposed to happen, since PerlIO::scalar is core,
1404 * but could happen anyway in smaller installs or with PAR */
1406 /* diag_listed_as: Unknown PerlIO layer "%s" */
1407 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1412 * For other types allow if layer is known but don't try and load it
1414 switch (SvTYPE(sv)) {
1416 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1418 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1420 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1422 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1429 PerlIO_resolve_layers(pTHX_ const char *layers,
1430 const char *mode, int narg, SV **args)
1432 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1435 PerlIO_stdstreams(aTHX);
1437 SV * const arg = *args;
1439 * If it is a reference but not an object see if we have a handler
1442 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1443 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1445 def = PerlIO_list_alloc(aTHX);
1446 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1450 * Don't fail if handler cannot be found :via(...) etc. may do
1451 * something sensible else we will just stringfy and open
1456 if (!layers || !*layers)
1457 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1458 if (layers && *layers) {
1461 av = PerlIO_clone_list(aTHX_ def, NULL);
1466 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1470 PerlIO_list_free(aTHX_ av);
1482 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1483 int imode, int perm, PerlIO *f, int narg, SV **args)
1485 if (!f && narg == 1 && *args == &PL_sv_undef) {
1486 if ((f = PerlIO_tmpfile())) {
1487 if (!layers || !*layers)
1488 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1489 if (layers && *layers)
1490 PerlIO_apply_layers(aTHX_ f, mode, layers);
1494 PerlIO_list_t *layera;
1496 PerlIO_funcs *tab = NULL;
1497 if (PerlIOValid(f)) {
1499 * This is "reopen" - it is not tested as perl does not use it
1503 layera = PerlIO_list_alloc(aTHX);
1506 if (l->tab && l->tab->Getarg)
1507 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1508 PerlIO_list_push(aTHX_ layera, l->tab,
1509 (arg) ? arg : &PL_sv_undef);
1511 l = *PerlIONext(&l);
1515 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1521 * Start at "top" of layer stack
1523 n = layera->cur - 1;
1525 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1534 * Found that layer 'n' can do opens - call it
1536 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1537 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1539 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1540 tab->name, layers ? layers : "(Null)", mode, fd,
1541 imode, perm, (void*)f, narg, (void*)args) );
1543 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1546 SETERRNO(EINVAL, LIB_INVARG);
1550 if (n + 1 < layera->cur) {
1552 * More layers above the one that we used to open -
1555 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1556 /* If pushing layers fails close the file */
1563 PerlIO_list_free(aTHX_ layera);
1570 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1572 PERL_ARGS_ASSERT_PERLIO_READ;
1574 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1578 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1580 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1582 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1586 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1588 PERL_ARGS_ASSERT_PERLIO_WRITE;
1590 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1594 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1596 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1600 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1602 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1606 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1610 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1612 if (tab && tab->Flush)
1613 return (*tab->Flush) (aTHX_ f);
1615 return 0; /* If no Flush defined, silently succeed. */
1618 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1619 SETERRNO(EBADF, SS_IVCHAN);
1625 * Is it good API design to do flush-all on NULL, a potentially
1626 * erroneous input? Maybe some magical value (PerlIO*
1627 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1628 * things on fflush(NULL), but should we be bound by their design
1631 PerlIOl **table = &PL_perlio;
1634 while ((ff = *table)) {
1636 table = (PerlIOl **) (ff++);
1637 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1638 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1648 PerlIOBase_flush_linebuf(pTHX)
1650 PerlIOl **table = &PL_perlio;
1652 while ((f = *table)) {
1654 table = (PerlIOl **) (f++);
1655 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1657 && (PerlIOBase(&(f->next))->
1658 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1659 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1660 PerlIO_flush(&(f->next));
1667 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1669 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1673 PerlIO_isutf8(PerlIO *f)
1676 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1678 SETERRNO(EBADF, SS_IVCHAN);
1684 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1686 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1690 Perl_PerlIO_error(pTHX_ PerlIO *f)
1692 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1696 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1698 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1702 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1704 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1708 PerlIO_has_base(PerlIO *f)
1710 if (PerlIOValid(f)) {
1711 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1714 return (tab->Get_base != NULL);
1721 PerlIO_fast_gets(PerlIO *f)
1723 if (PerlIOValid(f)) {
1724 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1725 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1728 return (tab->Set_ptrcnt != NULL);
1736 PerlIO_has_cntptr(PerlIO *f)
1738 if (PerlIOValid(f)) {
1739 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1742 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1749 PerlIO_canset_cnt(PerlIO *f)
1751 if (PerlIOValid(f)) {
1752 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1755 return (tab->Set_ptrcnt != NULL);
1762 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1764 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1768 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1770 /* Note that Get_bufsiz returns a Size_t */
1771 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1775 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1777 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1781 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1783 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1787 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1789 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1793 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1795 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1799 /*--------------------------------------------------------------------------------------*/
1801 * utf8 and raw dummy layers
1805 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1807 PERL_UNUSED_CONTEXT;
1808 PERL_UNUSED_ARG(mode);
1809 PERL_UNUSED_ARG(arg);
1810 if (PerlIOValid(f)) {
1811 if (tab && tab->kind & PERLIO_K_UTF8)
1812 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1814 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1820 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1821 sizeof(PerlIO_funcs),
1824 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1844 NULL, /* get_base */
1845 NULL, /* get_bufsiz */
1848 NULL, /* set_ptrcnt */
1851 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1852 sizeof(PerlIO_funcs),
1855 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1875 NULL, /* get_base */
1876 NULL, /* get_bufsiz */
1879 NULL, /* set_ptrcnt */
1882 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1883 sizeof(PerlIO_funcs),
1906 NULL, /* get_base */
1907 NULL, /* get_bufsiz */
1910 NULL, /* set_ptrcnt */
1912 /*--------------------------------------------------------------------------------------*/
1913 /*--------------------------------------------------------------------------------------*/
1915 * "Methods" of the "base class"
1919 PerlIOBase_fileno(pTHX_ PerlIO *f)
1921 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1925 PerlIO_modestr(PerlIO * f, char *buf)
1928 if (PerlIOValid(f)) {
1929 const IV flags = PerlIOBase(f)->flags;
1930 if (flags & PERLIO_F_APPEND) {
1932 if (flags & PERLIO_F_CANREAD) {
1936 else if (flags & PERLIO_F_CANREAD) {
1938 if (flags & PERLIO_F_CANWRITE)
1941 else if (flags & PERLIO_F_CANWRITE) {
1943 if (flags & PERLIO_F_CANREAD) {
1947 #ifdef PERLIO_USING_CRLF
1948 if (!(flags & PERLIO_F_CRLF))
1958 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1960 PerlIOl * const l = PerlIOBase(f);
1961 PERL_UNUSED_CONTEXT;
1962 PERL_UNUSED_ARG(arg);
1964 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1965 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1966 if (tab && tab->Set_ptrcnt != NULL)
1967 l->flags |= PERLIO_F_FASTGETS;
1969 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1973 l->flags |= PERLIO_F_CANREAD;
1976 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1979 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1982 SETERRNO(EINVAL, LIB_INVARG);
1987 /* The mode variable contains one positional parameter followed by
1988 * optional keyword parameters. The positional parameters must be
1989 * passed as lowercase characters. The keyword parameters can be
1990 * passed in mixed case. They must be separated by commas. Only one
1991 * instance of a keyword can be specified. */
1997 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2001 l->flags &= ~PERLIO_F_CRLF;
2005 l->flags |= PERLIO_F_CRLF;
2019 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2022 l->flags &= ~PERLIO_F_CRLF;
2025 l->flags |= PERLIO_F_CRLF;
2028 SETERRNO(EINVAL, LIB_INVARG);
2036 l->flags |= l->next->flags &
2037 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2043 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2044 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2045 l->flags, PerlIO_modestr(f, temp));
2052 PerlIOBase_popped(pTHX_ PerlIO *f)
2054 PERL_UNUSED_CONTEXT;
2060 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2063 * Save the position as current head considers it
2065 const Off_t old = PerlIO_tell(f);
2066 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2067 PerlIOSelf(f, PerlIOBuf)->posn = old;
2068 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2072 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2074 STDCHAR *buf = (STDCHAR *) vbuf;
2076 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2077 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2078 SETERRNO(EBADF, SS_IVCHAN);
2079 PerlIO_save_errno(f);
2085 SSize_t avail = PerlIO_get_cnt(f);
2088 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2090 STDCHAR *ptr = PerlIO_get_ptr(f);
2091 Copy(ptr, buf, take, STDCHAR);
2092 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2095 if (avail == 0) /* set_ptrcnt could have reset avail */
2098 if (count > 0 && avail <= 0) {
2099 if (PerlIO_fill(f) != 0)
2104 return (buf - (STDCHAR *) vbuf);
2110 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2112 PERL_UNUSED_CONTEXT;
2118 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2120 PERL_UNUSED_CONTEXT;
2126 PerlIOBase_close(pTHX_ PerlIO *f)
2129 if (PerlIOValid(f)) {
2130 PerlIO *n = PerlIONext(f);
2131 code = PerlIO_flush(f);
2132 PerlIOBase(f)->flags &=
2133 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2134 while (PerlIOValid(n)) {
2135 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2136 if (tab && tab->Close) {
2137 if ((*tab->Close)(aTHX_ n) != 0)
2142 PerlIOBase(n)->flags &=
2143 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2149 SETERRNO(EBADF, SS_IVCHAN);
2155 PerlIOBase_eof(pTHX_ PerlIO *f)
2157 PERL_UNUSED_CONTEXT;
2158 if (PerlIOValid(f)) {
2159 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2165 PerlIOBase_error(pTHX_ PerlIO *f)
2167 PERL_UNUSED_CONTEXT;
2168 if (PerlIOValid(f)) {
2169 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2175 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2177 if (PerlIOValid(f)) {
2178 PerlIO * const n = PerlIONext(f);
2179 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2186 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2188 PERL_UNUSED_CONTEXT;
2189 if (PerlIOValid(f)) {
2190 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2195 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2201 arg = sv_dup(arg, param);
2202 SvREFCNT_inc_simple_void_NN(arg);
2206 return newSVsv(arg);
2209 PERL_UNUSED_ARG(param);
2210 return newSVsv(arg);
2215 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2217 PerlIO * const nexto = PerlIONext(o);
2218 if (PerlIOValid(nexto)) {
2219 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2220 if (tab && tab->Dup)
2221 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2223 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2226 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2230 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2232 (void*)f, (void*)o, (void*)param) );
2234 arg = (*self->Getarg)(aTHX_ o, param, flags);
2235 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2236 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2237 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2243 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2245 /* Must be called with PL_perlio_mutex locked. */
2247 S_more_refcounted_fds(pTHX_ const int new_fd)
2248 PERL_TSA_REQUIRES(PL_perlio_mutex)
2251 const int old_max = PL_perlio_fd_refcnt_size;
2252 const int new_max = 16 + (new_fd & ~15);
2255 #ifndef PERL_IMPLICIT_SYS
2256 PERL_UNUSED_CONTEXT;
2259 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2260 old_max, new_fd, new_max) );
2262 if (new_fd < old_max) {
2266 assert (new_max > new_fd);
2268 /* Use plain realloc() since we need this memory to be really
2269 * global and visible to all the interpreters and/or threads. */
2270 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2273 MUTEX_UNLOCK(&PL_perlio_mutex);
2277 PL_perlio_fd_refcnt_size = new_max;
2278 PL_perlio_fd_refcnt = new_array;
2280 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2281 (void*)(new_array + old_max),
2282 new_max - old_max) );
2284 Zero(new_array + old_max, new_max - old_max, int);
2291 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2292 PERL_UNUSED_CONTEXT;
2296 PerlIOUnix_refcnt_inc(int fd)
2302 MUTEX_LOCK(&PL_perlio_mutex);
2303 if (fd >= PL_perlio_fd_refcnt_size)
2304 S_more_refcounted_fds(aTHX_ fd);
2306 PL_perlio_fd_refcnt[fd]++;
2307 if (PL_perlio_fd_refcnt[fd] <= 0) {
2308 /* diag_listed_as: refcnt_inc: fd %d%s */
2309 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2310 fd, PL_perlio_fd_refcnt[fd]);
2312 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2313 fd, PL_perlio_fd_refcnt[fd]) );
2315 MUTEX_UNLOCK(&PL_perlio_mutex);
2317 /* diag_listed_as: refcnt_inc: fd %d%s */
2318 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2323 PerlIOUnix_refcnt_dec(int fd)
2332 MUTEX_LOCK(&PL_perlio_mutex);
2333 if (fd >= PL_perlio_fd_refcnt_size) {
2334 /* diag_listed_as: refcnt_dec: fd %d%s */
2335 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2336 fd, PL_perlio_fd_refcnt_size);
2338 if (PL_perlio_fd_refcnt[fd] <= 0) {
2339 /* diag_listed_as: refcnt_dec: fd %d%s */
2340 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2341 fd, PL_perlio_fd_refcnt[fd]);
2343 cnt = --PL_perlio_fd_refcnt[fd];
2344 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2345 MUTEX_UNLOCK(&PL_perlio_mutex);
2347 /* diag_listed_as: refcnt_dec: fd %d%s */
2348 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2354 PerlIOUnix_refcnt(int fd)
2360 MUTEX_LOCK(&PL_perlio_mutex);
2361 if (fd >= PL_perlio_fd_refcnt_size) {
2362 /* diag_listed_as: refcnt: fd %d%s */
2363 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2364 fd, PL_perlio_fd_refcnt_size);
2366 if (PL_perlio_fd_refcnt[fd] <= 0) {
2367 /* diag_listed_as: refcnt: fd %d%s */
2368 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2369 fd, PL_perlio_fd_refcnt[fd]);
2371 cnt = PL_perlio_fd_refcnt[fd];
2372 MUTEX_UNLOCK(&PL_perlio_mutex);
2374 /* diag_listed_as: refcnt: fd %d%s */
2375 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2381 PerlIO_cleanup(pTHX)
2385 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2387 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2390 /* Raise STDIN..STDERR refcount so we don't close them */
2391 for (i=0; i < 3; i++)
2392 PerlIOUnix_refcnt_inc(i);
2393 PerlIO_cleantable(aTHX_ &PL_perlio);
2394 /* Restore STDIN..STDERR refcount */
2395 for (i=0; i < 3; i++)
2396 PerlIOUnix_refcnt_dec(i);
2398 if (PL_known_layers) {
2399 PerlIO_list_free(aTHX_ PL_known_layers);
2400 PL_known_layers = NULL;
2402 if (PL_def_layerlist) {
2403 PerlIO_list_free(aTHX_ PL_def_layerlist);
2404 PL_def_layerlist = NULL;
2408 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2412 /* XXX we can't rely on an interpreter being present at this late stage,
2413 XXX so we can't use a function like PerlLIO_write that relies on one
2414 being present (at least in win32) :-(.
2419 /* By now all filehandles should have been closed, so any
2420 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2422 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2423 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2424 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2426 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2427 if (PL_perlio_fd_refcnt[i]) {
2429 my_snprintf(buf, sizeof(buf),
2430 "PerlIO_teardown: fd %d refcnt=%d\n",
2431 i, PL_perlio_fd_refcnt[i]);
2432 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2438 /* Not bothering with PL_perlio_mutex since by now
2439 * all the interpreters are gone. */
2440 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2441 && PL_perlio_fd_refcnt) {
2442 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2443 PL_perlio_fd_refcnt = NULL;
2444 PL_perlio_fd_refcnt_size = 0;
2448 /*--------------------------------------------------------------------------------------*/
2450 * Bottom-most level for UNIX-like case
2454 struct _PerlIO base; /* The generic part */
2455 int fd; /* UNIX like file descriptor */
2456 int oflags; /* open/fcntl flags */
2460 S_lockcnt_dec(pTHX_ const void* f)
2462 #ifndef PERL_IMPLICIT_SYS
2463 PERL_UNUSED_CONTEXT;
2465 PerlIO_lockcnt((PerlIO*)f)--;
2469 /* call the signal handler, and if that handler happens to clear
2470 * this handle, free what we can and return true */
2473 S_perlio_async_run(pTHX_ PerlIO* f) {
2475 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2476 PerlIO_lockcnt(f)++;
2478 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2482 /* we've just run some perl-level code that could have done
2483 * anything, including closing the file or clearing this layer.
2484 * If so, free any lower layers that have already been
2485 * cleared, then return an error. */
2486 while (PerlIOValid(f) &&
2487 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2489 const PerlIOl *l = *f;
2498 PerlIOUnix_oflags(const char *mode)
2501 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2506 if (*++mode == '+') {
2513 oflags = O_CREAT | O_TRUNC;
2514 if (*++mode == '+') {
2523 oflags = O_CREAT | O_APPEND;
2524 if (*++mode == '+') {
2533 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2535 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2536 * of them in, and then bit-and-masking the other them away, won't
2537 * have much of an effect. */
2540 #if O_TEXT != O_BINARY
2547 #if O_TEXT != O_BINARY
2549 oflags &= ~O_BINARY;
2555 /* bit-or:ing with zero O_BINARY would be useless. */
2557 * If neither "t" nor "b" was specified, open the file
2560 * Note that if something else than the zero byte was seen
2561 * here (e.g. bogus mode "rx"), just few lines later we will
2562 * set the errno and invalidate the flags.
2568 if (*mode || oflags == -1) {
2569 SETERRNO(EINVAL, LIB_INVARG);
2576 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2578 PERL_UNUSED_CONTEXT;
2579 return PerlIOSelf(f, PerlIOUnix)->fd;
2583 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2585 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2588 if (PerlLIO_fstat(fd, &st) == 0) {
2589 if (!S_ISREG(st.st_mode)) {
2590 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2591 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2594 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2600 PerlIOUnix_refcnt_inc(fd);
2601 PERL_UNUSED_CONTEXT;
2605 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2607 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2608 if (*PerlIONext(f)) {
2609 /* We never call down so do any pending stuff now */
2610 PerlIO_flush(PerlIONext(f));
2612 * XXX could (or should) we retrieve the oflags from the open file
2613 * handle rather than believing the "mode" we are passed in? XXX
2614 * Should the value on NULL mode be 0 or -1?
2616 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2617 mode ? PerlIOUnix_oflags(mode) : -1);
2619 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2625 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2627 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2629 PERL_UNUSED_CONTEXT;
2630 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2632 SETERRNO(ESPIPE, LIB_INVARG);
2634 SETERRNO(EINVAL, LIB_INVARG);
2638 new_loc = PerlLIO_lseek(fd, offset, whence);
2639 if (new_loc == (Off_t) - 1)
2641 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2646 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2647 IV n, const char *mode, int fd, int imode,
2648 int perm, PerlIO *f, int narg, SV **args)
2650 if (PerlIOValid(f)) {
2651 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2652 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2655 if (*mode == IoTYPE_NUMERIC)
2658 imode = PerlIOUnix_oflags(mode);
2660 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2667 const char *path = SvPV_const(*args, len);
2668 if (!IS_SAFE_PATHNAME(path, len, "open"))
2670 fd = PerlLIO_open3(path, imode, perm);
2674 if (*mode == IoTYPE_IMPLICIT)
2677 f = PerlIO_allocate(aTHX);
2679 if (!PerlIOValid(f)) {
2680 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2685 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2686 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2687 if (*mode == IoTYPE_APPEND)
2688 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2695 * FIXME: pop layers ???
2703 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2705 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2707 if (flags & PERLIO_DUP_FD) {
2708 fd = PerlLIO_dup(fd);
2711 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2713 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2714 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2724 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2727 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2729 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2730 #ifdef PERLIO_STD_SPECIAL
2732 return PERLIO_STD_IN(fd, vbuf, count);
2734 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2735 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2739 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2740 if (len >= 0 || errno != EINTR) {
2742 if (errno != EAGAIN) {
2743 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2744 PerlIO_save_errno(f);
2747 else if (len == 0 && count != 0) {
2748 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2754 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2757 NOT_REACHED; /*NOTREACHED*/
2761 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2764 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2766 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2767 #ifdef PERLIO_STD_SPECIAL
2768 if (fd == 1 || fd == 2)
2769 return PERLIO_STD_OUT(fd, vbuf, count);
2772 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2773 if (len >= 0 || errno != EINTR) {
2775 if (errno != EAGAIN) {
2776 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2777 PerlIO_save_errno(f);
2783 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2786 NOT_REACHED; /*NOTREACHED*/
2790 PerlIOUnix_tell(pTHX_ PerlIO *f)
2792 PERL_UNUSED_CONTEXT;
2794 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2799 PerlIOUnix_close(pTHX_ PerlIO *f)
2801 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2803 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2804 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2805 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2810 SETERRNO(EBADF,SS_IVCHAN);
2813 while (PerlLIO_close(fd) != 0) {
2814 if (errno != EINTR) {
2819 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2823 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2828 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2829 sizeof(PerlIO_funcs),
2836 PerlIOBase_binmode, /* binmode */
2846 PerlIOBase_noop_ok, /* flush */
2847 PerlIOBase_noop_fail, /* fill */
2850 PerlIOBase_clearerr,
2851 PerlIOBase_setlinebuf,
2852 NULL, /* get_base */
2853 NULL, /* get_bufsiz */
2856 NULL, /* set_ptrcnt */
2859 /*--------------------------------------------------------------------------------------*/
2864 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2865 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2866 broken by the last second glibc 2.3 fix
2868 #define STDIO_BUFFER_WRITABLE
2873 struct _PerlIO base;
2874 FILE *stdio; /* The stream */
2878 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2880 PERL_UNUSED_CONTEXT;
2882 if (PerlIOValid(f)) {
2883 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2885 return PerlSIO_fileno(s);
2892 PerlIOStdio_mode(const char *mode, char *tmode)
2894 char * const ret = tmode;
2900 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2908 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2911 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2912 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2913 if (toptab == tab) {
2914 /* Top is already stdio - pop self (duplicate) and use original */
2915 PerlIO_pop(aTHX_ f);
2918 const int fd = PerlIO_fileno(n);
2921 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2922 mode = PerlIOStdio_mode(mode, tmode)))) {
2923 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2924 /* We never call down so do any pending stuff now */
2925 PerlIO_flush(PerlIONext(f));
2926 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2933 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2938 PerlIO_importFILE(FILE *stdio, const char *mode)
2944 char filename[FILENAME_MAX];
2949 int fd0 = fileno(stdio);
2952 rc = fldata(stdio,filename,&fileinfo);
2956 if(fileinfo.__dsorgHFS){
2959 /*This MVS dataset , OK!*/
2964 if (!mode || !*mode) {
2965 /* We need to probe to see how we can open the stream
2966 so start with read/write and then try write and read
2967 we dup() so that we can fclose without loosing the fd.
2969 Note that the errno value set by a failing fdopen
2970 varies between stdio implementations.
2972 const int fd = PerlLIO_dup(fd0);
2977 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2979 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2982 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2985 /* Don't seem to be able to open */
2991 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2992 s = PerlIOSelf(f, PerlIOStdio);
2995 fd0 = fileno(stdio);
2997 PerlIOUnix_refcnt_inc(fd0);
3000 rc = fldata(stdio,filename,&fileinfo);
3002 PerlIOUnix_refcnt_inc(fd0);
3004 if(fileinfo.__dsorgHFS){
3005 PerlIOUnix_refcnt_inc(fd0);
3007 /*This MVS dataset , OK!*/
3010 PerlIOUnix_refcnt_inc(fileno(stdio));
3018 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3019 IV n, const char *mode, int fd, int imode,
3020 int perm, PerlIO *f, int narg, SV **args)
3023 if (PerlIOValid(f)) {
3025 const char * const path = SvPV_const(*args, len);
3026 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3028 if (!IS_SAFE_PATHNAME(path, len, "open"))
3030 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3031 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3036 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3042 const char * const path = SvPV_const(*args, len);
3043 if (!IS_SAFE_PATHNAME(path, len, "open"))
3045 if (*mode == IoTYPE_NUMERIC) {
3047 fd = PerlLIO_open3(path, imode, perm);
3051 bool appended = FALSE;
3053 /* Cygwin wants its 'b' early. */
3055 mode = PerlIOStdio_mode(mode, tmode);
3057 stdio = PerlSIO_fopen(path, mode);
3060 f = PerlIO_allocate(aTHX);
3063 mode = PerlIOStdio_mode(mode, tmode);
3064 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3066 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3067 PerlIOUnix_refcnt_inc(fileno(stdio));
3069 PerlSIO_fclose(stdio);
3081 if (*mode == IoTYPE_IMPLICIT) {
3088 stdio = PerlSIO_stdin;
3091 stdio = PerlSIO_stdout;
3094 stdio = PerlSIO_stderr;
3099 stdio = PerlSIO_fdopen(fd, mode =
3100 PerlIOStdio_mode(mode, tmode));
3104 f = PerlIO_allocate(aTHX);
3106 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3107 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3108 PerlIOUnix_refcnt_inc(fileno(stdio));
3119 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3121 /* This assumes no layers underneath - which is what
3122 happens, but is not how I remember it. NI-S 2001/10/16
3124 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3125 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3126 const int fd = fileno(stdio);
3128 if (flags & PERLIO_DUP_FD) {
3129 const int dfd = PerlLIO_dup(fileno(stdio));
3131 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3136 /* FIXME: To avoid messy error recovery if dup fails
3137 re-use the existing stdio as though flag was not set
3141 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3143 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3145 PerlIOUnix_refcnt_inc(fileno(stdio));
3152 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3154 PERL_UNUSED_CONTEXT;
3156 /* XXX this could use PerlIO_canset_fileno() and
3157 * PerlIO_set_fileno() support from Configure
3159 # if defined(HAS_FDCLOSE)
3160 return fdclose(f, NULL) == 0 ? 1 : 0;
3161 # elif defined(__UCLIBC__)
3162 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3165 # elif defined(__GLIBC__)
3166 /* There may be a better way for GLIBC:
3167 - libio.h defines a flag to not close() on cleanup
3171 # elif defined(__sun)
3174 # elif defined(__hpux)
3178 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3179 your platform does not have special entry try this one.
3180 [For OSF only have confirmation for Tru64 (alpha)
3181 but assume other OSFs will be similar.]
3183 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3186 # elif defined(__FreeBSD__)
3187 /* There may be a better way on FreeBSD:
3188 - we could insert a dummy func in the _close function entry
3189 f->_close = (int (*)(void *)) dummy_close;
3193 # elif defined(__OpenBSD__)
3194 /* There may be a better way on OpenBSD:
3195 - we could insert a dummy func in the _close function entry
3196 f->_close = (int (*)(void *)) dummy_close;
3200 # elif defined(__EMX__)
3201 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3204 # elif defined(__CYGWIN__)
3205 /* There may be a better way on CYGWIN:
3206 - we could insert a dummy func in the _close function entry
3207 f->_close = (int (*)(void *)) dummy_close;
3211 # elif defined(WIN32)
3212 # if defined(UNDER_CE)
3213 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3217 PERLIO_FILE_file(f) = -1;
3222 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3223 (which isn't thread safe) instead
3225 # error "Don't know how to set FILE.fileno on your platform"
3233 PerlIOStdio_close(pTHX_ PerlIO *f)
3235 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3241 const int fd = fileno(stdio);
3249 #ifdef SOCKS5_VERSION_NAME
3250 /* Socks lib overrides close() but stdio isn't linked to
3251 that library (though we are) - so we must call close()
3252 on sockets on stdio's behalf.
3255 Sock_size_t optlen = sizeof(int);
3256 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3259 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3260 that a subsequent fileno() on it returns -1. Don't want to croak()
3261 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3262 trying to close an already closed handle which somehow it still has
3263 a reference to. (via.xs, I'm looking at you). */
3264 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3265 /* File descriptor still in use */
3269 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3270 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3272 if (stdio == stdout || stdio == stderr)
3273 return PerlIO_flush(f);
3275 MUTEX_LOCK(&PL_perlio_mutex);
3276 /* Right. We need a mutex here because for a brief while we
3277 will have the situation that fd is actually closed. Hence if
3278 a second thread were to get into this block, its dup() would
3279 likely return our fd as its dupfd. (after all, it is closed)
3280 Then if we get to the dup2() first, we blat the fd back
3281 (messing up its temporary as a side effect) only for it to
3282 then close its dupfd (== our fd) in its close(dupfd) */
3284 /* There is, of course, a race condition, that any other thread
3285 trying to input/output/whatever on this fd will be stuffed
3286 for the duration of this little manoeuvrer. Perhaps we
3287 should hold an IO mutex for the duration of every IO
3288 operation if we know that invalidate doesn't work on this
3289 platform, but that would suck, and could kill performance.
3291 Except that correctness trumps speed.
3292 Advice from klortho #11912. */
3294 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3295 Use Sarathy's trick from maint-5.6 to invalidate the
3296 fileno slot of the FILE *
3298 result = PerlIO_flush(f);
3300 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3302 dupfd = PerlLIO_dup(fd);
3305 /* Oh cXap. This isn't going to go well. Not sure if we can
3306 recover from here, or if closing this particular FILE *
3307 is a good idea now. */
3312 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3314 result = PerlSIO_fclose(stdio);
3315 /* We treat error from stdio as success if we invalidated
3316 errno may NOT be expected EBADF
3318 if (invalidate && result != 0) {
3322 #ifdef SOCKS5_VERSION_NAME
3323 /* in SOCKS' case, let close() determine return value */
3327 PerlLIO_dup2(dupfd,fd);
3328 PerlLIO_close(dupfd);
3330 MUTEX_UNLOCK(&PL_perlio_mutex);
3336 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3340 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3342 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3345 STDCHAR *buf = (STDCHAR *) vbuf;
3347 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3348 * stdio does not do that for fread()
3350 const int ch = PerlSIO_fgetc(s);
3357 got = PerlSIO_fread(vbuf, 1, count, s);
3358 if (got == 0 && PerlSIO_ferror(s))
3360 if (got >= 0 || errno != EINTR)
3362 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3364 SETERRNO(0,0); /* just in case */
3367 /* Under some circumstances IRIX stdio fgetc() and fread()
3368 * set the errno to ENOENT, which makes no sense according
3369 * to either IRIX or POSIX. [rt.perl.org #123977] */
3370 if (errno == ENOENT) SETERRNO(0,0);
3376 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3379 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3381 #ifdef STDIO_BUFFER_WRITABLE
3382 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3383 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3384 STDCHAR *base = PerlIO_get_base(f);
3385 SSize_t cnt = PerlIO_get_cnt(f);
3386 STDCHAR *ptr = PerlIO_get_ptr(f);
3387 SSize_t avail = ptr - base;
3389 if (avail > count) {
3393 Move(buf-avail,ptr,avail,STDCHAR);
3396 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3397 if (PerlSIO_feof(s) && unread >= 0)
3398 PerlSIO_clearerr(s);
3403 if (PerlIO_has_cntptr(f)) {
3404 /* We can get pointer to buffer but not its base
3405 Do ungetc() but check chars are ending up in the
3408 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3409 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3411 const int ch = *--buf & 0xFF;
3412 if (ungetc(ch,s) != ch) {
3413 /* ungetc did not work */
3416 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3417 /* Did not change pointer as expected */
3418 if (fgetc(s) != EOF) /* get char back again */
3428 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3434 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3437 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3440 got = PerlSIO_fwrite(vbuf, 1, count,
3441 PerlIOSelf(f, PerlIOStdio)->stdio);
3442 if (got >= 0 || errno != EINTR)
3444 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3446 SETERRNO(0,0); /* just in case */
3452 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3454 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3455 PERL_UNUSED_CONTEXT;
3457 return PerlSIO_fseek(stdio, offset, whence);
3461 PerlIOStdio_tell(pTHX_ PerlIO *f)
3463 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3464 PERL_UNUSED_CONTEXT;
3466 return PerlSIO_ftell(stdio);
3470 PerlIOStdio_flush(pTHX_ PerlIO *f)
3472 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3473 PERL_UNUSED_CONTEXT;
3475 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3476 return PerlSIO_fflush(stdio);
3482 * FIXME: This discards ungetc() and pre-read stuff which is not
3483 * right if this is just a "sync" from a layer above Suspect right
3484 * design is to do _this_ but not have layer above flush this
3485 * layer read-to-read
3488 * Not writeable - sync by attempting a seek
3491 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3499 PerlIOStdio_eof(pTHX_ PerlIO *f)
3501 PERL_UNUSED_CONTEXT;
3503 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3507 PerlIOStdio_error(pTHX_ PerlIO *f)
3509 PERL_UNUSED_CONTEXT;
3511 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3515 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3517 PERL_UNUSED_CONTEXT;
3519 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3523 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3525 PERL_UNUSED_CONTEXT;
3527 #ifdef HAS_SETLINEBUF
3528 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3530 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3536 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3538 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3539 PERL_UNUSED_CONTEXT;
3540 return (STDCHAR*)PerlSIO_get_base(stdio);
3544 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3546 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3547 PERL_UNUSED_CONTEXT;
3548 return PerlSIO_get_bufsiz(stdio);
3552 #ifdef USE_STDIO_PTR
3554 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3556 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3557 PERL_UNUSED_CONTEXT;
3558 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3562 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3564 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3565 PERL_UNUSED_CONTEXT;
3566 return PerlSIO_get_cnt(stdio);
3570 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3572 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3573 PERL_UNUSED_CONTEXT;
3575 #ifdef STDIO_PTR_LVALUE
3576 /* This is a long-standing infamous mess. The root of the
3577 * problem is that one cannot know the signedness of char, and
3578 * more precisely the signedness of FILE._ptr. The following
3579 * things have been tried, and they have all failed (across
3580 * different compilers (remember that core needs to to build
3581 * also with c++) and compiler options:
3583 * - casting the RHS to (void*) -- works in *some* places
3584 * - casting the LHS to (void*) -- totally unportable
3586 * So let's try silencing the warning at least for gcc. */
3587 GCC_DIAG_IGNORE(-Wpointer-sign);
3588 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3590 #ifdef STDIO_PTR_LVAL_SETS_CNT
3591 assert(PerlSIO_get_cnt(stdio) == (cnt));
3593 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3595 * Setting ptr _does_ change cnt - we are done
3599 #else /* STDIO_PTR_LVALUE */
3601 #endif /* STDIO_PTR_LVALUE */
3604 * Now (or only) set cnt
3606 #ifdef STDIO_CNT_LVALUE
3607 PerlSIO_set_cnt(stdio, cnt);
3608 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3609 PerlSIO_set_ptr(stdio,
3610 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3612 #else /* STDIO_PTR_LVAL_SETS_CNT */
3614 #endif /* STDIO_CNT_LVALUE */
3621 PerlIOStdio_fill(pTHX_ PerlIO *f)
3625 PERL_UNUSED_CONTEXT;
3626 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3628 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3631 * fflush()ing read-only streams can cause trouble on some stdio-s
3633 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3634 if (PerlSIO_fflush(stdio) != 0)
3638 c = PerlSIO_fgetc(stdio);
3641 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3643 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3648 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3650 #ifdef STDIO_BUFFER_WRITABLE
3651 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3652 /* Fake ungetc() to the real buffer in case system's ungetc
3655 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3656 SSize_t cnt = PerlSIO_get_cnt(stdio);
3657 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3658 if (ptr == base+1) {
3659 *--ptr = (STDCHAR) c;
3660 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3661 if (PerlSIO_feof(stdio))
3662 PerlSIO_clearerr(stdio);
3668 if (PerlIO_has_cntptr(f)) {
3670 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3676 /* If buffer snoop scheme above fails fall back to
3679 if (PerlSIO_ungetc(c, stdio) != c)
3687 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3688 sizeof(PerlIO_funcs),
3690 sizeof(PerlIOStdio),
3691 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3695 PerlIOBase_binmode, /* binmode */
3709 PerlIOStdio_clearerr,
3710 PerlIOStdio_setlinebuf,
3712 PerlIOStdio_get_base,
3713 PerlIOStdio_get_bufsiz,
3718 #ifdef USE_STDIO_PTR
3719 PerlIOStdio_get_ptr,
3720 PerlIOStdio_get_cnt,
3721 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3722 PerlIOStdio_set_ptrcnt,
3725 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3730 #endif /* USE_STDIO_PTR */
3733 /* Note that calls to PerlIO_exportFILE() are reversed using
3734 * PerlIO_releaseFILE(), not importFILE. */
3736 PerlIO_exportFILE(PerlIO * f, const char *mode)
3740 if (PerlIOValid(f)) {
3742 int fd = PerlIO_fileno(f);
3747 if (!mode || !*mode) {
3748 mode = PerlIO_modestr(f, buf);
3750 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3754 /* De-link any lower layers so new :stdio sticks */
3756 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3757 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3759 PerlIOUnix_refcnt_inc(fileno(stdio));
3760 /* Link previous lower layers under new one */
3764 /* restore layers list */
3774 PerlIO_findFILE(PerlIO *f)
3779 if (l->tab == &PerlIO_stdio) {
3780 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3783 l = *PerlIONext(&l);
3785 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3786 /* However, we're not really exporting a FILE * to someone else (who
3787 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3788 So we need to undo its reference count increase on the underlying file
3789 descriptor. We have to do this, because if the loop above returns you
3790 the FILE *, then *it* didn't increase any reference count. So there's
3791 only one way to be consistent. */
3792 stdio = PerlIO_exportFILE(f, NULL);
3794 const int fd = fileno(stdio);
3796 PerlIOUnix_refcnt_dec(fd);
3801 /* Use this to reverse PerlIO_exportFILE calls. */
3803 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3807 if (l->tab == &PerlIO_stdio) {
3808 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3809 if (s->stdio == f) { /* not in a loop */
3810 const int fd = fileno(f);
3812 PerlIOUnix_refcnt_dec(fd);
3815 PerlIO_pop(aTHX_ p);
3825 /*--------------------------------------------------------------------------------------*/
3827 * perlio buffer layer
3831 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3833 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3834 const int fd = PerlIO_fileno(f);
3835 if (fd >= 0 && PerlLIO_isatty(fd)) {
3836 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3838 if (*PerlIONext(f)) {
3839 const Off_t posn = PerlIO_tell(PerlIONext(f));
3840 if (posn != (Off_t) - 1) {
3844 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3848 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3849 IV n, const char *mode, int fd, int imode, int perm,
3850 PerlIO *f, int narg, SV **args)
3852 if (PerlIOValid(f)) {
3853 PerlIO *next = PerlIONext(f);
3855 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3856 if (tab && tab->Open)
3858 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3860 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3865 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3867 if (*mode == IoTYPE_IMPLICIT) {
3873 if (tab && tab->Open)
3874 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3877 SETERRNO(EINVAL, LIB_INVARG);
3879 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3881 * if push fails during open, open fails. close will pop us.
3886 fd = PerlIO_fileno(f);
3887 if (init && fd == 2) {
3889 * Initial stderr is unbuffered
3891 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3893 #ifdef PERLIO_USING_CRLF
3894 # ifdef PERLIO_IS_BINMODE_FD
3895 if (PERLIO_IS_BINMODE_FD(fd))
3896 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3900 * do something about failing setmode()? --jhi
3902 PerlLIO_setmode(fd, O_BINARY);
3905 /* Enable line buffering with record-oriented regular files
3906 * so we don't introduce an extraneous record boundary when
3907 * the buffer fills up.
3909 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3911 if (PerlLIO_fstat(fd, &st) == 0
3912 && S_ISREG(st.st_mode)
3913 && (st.st_fab_rfm == FAB$C_VAR
3914 || st.st_fab_rfm == FAB$C_VFC)) {
3915 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3926 * This "flush" is akin to sfio's sync in that it handles files in either
3927 * read or write state. For write state, we put the postponed data through
3928 * the next layers. For read state, we seek() the next layers to the
3929 * offset given by current position in the buffer, and discard the buffer
3930 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3931 * in any case?). Then the pass the stick further in chain.
3934 PerlIOBuf_flush(pTHX_ PerlIO *f)
3936 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3938 PerlIO *n = PerlIONext(f);
3939 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3941 * write() the buffer
3943 const STDCHAR *buf = b->buf;
3944 const STDCHAR *p = buf;
3945 while (p < b->ptr) {
3946 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3950 else if (count < 0 || PerlIO_error(n)) {
3951 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3952 PerlIO_save_errno(f);
3957 b->posn += (p - buf);
3959 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3960 STDCHAR *buf = PerlIO_get_base(f);
3962 * Note position change
3964 b->posn += (b->ptr - buf);
3965 if (b->ptr < b->end) {
3966 /* We did not consume all of it - try and seek downstream to
3967 our logical position
3969 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3970 /* Reload n as some layers may pop themselves on seek */
3971 b->posn = PerlIO_tell(n = PerlIONext(f));
3974 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3975 data is lost for good - so return saying "ok" having undone
3978 b->posn -= (b->ptr - buf);
3983 b->ptr = b->end = b->buf;
3984 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3985 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3986 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3991 /* This discards the content of the buffer after b->ptr, and rereads
3992 * the buffer from the position off in the layer downstream; here off
3993 * is at offset corresponding to b->ptr - b->buf.
3996 PerlIOBuf_fill(pTHX_ PerlIO *f)
3998 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3999 PerlIO *n = PerlIONext(f);
4002 * Down-stream flush is defined not to loose read data so is harmless.
4003 * we would not normally be fill'ing if there was data left in anycase.
4005 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4007 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4008 PerlIOBase_flush_linebuf(aTHX);
4011 PerlIO_get_base(f); /* allocate via vtable */
4013 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4015 b->ptr = b->end = b->buf;
4017 if (!PerlIOValid(n)) {
4018 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4022 if (PerlIO_fast_gets(n)) {
4024 * Layer below is also buffered. We do _NOT_ want to call its
4025 * ->Read() because that will loop till it gets what we asked for
4026 * which may hang on a pipe etc. Instead take anything it has to
4027 * hand, or ask it to fill _once_.
4029 avail = PerlIO_get_cnt(n);
4031 avail = PerlIO_fill(n);
4033 avail = PerlIO_get_cnt(n);
4035 if (!PerlIO_error(n) && PerlIO_eof(n))
4040 STDCHAR *ptr = PerlIO_get_ptr(n);
4041 const SSize_t cnt = avail;
4042 if (avail > (SSize_t)b->bufsiz)
4044 Copy(ptr, b->buf, avail, STDCHAR);
4045 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4049 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4053 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4056 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4057 PerlIO_save_errno(f);
4061 b->end = b->buf + avail;
4062 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4067 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4069 if (PerlIOValid(f)) {
4070 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4073 return PerlIOBase_read(aTHX_ f, vbuf, count);
4079 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4081 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4082 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4085 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4090 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4092 * Buffer is already a read buffer, we can overwrite any chars
4093 * which have been read back to buffer start
4095 avail = (b->ptr - b->buf);
4099 * Buffer is idle, set it up so whole buffer is available for
4103 b->end = b->buf + avail;
4105 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4107 * Buffer extends _back_ from where we are now
4109 b->posn -= b->bufsiz;
4111 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4113 * If we have space for more than count, just move count
4121 * In simple stdio-like ungetc() case chars will be already
4124 if (buf != b->ptr) {
4125 Copy(buf, b->ptr, avail, STDCHAR);
4129 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4133 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4139 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4141 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4142 const STDCHAR *buf = (const STDCHAR *) vbuf;
4143 const STDCHAR *flushptr = buf;
4147 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4149 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4150 if (PerlIO_flush(f) != 0) {
4154 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4155 flushptr = buf + count;
4156 while (flushptr > buf && *(flushptr - 1) != '\n')
4160 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4161 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4163 if (flushptr > buf && flushptr <= buf + avail)
4164 avail = flushptr - buf;
4165 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4167 Copy(buf, b->ptr, avail, STDCHAR);
4172 if (buf == flushptr)
4175 if (b->ptr >= (b->buf + b->bufsiz))
4176 if (PerlIO_flush(f) == -1)
4179 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4185 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4188 if ((code = PerlIO_flush(f)) == 0) {
4189 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4190 code = PerlIO_seek(PerlIONext(f), offset, whence);
4192 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4193 b->posn = PerlIO_tell(PerlIONext(f));
4200 PerlIOBuf_tell(pTHX_ PerlIO *f)
4202 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4204 * b->posn is file position where b->buf was read, or will be written
4206 Off_t posn = b->posn;
4207 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4208 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4210 /* As O_APPEND files are normally shared in some sense it is better
4215 /* when file is NOT shared then this is sufficient */
4216 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4218 posn = b->posn = PerlIO_tell(PerlIONext(f));
4222 * If buffer is valid adjust position by amount in buffer
4224 posn += (b->ptr - b->buf);
4230 PerlIOBuf_popped(pTHX_ PerlIO *f)
4232 const IV code = PerlIOBase_popped(aTHX_ f);
4233 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4234 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4237 b->ptr = b->end = b->buf = NULL;
4238 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4243 PerlIOBuf_close(pTHX_ PerlIO *f)
4245 const IV code = PerlIOBase_close(aTHX_ f);
4246 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4247 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4250 b->ptr = b->end = b->buf = NULL;
4251 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4256 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4258 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4265 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4267 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4270 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4271 return (b->end - b->ptr);
4276 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4278 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4279 PERL_UNUSED_CONTEXT;
4283 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4284 Newxz(b->buf,b->bufsiz, STDCHAR);
4286 b->buf = (STDCHAR *) & b->oneword;
4287 b->bufsiz = sizeof(b->oneword);
4289 b->end = b->ptr = b->buf;
4295 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4297 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4300 return (b->end - b->buf);
4304 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4306 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4308 PERL_UNUSED_ARG(cnt);
4313 assert(PerlIO_get_cnt(f) == cnt);
4314 assert(b->ptr >= b->buf);
4315 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4319 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4321 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4326 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4327 sizeof(PerlIO_funcs),
4330 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4334 PerlIOBase_binmode, /* binmode */
4348 PerlIOBase_clearerr,
4349 PerlIOBase_setlinebuf,
4354 PerlIOBuf_set_ptrcnt,
4357 /*--------------------------------------------------------------------------------------*/
4359 * Temp layer to hold unread chars when cannot do it any other way
4363 PerlIOPending_fill(pTHX_ PerlIO *f)
4366 * Should never happen
4373 PerlIOPending_close(pTHX_ PerlIO *f)
4376 * A tad tricky - flush pops us, then we close new top
4379 return PerlIO_close(f);
4383 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4386 * A tad tricky - flush pops us, then we seek new top
4389 return PerlIO_seek(f, offset, whence);
4394 PerlIOPending_flush(pTHX_ PerlIO *f)
4396 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4397 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4401 PerlIO_pop(aTHX_ f);
4406 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4412 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4417 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4419 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4420 PerlIOl * const l = PerlIOBase(f);
4422 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4423 * etc. get muddled when it changes mid-string when we auto-pop.
4425 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4426 (PerlIOBase(PerlIONext(f))->
4427 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4432 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4434 SSize_t avail = PerlIO_get_cnt(f);
4436 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4439 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4440 if (got >= 0 && got < (SSize_t)count) {
4441 const SSize_t more =
4442 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4443 if (more >= 0 || got == 0)
4449 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4450 sizeof(PerlIO_funcs),
4453 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4454 PerlIOPending_pushed,
4457 PerlIOBase_binmode, /* binmode */
4466 PerlIOPending_close,
4467 PerlIOPending_flush,
4471 PerlIOBase_clearerr,
4472 PerlIOBase_setlinebuf,
4477 PerlIOPending_set_ptrcnt,
4482 /*--------------------------------------------------------------------------------------*/
4484 * crlf - translation On read translate CR,LF to "\n" we do this by
4485 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4486 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4488 * c->nl points on the first byte of CR LF pair when it is temporarily
4489 * replaced by LF, or to the last CR of the buffer. In the former case
4490 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4491 * that it ends at c->nl; these two cases can be distinguished by
4492 * *c->nl. c->nl is set during _getcnt() call, and unset during
4493 * _unread() and _flush() calls.
4494 * It only matters for read operations.
4498 PerlIOBuf base; /* PerlIOBuf stuff */
4499 STDCHAR *nl; /* Position of crlf we "lied" about in the
4503 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4504 * Otherwise the :crlf layer would always revert back to
4508 S_inherit_utf8_flag(PerlIO *f)
4510 PerlIO *g = PerlIONext(f);
4511 if (PerlIOValid(g)) {
4512 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4513 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4519 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4522 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4523 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4526 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4527 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4528 PerlIOBase(f)->flags);
4532 /* If the old top layer is a CRLF layer, reactivate it (if
4533 * necessary) and remove this new layer from the stack */
4534 PerlIO *g = PerlIONext(f);
4535 if (PerlIOValid(g)) {
4536 PerlIOl *b = PerlIOBase(g);
4537 if (b && b->tab == &PerlIO_crlf) {
4538 if (!(b->flags & PERLIO_F_CRLF))
4539 b->flags |= PERLIO_F_CRLF;
4540 S_inherit_utf8_flag(g);
4541 PerlIO_pop(aTHX_ f);
4546 S_inherit_utf8_flag(f);
4552 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4554 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4555 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4556 *(c->nl) = NATIVE_0xd;
4559 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4560 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4562 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4563 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4565 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4570 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4571 b->end = b->ptr = b->buf + b->bufsiz;
4572 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4573 b->posn -= b->bufsiz;
4575 while (count > 0 && b->ptr > b->buf) {
4576 const int ch = *--buf;
4578 if (b->ptr - 2 >= b->buf) {
4579 *--(b->ptr) = NATIVE_0xa;
4580 *--(b->ptr) = NATIVE_0xd;
4585 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4586 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4600 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4605 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4607 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4609 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4612 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4613 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4614 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4615 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4617 while (nl < b->end && *nl != NATIVE_0xd)
4619 if (nl < b->end && *nl == NATIVE_0xd) {
4621 if (nl + 1 < b->end) {
4622 if (nl[1] == NATIVE_0xa) {
4628 * Not CR,LF but just CR
4636 * Blast - found CR as last char in buffer
4641 * They may not care, defer work as long as
4645 return (nl - b->ptr);
4649 b->ptr++; /* say we have read it as far as
4650 * flush() is concerned */
4651 b->buf++; /* Leave space in front of buffer */
4652 /* Note as we have moved buf up flush's
4654 will naturally make posn point at CR
4656 b->bufsiz--; /* Buffer is thus smaller */
4657 code = PerlIO_fill(f); /* Fetch some more */
4658 b->bufsiz++; /* Restore size for next time */
4659 b->buf--; /* Point at space */
4660 b->ptr = nl = b->buf; /* Which is what we hand
4662 *nl = NATIVE_0xd; /* Fill in the CR */
4664 goto test; /* fill() call worked */
4666 * CR at EOF - just fall through
4668 /* Should we clear EOF though ??? */
4673 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4679 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4681 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4682 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4688 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4689 /* Deferred CR at end of buffer case - we lied about count */
4702 * Test code - delete when it works ...
4704 IV flags = PerlIOBase(f)->flags;
4705 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4706 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4707 /* Deferred CR at end of buffer case - we lied about count */
4713 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4714 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4715 flags, c->nl, b->end, cnt);
4722 * They have taken what we lied about
4724 *(c->nl) = NATIVE_0xd;
4730 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4734 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4736 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4737 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4739 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4740 const STDCHAR *buf = (const STDCHAR *) vbuf;
4741 const STDCHAR * const ebuf = buf + count;
4744 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4746 while (buf < ebuf) {
4747 const STDCHAR * const eptr = b->buf + b->bufsiz;
4748 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4749 while (buf < ebuf && b->ptr < eptr) {
4751 if ((b->ptr + 2) > eptr) {
4759 *(b->ptr)++ = NATIVE_0xd; /* CR */
4760 *(b->ptr)++ = NATIVE_0xa; /* LF */
4762 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4769 *(b->ptr)++ = *buf++;
4771 if (b->ptr >= eptr) {
4777 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4779 return (buf - (STDCHAR *) vbuf);
4784 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4786 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4788 *(c->nl) = NATIVE_0xd;
4791 return PerlIOBuf_flush(aTHX_ f);
4795 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4797 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4798 /* In text mode - flush any pending stuff and flip it */
4799 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4800 #ifndef PERLIO_USING_CRLF
4801 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4802 PerlIO_pop(aTHX_ f);
4808 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4809 sizeof(PerlIO_funcs),
4812 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4814 PerlIOBuf_popped, /* popped */
4816 PerlIOCrlf_binmode, /* binmode */
4820 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4821 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4822 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4830 PerlIOBase_clearerr,
4831 PerlIOBase_setlinebuf,
4836 PerlIOCrlf_set_ptrcnt,
4840 Perl_PerlIO_stdin(pTHX)
4843 PerlIO_stdstreams(aTHX);
4845 return (PerlIO*)&PL_perlio[1];
4849 Perl_PerlIO_stdout(pTHX)
4852 PerlIO_stdstreams(aTHX);
4854 return (PerlIO*)&PL_perlio[2];
4858 Perl_PerlIO_stderr(pTHX)
4861 PerlIO_stdstreams(aTHX);
4863 return (PerlIO*)&PL_perlio[3];
4866 /*--------------------------------------------------------------------------------------*/
4869 PerlIO_getname(PerlIO *f, char *buf)
4874 bool exported = FALSE;
4875 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4877 stdio = PerlIO_exportFILE(f,0);
4881 name = fgetname(stdio, buf);
4882 if (exported) PerlIO_releaseFILE(f,stdio);
4887 PERL_UNUSED_ARG(buf);
4888 Perl_croak_nocontext("Don't know how to get file name");
4894 /*--------------------------------------------------------------------------------------*/
4896 * Functions which can be called on any kind of PerlIO implemented in
4900 #undef PerlIO_fdopen
4902 PerlIO_fdopen(int fd, const char *mode)
4905 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4910 PerlIO_open(const char *path, const char *mode)
4913 SV *name = sv_2mortal(newSVpv(path, 0));
4914 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4917 #undef Perlio_reopen
4919 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4922 SV *name = sv_2mortal(newSVpv(path,0));
4923 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4928 PerlIO_getc(PerlIO *f)
4932 if ( 1 == PerlIO_read(f, buf, 1) ) {
4933 return (unsigned char) buf[0];
4938 #undef PerlIO_ungetc
4940 PerlIO_ungetc(PerlIO *f, int ch)
4945 if (PerlIO_unread(f, &buf, 1) == 1)
4953 PerlIO_putc(PerlIO *f, int ch)
4957 return PerlIO_write(f, &buf, 1);
4962 PerlIO_puts(PerlIO *f, const char *s)
4965 return PerlIO_write(f, s, strlen(s));
4968 #undef PerlIO_rewind
4970 PerlIO_rewind(PerlIO *f)
4973 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4977 #undef PerlIO_vprintf
4979 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4988 Perl_va_copy(ap, apc);
4989 sv = vnewSVpvf(fmt, &apc);
4992 sv = vnewSVpvf(fmt, &ap);
4994 s = SvPV_const(sv, len);
4995 wrote = PerlIO_write(f, s, len);
5000 #undef PerlIO_printf
5002 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5007 result = PerlIO_vprintf(f, fmt, ap);
5012 #undef PerlIO_stdoutf
5014 PerlIO_stdoutf(const char *fmt, ...)
5020 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5025 #undef PerlIO_tmpfile
5027 PerlIO_tmpfile(void)
5034 const int fd = win32_tmpfd();
5036 f = PerlIO_fdopen(fd, "w+b");
5037 #elif defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5039 char tempname[] = "/tmp/PerlIO_XXXXXX";
5040 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5042 int old_umask = umask(0177);
5044 * I have no idea how portable mkstemp() is ... NI-S
5046 if (tmpdir && *tmpdir) {
5047 /* if TMPDIR is set and not empty, we try that first */
5048 sv = newSVpv(tmpdir, 0);
5049 sv_catpv(sv, tempname + 4);
5050 fd = mkstemp(SvPVX(sv));
5055 /* else we try /tmp */
5056 fd = mkstemp(tempname);
5061 sv_catpv(sv, tempname + 4);
5062 fd = mkstemp(SvPVX(sv));
5066 f = PerlIO_fdopen(fd, "w+");
5068 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5069 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5072 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5073 FILE * const stdio = PerlSIO_tmpfile();
5076 f = PerlIO_fdopen(fileno(stdio), "w+");
5078 #endif /* else WIN32 */
5083 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5085 PERL_UNUSED_CONTEXT;
5086 if (!PerlIOValid(f))
5088 PerlIOBase(f)->err = errno;
5090 PerlIOBase(f)->os_err = vaxc$errno;
5092 PerlIOBase(f)->os_err = Perl_rc;
5093 #elif defined(WIN32)
5094 PerlIOBase(f)->os_err = GetLastError();
5099 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5101 PERL_UNUSED_CONTEXT;
5102 if (!PerlIOValid(f))
5104 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5106 Perl_rc = PerlIOBase(f)->os_err);
5107 #elif defined(WIN32)
5108 SetLastError(PerlIOBase(f)->os_err);
5116 /*======================================================================================*/
5118 * Now some functions in terms of above which may be needed even if we are
5119 * not in true PerlIO mode
5122 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5124 const char *direction = NULL;
5127 * Need to supply default layer info from open.pm
5133 if (mode && mode[0] != 'r') {
5134 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5135 direction = "open>";
5137 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5138 direction = "open<";
5143 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5146 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5151 #undef PerlIO_setpos
5153 PerlIO_setpos(PerlIO *f, SV *pos)
5159 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5160 if(len == sizeof(Off_t))
5161 return PerlIO_seek(f, *posn, SEEK_SET);
5164 SETERRNO(EINVAL, SS_IVCHAN);
5168 #undef PerlIO_setpos
5170 PerlIO_setpos(PerlIO *f, SV *pos)
5176 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5177 if(len == sizeof(Fpos_t))
5178 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5179 return fsetpos64(f, fpos);
5181 return fsetpos(f, fpos);
5185 SETERRNO(EINVAL, SS_IVCHAN);
5191 #undef PerlIO_getpos
5193 PerlIO_getpos(PerlIO *f, SV *pos)
5196 Off_t posn = PerlIO_tell(f);
5197 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5198 return (posn == (Off_t) - 1) ? -1 : 0;
5201 #undef PerlIO_getpos
5203 PerlIO_getpos(PerlIO *f, SV *pos)
5208 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5209 code = fgetpos64(f, &fpos);
5211 code = fgetpos(f, &fpos);
5213 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5218 /* print a failure format string message to stderr and fail exit the process
5219 using only libc without depending on any perl data structures being
5224 Perl_noperl_die(const char* pat, ...)
5227 PERL_ARGS_ASSERT_NOPERL_DIE;
5228 va_start(arglist, pat);
5229 vfprintf(stderr, pat, arglist);
5235 * ex: set ts=8 sts=4 sw=4 et: