3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
17 /* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
28 #ifdef PERL_IMPLICIT_SYS
34 #define PERLIO_NOT_STDIO 0
36 * This file provides those parts of PerlIO abstraction
37 * which are not #defined in perlio.h.
38 * Which these are depends on various Configure #ifdef's
42 #define PERL_IN_PERLIO_C
45 #ifdef PERL_IMPLICIT_CONTEXT
53 /* Missing proto on LynxOS */
61 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
63 /* Call the callback or PerlIOBase, and return failure. */
64 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
65 if (PerlIOValid(f)) { \
66 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
67 if (tab && tab->callback) \
68 return (*tab->callback) args; \
70 return PerlIOBase_ ## base args; \
73 SETERRNO(EBADF, SS_IVCHAN); \
76 /* Call the callback or fail, and return failure. */
77 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
78 if (PerlIOValid(f)) { \
79 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
80 if (tab && tab->callback) \
81 return (*tab->callback) args; \
82 SETERRNO(EINVAL, LIB_INVARG); \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or PerlIOBase, and be void. */
89 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 (*tab->callback) args; \
95 PerlIOBase_ ## base args; \
98 SETERRNO(EBADF, SS_IVCHAN)
100 /* Call the callback or fail, and be void. */
101 #define Perl_PerlIO_or_fail_void(f, callback, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 SETERRNO(EINVAL, LIB_INVARG); \
110 SETERRNO(EBADF, SS_IVCHAN)
112 #if defined(__osf__) && _XOPEN_SOURCE < 500
113 extern int fseeko(FILE *, off_t, int);
114 extern off_t ftello(FILE *);
117 #define NATIVE_0xd CR_NATIVE
118 #define NATIVE_0xa LF_NATIVE
120 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
123 perlsio_binmode(FILE *fp, int iotype, int mode)
126 * This used to be contents of do_binmode in doio.c
130 PERL_UNUSED_ARG(iotype);
132 if (PerlLIO_setmode(fp, mode) != -1) {
134 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
141 # if defined(USEMYBINMODE)
143 # if defined(__CYGWIN__)
144 PERL_UNUSED_ARG(iotype);
146 if (my_binmode(fp, iotype, mode) != FALSE)
152 PERL_UNUSED_ARG(iotype);
153 PERL_UNUSED_ARG(mode);
160 #define O_ACCMODE 3 /* Assume traditional implementation */
164 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
166 const int result = rawmode & O_ACCMODE;
171 ptype = IoTYPE_RDONLY;
174 ptype = IoTYPE_WRONLY;
182 *writing = (result != O_RDONLY);
184 if (result == O_RDONLY) {
188 else if (rawmode & O_APPEND) {
190 if (result != O_WRONLY)
195 if (result == O_WRONLY)
203 /* Unless O_BINARY is different from zero, bit-and:ing
204 * with it won't do much good. */
205 if (rawmode & O_BINARY)
212 #ifndef PERLIO_LAYERS
214 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
216 if (!names || !*names
217 || strEQ(names, ":crlf")
218 || strEQ(names, ":raw")
219 || strEQ(names, ":bytes")
223 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
231 PerlIO_destruct(pTHX)
236 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
238 return perlsio_binmode(fp, iotype, mode);
242 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
244 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
247 #ifdef PERL_IMPLICIT_SYS
248 return PerlSIO_fdupopen(f);
251 return win32_fdupopen(f);
254 const int fd = PerlLIO_dup(PerlIO_fileno(f));
258 const int omode = djgpp_get_stream_mode(f);
260 const int omode = fcntl(fd, F_GETFL);
262 PerlIO_intmode2str(omode,mode,NULL);
263 /* the r+ is a hack */
264 return PerlIO_fdopen(fd, mode);
269 SETERRNO(EBADF, SS_IVCHAN);
279 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
283 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
284 int imode, int perm, PerlIO *old, int narg, SV **args)
288 Perl_croak(aTHX_ "More than one argument to open");
290 if (*args == &PL_sv_undef)
291 return PerlIO_tmpfile();
294 const char *name = SvPV_const(*args, len);
295 if (!IS_SAFE_PATHNAME(name, len, "open"))
298 if (*mode == IoTYPE_NUMERIC) {
299 fd = PerlLIO_open3(name, imode, perm);
301 return PerlIO_fdopen(fd, mode + 1);
304 return PerlIO_reopen(name, mode, old);
307 return PerlIO_open(name, mode);
312 return PerlIO_fdopen(fd, (char *) mode);
317 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
318 XS(XS_PerlIO__Layer__find)
322 Perl_croak(aTHX_ "Usage class->find(name[,load])");
324 const char * const name = SvPV_nolen_const(ST(1));
325 ST(0) = (strEQ(name, "crlf")
326 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
333 Perl_boot_core_PerlIO(pTHX)
335 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
341 #ifdef PERLIO_IS_STDIO
348 * Does nothing (yet) except force this file to be included in perl
349 * binary. That allows this file to force inclusion of other functions
350 * that may be required by loadable extensions e.g. for
351 * FileHandle::tmpfile
355 #undef PerlIO_tmpfile
362 #else /* PERLIO_IS_STDIO */
364 /*======================================================================================*/
366 * Implement all the PerlIO interface ourselves.
372 PerlIO_debug(const char *fmt, ...)
377 if (!PL_perlio_debug_fd) {
379 PerlProc_getuid() == PerlProc_geteuid() &&
380 PerlProc_getgid() == PerlProc_getegid()) {
381 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
384 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
386 PL_perlio_debug_fd = -1;
388 /* tainting or set*id, so ignore the environment, and ensure we
389 skip these tests next time through. */
390 PL_perlio_debug_fd = -1;
393 if (PL_perlio_debug_fd > 0) {
395 const char * const s = CopFILE(PL_curcop);
396 /* Use fixed buffer as sv_catpvf etc. needs SVs */
398 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
399 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
400 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
402 const char *s = CopFILE(PL_curcop);
404 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
405 (IV) CopLINE(PL_curcop));
406 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
408 s = SvPV_const(sv, len);
409 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
416 /*--------------------------------------------------------------------------------------*/
419 * Inner level routines
422 /* check that the head field of each layer points back to the head */
425 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
427 PerlIO_verify_head(pTHX_ PerlIO *f)
431 #ifndef PERL_IMPLICIT_SYS
436 p = head = PerlIOBase(f)->head;
439 assert(p->head == head);
440 if (p == (PerlIOl*)f)
447 # define VERIFY_HEAD(f)
452 * Table of pointers to the PerlIO structs (malloc'ed)
454 #define PERLIO_TABLE_SIZE 64
457 PerlIO_init_table(pTHX)
461 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
467 PerlIO_allocate(pTHX)
470 * Find a free slot in the table, allocating new table as necessary
475 while ((f = *last)) {
477 last = (PerlIOl **) (f);
478 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
479 if (!((++f)->next)) {
480 f->flags = 0; /* lockcnt */
487 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
491 *last = (PerlIOl*) f++;
492 f->flags = 0; /* lockcnt */
498 #undef PerlIO_fdupopen
500 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
502 if (PerlIOValid(f)) {
503 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
504 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
506 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
508 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
512 SETERRNO(EBADF, SS_IVCHAN);
518 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
520 PerlIOl * const table = *tablep;
523 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
524 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
525 PerlIOl * const f = table + i;
527 PerlIO_close(&(f->next));
537 PerlIO_list_alloc(pTHX)
541 Newxz(list, 1, PerlIO_list_t);
547 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
550 if (--list->refcnt == 0) {
553 for (i = 0; i < list->cur; i++)
554 SvREFCNT_dec(list->array[i].arg);
555 Safefree(list->array);
563 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
568 if (list->cur >= list->len) {
571 Renew(list->array, list->len, PerlIO_pair_t);
573 Newx(list->array, list->len, PerlIO_pair_t);
575 p = &(list->array[list->cur++]);
577 if ((p->arg = arg)) {
578 SvREFCNT_inc_simple_void_NN(arg);
583 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
585 PerlIO_list_t *list = NULL;
588 list = PerlIO_list_alloc(aTHX);
589 for (i=0; i < proto->cur; i++) {
590 SV *arg = proto->array[i].arg;
593 arg = sv_dup(arg, param);
595 PERL_UNUSED_ARG(param);
597 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
604 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
607 PerlIOl **table = &proto->Iperlio;
610 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
611 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
612 PerlIO_init_table(aTHX);
613 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
614 while ((f = *table)) {
616 table = (PerlIOl **) (f++);
617 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
619 (void) fp_dup(&(f->next), 0, param);
626 PERL_UNUSED_ARG(proto);
627 PERL_UNUSED_ARG(param);
632 PerlIO_destruct(pTHX)
634 PerlIOl **table = &PL_perlio;
637 PerlIO_debug("Destruct %p\n",(void*)aTHX);
639 while ((f = *table)) {
641 table = (PerlIOl **) (f++);
642 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
643 PerlIO *x = &(f->next);
646 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
647 PerlIO_debug("Destruct popping %s\n", l->tab->name);
661 PerlIO_pop(pTHX_ PerlIO *f)
663 const PerlIOl *l = *f;
666 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
667 l->tab ? l->tab->name : "(Null)");
668 if (l->tab && l->tab->Popped) {
670 * If popped returns non-zero do not free its layer structure
671 * it has either done so itself, or it is shared and still in
674 if ((*l->tab->Popped) (aTHX_ f) != 0)
677 if (PerlIO_lockcnt(f)) {
678 /* we're in use; defer freeing the structure */
679 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
680 PerlIOBase(f)->tab = NULL;
690 /* Return as an array the stack of layers on a filehandle. Note that
691 * the stack is returned top-first in the array, and there are three
692 * times as many array elements as there are layers in the stack: the
693 * first element of a layer triplet is the name, the second one is the
694 * arguments, and the third one is the flags. */
697 PerlIO_get_layers(pTHX_ PerlIO *f)
699 AV * const av = newAV();
701 if (PerlIOValid(f)) {
702 PerlIOl *l = PerlIOBase(f);
705 /* There is some collusion in the implementation of
706 XS_PerlIO_get_layers - it knows that name and flags are
707 generated as fresh SVs here, and takes advantage of that to
708 "copy" them by taking a reference. If it changes here, it needs
709 to change there too. */
710 SV * const name = l->tab && l->tab->name ?
711 newSVpv(l->tab->name, 0) : &PL_sv_undef;
712 SV * const arg = l->tab && l->tab->Getarg ?
713 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
716 av_push(av, newSViv((IV)l->flags));
724 /*--------------------------------------------------------------------------------------*/
726 * XS Interface for perl code
730 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
734 if ((SSize_t) len <= 0)
736 for (i = 0; i < PL_known_layers->cur; i++) {
737 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
738 const STRLEN this_len = strlen(f->name);
739 if (this_len == len && memEQ(f->name, name, len)) {
740 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
744 if (load && PL_subname && PL_def_layerlist
745 && PL_def_layerlist->cur >= 2) {
746 if (PL_in_load_module) {
747 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
750 SV * const pkgsv = newSVpvs("PerlIO");
751 SV * const layer = newSVpvn(name, len);
752 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
754 SAVEBOOL(PL_in_load_module);
756 SAVEGENERICSV(PL_warnhook);
757 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
759 PL_in_load_module = TRUE;
761 * The two SVs are magically freed by load_module
763 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
765 return PerlIO_find_layer(aTHX_ name, len, 0);
768 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
772 #ifdef USE_ATTRIBUTES_FOR_PERLIO
775 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
778 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
779 PerlIO * const ifp = IoIFP(io);
780 PerlIO * const ofp = IoOFP(io);
781 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
782 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
788 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
791 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
792 PerlIO * const ifp = IoIFP(io);
793 PerlIO * const ofp = IoOFP(io);
794 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
795 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
801 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
803 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
808 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
810 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
814 MGVTBL perlio_vtab = {
822 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
823 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
826 SV * const sv = SvRV(ST(1));
827 AV * const av = newAV();
831 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
833 mg = mg_find(sv, PERL_MAGIC_ext);
834 mg->mg_virtual = &perlio_vtab;
836 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
837 for (i = 2; i < items; i++) {
839 const char * const name = SvPV_const(ST(i), len);
840 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
842 av_push(av, SvREFCNT_inc_simple_NN(layer));
853 #endif /* USE_ATTIBUTES_FOR_PERLIO */
856 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
858 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
859 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
863 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
864 XS(XS_PerlIO__Layer__NoWarnings)
866 /* This is used as a %SIG{__WARN__} handler to suppress warnings
867 during loading of layers.
872 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
876 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
877 XS(XS_PerlIO__Layer__find)
882 Perl_croak(aTHX_ "Usage class->find(name[,load])");
885 const char * const name = SvPV_const(ST(1), len);
886 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
887 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
889 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
896 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
898 if (!PL_known_layers)
899 PL_known_layers = PerlIO_list_alloc(aTHX);
900 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
901 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
905 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
908 const char *s = names;
910 while (isSPACE(*s) || *s == ':')
915 const char *as = NULL;
917 if (!isIDFIRST(*s)) {
919 * Message is consistent with how attribute lists are
920 * passed. Even though this means "foo : : bar" is
921 * seen as an invalid separator character.
923 const char q = ((*s == '\'') ? '"' : '\'');
924 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
925 "Invalid separator character %c%c%c in PerlIO layer specification %s",
927 SETERRNO(EINVAL, LIB_INVARG);
932 } while (isWORDCHAR(*e));
948 * It's a nul terminated string, not allowed
949 * to \ the terminating null. Anything other
950 * character is passed over.
960 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
961 "Argument list not closed for PerlIO layer \"%.*s\"",
973 PerlIO_funcs * const layer =
974 PerlIO_find_layer(aTHX_ s, llen, 1);
978 arg = newSVpvn(as, alen);
979 PerlIO_list_push(aTHX_ av, layer,
980 (arg) ? arg : &PL_sv_undef);
984 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
997 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
999 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1000 #ifdef PERLIO_USING_CRLF
1003 if (PerlIO_stdio.Set_ptrcnt)
1004 tab = &PerlIO_stdio;
1006 PerlIO_debug("Pushing %s\n", tab->name);
1007 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1012 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1014 return av->array[n].arg;
1018 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1020 if (n >= 0 && n < av->cur) {
1021 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1022 av->array[n].funcs->name);
1023 return av->array[n].funcs;
1026 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1031 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1033 PERL_UNUSED_ARG(mode);
1034 PERL_UNUSED_ARG(arg);
1035 PERL_UNUSED_ARG(tab);
1036 if (PerlIOValid(f)) {
1038 PerlIO_pop(aTHX_ f);
1044 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1045 sizeof(PerlIO_funcs),
1048 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1068 NULL, /* get_base */
1069 NULL, /* get_bufsiz */
1072 NULL, /* set_ptrcnt */
1076 PerlIO_default_layers(pTHX)
1078 if (!PL_def_layerlist) {
1079 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1080 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1081 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1082 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1084 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1086 osLayer = &PerlIO_win32;
1089 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1090 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1091 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1092 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1093 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1094 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1095 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1096 PerlIO_list_push(aTHX_ PL_def_layerlist,
1097 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1100 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1103 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1106 if (PL_def_layerlist->cur < 2) {
1107 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1109 return PL_def_layerlist;
1113 Perl_boot_core_PerlIO(pTHX)
1115 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1116 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1119 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1120 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1124 PerlIO_default_layer(pTHX_ I32 n)
1126 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1129 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1132 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1133 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1136 PerlIO_stdstreams(pTHX)
1139 PerlIO_init_table(aTHX);
1140 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1141 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1142 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1147 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1150 if (tab->fsize != sizeof(PerlIO_funcs)) {
1152 "%s (%"UVuf") does not match %s (%"UVuf")",
1153 "PerlIO layer function table size", (UV)tab->fsize,
1154 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1158 if (tab->size < sizeof(PerlIOl)) {
1160 "%s (%"UVuf") smaller than %s (%"UVuf")",
1161 "PerlIO layer instance size", (UV)tab->size,
1162 "size expected by this perl", (UV)sizeof(PerlIOl) );
1164 /* Real layer with a data area */
1167 Newxz(temp, tab->size, char);
1171 l->tab = (PerlIO_funcs*) tab;
1172 l->head = ((PerlIOl*)f)->head;
1174 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1175 (void*)f, tab->name,
1176 (mode) ? mode : "(Null)", (void*)arg);
1177 if (*l->tab->Pushed &&
1179 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1180 PerlIO_pop(aTHX_ f);
1189 /* Pseudo-layer where push does its own stack adjust */
1190 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1191 (mode) ? mode : "(Null)", (void*)arg);
1193 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1201 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1202 IV n, const char *mode, int fd, int imode, int perm,
1203 PerlIO *old, int narg, SV **args)
1205 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1206 if (tab && tab->Open) {
1207 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1208 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1214 SETERRNO(EINVAL, LIB_INVARG);
1219 PerlIOBase_binmode(pTHX_ PerlIO *f)
1221 if (PerlIOValid(f)) {
1222 /* Is layer suitable for raw stream ? */
1223 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1224 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1225 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1228 /* Not suitable - pop it */
1229 PerlIO_pop(aTHX_ f);
1237 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1239 PERL_UNUSED_ARG(mode);
1240 PERL_UNUSED_ARG(arg);
1241 PERL_UNUSED_ARG(tab);
1243 if (PerlIOValid(f)) {
1248 * Strip all layers that are not suitable for a raw stream
1251 while (t && (l = *t)) {
1252 if (l->tab && l->tab->Binmode) {
1253 /* Has a handler - normal case */
1254 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1256 /* Layer still there - move down a layer */
1265 /* No handler - pop it */
1266 PerlIO_pop(aTHX_ t);
1269 if (PerlIOValid(f)) {
1270 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1271 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1279 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1280 PerlIO_list_t *layers, IV n, IV max)
1284 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1286 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1297 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1301 save_scalar(PL_errgv);
1303 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1304 code = PerlIO_parse_layers(aTHX_ layers, names);
1306 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1308 PerlIO_list_free(aTHX_ layers);
1315 /*--------------------------------------------------------------------------------------*/
1317 * Given the abstraction above the public API functions
1321 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1323 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1324 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1325 PerlIOBase(f)->tab->name : "(Null)",
1326 iotype, mode, (names) ? names : "(Null)");
1329 /* Do not flush etc. if (e.g.) switching encodings.
1330 if a pushed layer knows it needs to flush lower layers
1331 (for example :unix which is never going to call them)
1332 it can do the flush when it is pushed.
1334 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1337 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1338 #ifdef PERLIO_USING_CRLF
1339 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1340 O_BINARY so we can look for it in mode.
1342 if (!(mode & O_BINARY)) {
1344 /* FIXME?: Looking down the layer stack seems wrong,
1345 but is a way of reaching past (say) an encoding layer
1346 to flip CRLF-ness of the layer(s) below
1349 /* Perhaps we should turn on bottom-most aware layer
1350 e.g. Ilya's idea that UNIX TTY could serve
1352 if (PerlIOBase(f)->tab &&
1353 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1355 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1356 /* Not in text mode - flush any pending stuff and flip it */
1358 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1360 /* Only need to turn it on in one layer so we are done */
1365 /* Not finding a CRLF aware layer presumably means we are binary
1366 which is not what was requested - so we failed
1367 We _could_ push :crlf layer but so could caller
1372 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1373 So code that used to be here is now in PerlIORaw_pushed().
1375 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1380 PerlIO__close(pTHX_ PerlIO *f)
1382 if (PerlIOValid(f)) {
1383 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1384 if (tab && tab->Close)
1385 return (*tab->Close)(aTHX_ f);
1387 return PerlIOBase_close(aTHX_ f);
1390 SETERRNO(EBADF, SS_IVCHAN);
1396 Perl_PerlIO_close(pTHX_ PerlIO *f)
1398 const int code = PerlIO__close(aTHX_ f);
1399 while (PerlIOValid(f)) {
1400 PerlIO_pop(aTHX_ f);
1401 if (PerlIO_lockcnt(f))
1402 /* we're in use; the 'pop' deferred freeing the structure */
1409 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1411 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1415 static PerlIO_funcs *
1416 PerlIO_layer_from_ref(pTHX_ SV *sv)
1419 * For any scalar type load the handler which is bundled with perl
1421 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1422 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1423 /* This isn't supposed to happen, since PerlIO::scalar is core,
1424 * but could happen anyway in smaller installs or with PAR */
1426 /* diag_listed_as: Unknown PerlIO layer "%s" */
1427 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1432 * For other types allow if layer is known but don't try and load it
1434 switch (SvTYPE(sv)) {
1436 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1438 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1440 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1442 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1449 PerlIO_resolve_layers(pTHX_ const char *layers,
1450 const char *mode, int narg, SV **args)
1452 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1455 PerlIO_stdstreams(aTHX);
1457 SV * const arg = *args;
1459 * If it is a reference but not an object see if we have a handler
1462 if (SvROK(arg) && !sv_isobject(arg)) {
1463 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1465 def = PerlIO_list_alloc(aTHX);
1466 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1470 * Don't fail if handler cannot be found :via(...) etc. may do
1471 * something sensible else we will just stringfy and open
1476 if (!layers || !*layers)
1477 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1478 if (layers && *layers) {
1481 av = PerlIO_clone_list(aTHX_ def, NULL);
1486 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1490 PerlIO_list_free(aTHX_ av);
1502 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1503 int imode, int perm, PerlIO *f, int narg, SV **args)
1505 if (!f && narg == 1 && *args == &PL_sv_undef) {
1506 if ((f = PerlIO_tmpfile())) {
1507 if (!layers || !*layers)
1508 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1509 if (layers && *layers)
1510 PerlIO_apply_layers(aTHX_ f, mode, layers);
1514 PerlIO_list_t *layera;
1516 PerlIO_funcs *tab = NULL;
1517 if (PerlIOValid(f)) {
1519 * This is "reopen" - it is not tested as perl does not use it
1523 layera = PerlIO_list_alloc(aTHX);
1526 if (l->tab && l->tab->Getarg)
1527 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1528 PerlIO_list_push(aTHX_ layera, l->tab,
1529 (arg) ? arg : &PL_sv_undef);
1531 l = *PerlIONext(&l);
1535 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1541 * Start at "top" of layer stack
1543 n = layera->cur - 1;
1545 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1554 * Found that layer 'n' can do opens - call it
1556 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1557 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1559 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1560 tab->name, layers ? layers : "(Null)", mode, fd,
1561 imode, perm, (void*)f, narg, (void*)args);
1563 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1566 SETERRNO(EINVAL, LIB_INVARG);
1570 if (n + 1 < layera->cur) {
1572 * More layers above the one that we used to open -
1575 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1576 /* If pushing layers fails close the file */
1583 PerlIO_list_free(aTHX_ layera);
1590 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1592 PERL_ARGS_ASSERT_PERLIO_READ;
1594 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1598 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1600 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1602 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1606 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1608 PERL_ARGS_ASSERT_PERLIO_WRITE;
1610 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1614 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1616 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1620 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1622 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1626 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1630 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1632 if (tab && tab->Flush)
1633 return (*tab->Flush) (aTHX_ f);
1635 return 0; /* If no Flush defined, silently succeed. */
1638 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1639 SETERRNO(EBADF, SS_IVCHAN);
1645 * Is it good API design to do flush-all on NULL, a potentially
1646 * erroneous input? Maybe some magical value (PerlIO*
1647 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1648 * things on fflush(NULL), but should we be bound by their design
1651 PerlIOl **table = &PL_perlio;
1654 while ((ff = *table)) {
1656 table = (PerlIOl **) (ff++);
1657 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1658 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1668 PerlIOBase_flush_linebuf(pTHX)
1670 PerlIOl **table = &PL_perlio;
1672 while ((f = *table)) {
1674 table = (PerlIOl **) (f++);
1675 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1677 && (PerlIOBase(&(f->next))->
1678 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1679 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1680 PerlIO_flush(&(f->next));
1687 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1689 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1693 PerlIO_isutf8(PerlIO *f)
1696 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1698 SETERRNO(EBADF, SS_IVCHAN);
1704 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1706 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1710 Perl_PerlIO_error(pTHX_ PerlIO *f)
1712 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1716 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1718 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1722 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1724 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1728 PerlIO_has_base(PerlIO *f)
1730 if (PerlIOValid(f)) {
1731 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1734 return (tab->Get_base != NULL);
1741 PerlIO_fast_gets(PerlIO *f)
1743 if (PerlIOValid(f)) {
1744 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1745 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1748 return (tab->Set_ptrcnt != NULL);
1756 PerlIO_has_cntptr(PerlIO *f)
1758 if (PerlIOValid(f)) {
1759 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1762 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1769 PerlIO_canset_cnt(PerlIO *f)
1771 if (PerlIOValid(f)) {
1772 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1775 return (tab->Set_ptrcnt != NULL);
1782 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1784 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1788 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1790 /* Note that Get_bufsiz returns a Size_t */
1791 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1795 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1797 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1801 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1803 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1807 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1809 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1813 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1815 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1819 /*--------------------------------------------------------------------------------------*/
1821 * utf8 and raw dummy layers
1825 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1827 PERL_UNUSED_CONTEXT;
1828 PERL_UNUSED_ARG(mode);
1829 PERL_UNUSED_ARG(arg);
1830 if (PerlIOValid(f)) {
1831 if (tab && tab->kind & PERLIO_K_UTF8)
1832 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1834 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1840 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1841 sizeof(PerlIO_funcs),
1844 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1864 NULL, /* get_base */
1865 NULL, /* get_bufsiz */
1868 NULL, /* set_ptrcnt */
1871 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1872 sizeof(PerlIO_funcs),
1875 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1895 NULL, /* get_base */
1896 NULL, /* get_bufsiz */
1899 NULL, /* set_ptrcnt */
1902 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1903 sizeof(PerlIO_funcs),
1926 NULL, /* get_base */
1927 NULL, /* get_bufsiz */
1930 NULL, /* set_ptrcnt */
1932 /*--------------------------------------------------------------------------------------*/
1933 /*--------------------------------------------------------------------------------------*/
1935 * "Methods" of the "base class"
1939 PerlIOBase_fileno(pTHX_ PerlIO *f)
1941 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1945 PerlIO_modestr(PerlIO * f, char *buf)
1948 if (PerlIOValid(f)) {
1949 const IV flags = PerlIOBase(f)->flags;
1950 if (flags & PERLIO_F_APPEND) {
1952 if (flags & PERLIO_F_CANREAD) {
1956 else if (flags & PERLIO_F_CANREAD) {
1958 if (flags & PERLIO_F_CANWRITE)
1961 else if (flags & PERLIO_F_CANWRITE) {
1963 if (flags & PERLIO_F_CANREAD) {
1967 #ifdef PERLIO_USING_CRLF
1968 if (!(flags & PERLIO_F_CRLF))
1978 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1980 PerlIOl * const l = PerlIOBase(f);
1981 PERL_UNUSED_CONTEXT;
1982 PERL_UNUSED_ARG(arg);
1984 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1985 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1986 if (tab && tab->Set_ptrcnt != NULL)
1987 l->flags |= PERLIO_F_FASTGETS;
1989 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1993 l->flags |= PERLIO_F_CANREAD;
1996 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1999 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2002 SETERRNO(EINVAL, LIB_INVARG);
2008 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2011 l->flags &= ~PERLIO_F_CRLF;
2014 l->flags |= PERLIO_F_CRLF;
2017 SETERRNO(EINVAL, LIB_INVARG);
2024 l->flags |= l->next->flags &
2025 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2030 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2031 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2032 l->flags, PerlIO_modestr(f, temp));
2038 PerlIOBase_popped(pTHX_ PerlIO *f)
2040 PERL_UNUSED_CONTEXT;
2046 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2049 * Save the position as current head considers it
2051 const Off_t old = PerlIO_tell(f);
2052 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2053 PerlIOSelf(f, PerlIOBuf)->posn = old;
2054 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2058 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2060 STDCHAR *buf = (STDCHAR *) vbuf;
2062 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2063 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2064 SETERRNO(EBADF, SS_IVCHAN);
2070 SSize_t avail = PerlIO_get_cnt(f);
2073 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2075 STDCHAR *ptr = PerlIO_get_ptr(f);
2076 Copy(ptr, buf, take, STDCHAR);
2077 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2080 if (avail == 0) /* set_ptrcnt could have reset avail */
2083 if (count > 0 && avail <= 0) {
2084 if (PerlIO_fill(f) != 0)
2089 return (buf - (STDCHAR *) vbuf);
2095 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2097 PERL_UNUSED_CONTEXT;
2103 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2105 PERL_UNUSED_CONTEXT;
2111 PerlIOBase_close(pTHX_ PerlIO *f)
2114 if (PerlIOValid(f)) {
2115 PerlIO *n = PerlIONext(f);
2116 code = PerlIO_flush(f);
2117 PerlIOBase(f)->flags &=
2118 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2119 while (PerlIOValid(n)) {
2120 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2121 if (tab && tab->Close) {
2122 if ((*tab->Close)(aTHX_ n) != 0)
2127 PerlIOBase(n)->flags &=
2128 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2134 SETERRNO(EBADF, SS_IVCHAN);
2140 PerlIOBase_eof(pTHX_ PerlIO *f)
2142 PERL_UNUSED_CONTEXT;
2143 if (PerlIOValid(f)) {
2144 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2150 PerlIOBase_error(pTHX_ PerlIO *f)
2152 PERL_UNUSED_CONTEXT;
2153 if (PerlIOValid(f)) {
2154 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2160 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2162 if (PerlIOValid(f)) {
2163 PerlIO * const n = PerlIONext(f);
2164 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2171 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2173 PERL_UNUSED_CONTEXT;
2174 if (PerlIOValid(f)) {
2175 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2180 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2186 arg = sv_dup(arg, param);
2187 SvREFCNT_inc_simple_void_NN(arg);
2191 return newSVsv(arg);
2194 PERL_UNUSED_ARG(param);
2195 return newSVsv(arg);
2200 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2202 PerlIO * const nexto = PerlIONext(o);
2203 if (PerlIOValid(nexto)) {
2204 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2205 if (tab && tab->Dup)
2206 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2208 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2211 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2215 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2216 self ? self->name : "(Null)",
2217 (void*)f, (void*)o, (void*)param);
2218 if (self && self->Getarg)
2219 arg = (*self->Getarg)(aTHX_ o, param, flags);
2220 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2221 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2222 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2228 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2230 /* Must be called with PL_perlio_mutex locked. */
2232 S_more_refcounted_fds(pTHX_ const int new_fd) {
2234 const int old_max = PL_perlio_fd_refcnt_size;
2235 const int new_max = 16 + (new_fd & ~15);
2238 #ifndef PERL_IMPLICIT_SYS
2239 PERL_UNUSED_CONTEXT;
2242 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2243 old_max, new_fd, new_max);
2245 if (new_fd < old_max) {
2249 assert (new_max > new_fd);
2251 /* Use plain realloc() since we need this memory to be really
2252 * global and visible to all the interpreters and/or threads. */
2253 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2257 MUTEX_UNLOCK(&PL_perlio_mutex);
2262 PL_perlio_fd_refcnt_size = new_max;
2263 PL_perlio_fd_refcnt = new_array;
2265 PerlIO_debug("Zeroing %p, %d\n",
2266 (void*)(new_array + old_max),
2269 Zero(new_array + old_max, new_max - old_max, int);
2276 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2277 PERL_UNUSED_CONTEXT;
2281 PerlIOUnix_refcnt_inc(int fd)
2288 MUTEX_LOCK(&PL_perlio_mutex);
2290 if (fd >= PL_perlio_fd_refcnt_size)
2291 S_more_refcounted_fds(aTHX_ fd);
2293 PL_perlio_fd_refcnt[fd]++;
2294 if (PL_perlio_fd_refcnt[fd] <= 0) {
2295 /* diag_listed_as: refcnt_inc: fd %d%s */
2296 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2297 fd, PL_perlio_fd_refcnt[fd]);
2299 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2300 fd, PL_perlio_fd_refcnt[fd]);
2303 MUTEX_UNLOCK(&PL_perlio_mutex);
2306 /* diag_listed_as: refcnt_inc: fd %d%s */
2307 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2312 PerlIOUnix_refcnt_dec(int fd)
2318 MUTEX_LOCK(&PL_perlio_mutex);
2320 if (fd >= PL_perlio_fd_refcnt_size) {
2321 /* diag_listed_as: refcnt_dec: fd %d%s */
2322 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2323 fd, PL_perlio_fd_refcnt_size);
2325 if (PL_perlio_fd_refcnt[fd] <= 0) {
2326 /* diag_listed_as: refcnt_dec: fd %d%s */
2327 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2328 fd, PL_perlio_fd_refcnt[fd]);
2330 cnt = --PL_perlio_fd_refcnt[fd];
2331 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2333 MUTEX_UNLOCK(&PL_perlio_mutex);
2336 /* diag_listed_as: refcnt_dec: fd %d%s */
2337 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2343 PerlIOUnix_refcnt(int fd)
2350 MUTEX_LOCK(&PL_perlio_mutex);
2352 if (fd >= PL_perlio_fd_refcnt_size) {
2353 /* diag_listed_as: refcnt: fd %d%s */
2354 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2355 fd, PL_perlio_fd_refcnt_size);
2357 if (PL_perlio_fd_refcnt[fd] <= 0) {
2358 /* diag_listed_as: refcnt: fd %d%s */
2359 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2360 fd, PL_perlio_fd_refcnt[fd]);
2362 cnt = PL_perlio_fd_refcnt[fd];
2364 MUTEX_UNLOCK(&PL_perlio_mutex);
2367 /* diag_listed_as: refcnt: fd %d%s */
2368 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2374 PerlIO_cleanup(pTHX)
2378 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2380 PerlIO_debug("Cleanup layers\n");
2383 /* Raise STDIN..STDERR refcount so we don't close them */
2384 for (i=0; i < 3; i++)
2385 PerlIOUnix_refcnt_inc(i);
2386 PerlIO_cleantable(aTHX_ &PL_perlio);
2387 /* Restore STDIN..STDERR refcount */
2388 for (i=0; i < 3; i++)
2389 PerlIOUnix_refcnt_dec(i);
2391 if (PL_known_layers) {
2392 PerlIO_list_free(aTHX_ PL_known_layers);
2393 PL_known_layers = NULL;
2395 if (PL_def_layerlist) {
2396 PerlIO_list_free(aTHX_ PL_def_layerlist);
2397 PL_def_layerlist = NULL;
2401 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2405 /* XXX we can't rely on an interpreter being present at this late stage,
2406 XXX so we can't use a function like PerlLIO_write that relies on one
2407 being present (at least in win32) :-(.
2412 /* By now all filehandles should have been closed, so any
2413 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2415 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2416 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2417 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2419 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2420 if (PL_perlio_fd_refcnt[i]) {
2422 my_snprintf(buf, sizeof(buf),
2423 "PerlIO_teardown: fd %d refcnt=%d\n",
2424 i, PL_perlio_fd_refcnt[i]);
2425 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2431 /* Not bothering with PL_perlio_mutex since by now
2432 * all the interpreters are gone. */
2433 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2434 && PL_perlio_fd_refcnt) {
2435 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2436 PL_perlio_fd_refcnt = NULL;
2437 PL_perlio_fd_refcnt_size = 0;
2441 /*--------------------------------------------------------------------------------------*/
2443 * Bottom-most level for UNIX-like case
2447 struct _PerlIO base; /* The generic part */
2448 int fd; /* UNIX like file descriptor */
2449 int oflags; /* open/fcntl flags */
2453 S_lockcnt_dec(pTHX_ const void* f)
2455 #ifndef PERL_IMPLICIT_SYS
2456 PERL_UNUSED_CONTEXT;
2458 PerlIO_lockcnt((PerlIO*)f)--;
2462 /* call the signal handler, and if that handler happens to clear
2463 * this handle, free what we can and return true */
2466 S_perlio_async_run(pTHX_ PerlIO* f) {
2468 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2469 PerlIO_lockcnt(f)++;
2471 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2475 /* we've just run some perl-level code that could have done
2476 * anything, including closing the file or clearing this layer.
2477 * If so, free any lower layers that have already been
2478 * cleared, then return an error. */
2479 while (PerlIOValid(f) &&
2480 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2482 const PerlIOl *l = *f;
2491 PerlIOUnix_oflags(const char *mode)
2494 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2499 if (*++mode == '+') {
2506 oflags = O_CREAT | O_TRUNC;
2507 if (*++mode == '+') {
2516 oflags = O_CREAT | O_APPEND;
2517 if (*++mode == '+') {
2526 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2528 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2529 * of them in, and then bit-and-masking the other them away, won't
2530 * have much of an effect. */
2533 #if O_TEXT != O_BINARY
2540 #if O_TEXT != O_BINARY
2542 oflags &= ~O_BINARY;
2548 /* bit-or:ing with zero O_BINARY would be useless. */
2550 * If neither "t" nor "b" was specified, open the file
2553 * Note that if something else than the zero byte was seen
2554 * here (e.g. bogus mode "rx"), just few lines later we will
2555 * set the errno and invalidate the flags.
2561 if (*mode || oflags == -1) {
2562 SETERRNO(EINVAL, LIB_INVARG);
2569 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2571 PERL_UNUSED_CONTEXT;
2572 return PerlIOSelf(f, PerlIOUnix)->fd;
2576 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2578 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2581 if (PerlLIO_fstat(fd, &st) == 0) {
2582 if (!S_ISREG(st.st_mode)) {
2583 PerlIO_debug("%d is not regular file\n",fd);
2584 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2587 PerlIO_debug("%d _is_ a regular file\n",fd);
2593 PerlIOUnix_refcnt_inc(fd);
2594 PERL_UNUSED_CONTEXT;
2598 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2600 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2601 if (*PerlIONext(f)) {
2602 /* We never call down so do any pending stuff now */
2603 PerlIO_flush(PerlIONext(f));
2605 * XXX could (or should) we retrieve the oflags from the open file
2606 * handle rather than believing the "mode" we are passed in? XXX
2607 * Should the value on NULL mode be 0 or -1?
2609 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2610 mode ? PerlIOUnix_oflags(mode) : -1);
2612 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2618 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2620 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2622 PERL_UNUSED_CONTEXT;
2623 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2625 SETERRNO(ESPIPE, LIB_INVARG);
2627 SETERRNO(EINVAL, LIB_INVARG);
2631 new_loc = PerlLIO_lseek(fd, offset, whence);
2632 if (new_loc == (Off_t) - 1)
2634 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2639 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2640 IV n, const char *mode, int fd, int imode,
2641 int perm, PerlIO *f, int narg, SV **args)
2643 if (PerlIOValid(f)) {
2644 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2645 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2648 if (*mode == IoTYPE_NUMERIC)
2651 imode = PerlIOUnix_oflags(mode);
2653 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2660 const char *path = SvPV_const(*args, len);
2661 if (!IS_SAFE_PATHNAME(path, len, "open"))
2663 fd = PerlLIO_open3(path, imode, perm);
2667 if (*mode == IoTYPE_IMPLICIT)
2670 f = PerlIO_allocate(aTHX);
2672 if (!PerlIOValid(f)) {
2673 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2678 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2679 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2680 if (*mode == IoTYPE_APPEND)
2681 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2688 * FIXME: pop layers ???
2696 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2698 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2700 if (flags & PERLIO_DUP_FD) {
2701 fd = PerlLIO_dup(fd);
2704 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2706 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2707 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2717 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2720 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2722 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2723 #ifdef PERLIO_STD_SPECIAL
2725 return PERLIO_STD_IN(fd, vbuf, count);
2727 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2728 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2732 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2733 if (len >= 0 || errno != EINTR) {
2735 if (errno != EAGAIN) {
2736 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2739 else if (len == 0 && count != 0) {
2740 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2746 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2753 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2756 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2758 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2759 #ifdef PERLIO_STD_SPECIAL
2760 if (fd == 1 || fd == 2)
2761 return PERLIO_STD_OUT(fd, vbuf, count);
2764 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2765 if (len >= 0 || errno != EINTR) {
2767 if (errno != EAGAIN) {
2768 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2774 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2781 PerlIOUnix_tell(pTHX_ PerlIO *f)
2783 PERL_UNUSED_CONTEXT;
2785 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2790 PerlIOUnix_close(pTHX_ PerlIO *f)
2792 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2794 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2795 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2796 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2801 SETERRNO(EBADF,SS_IVCHAN);
2804 while (PerlLIO_close(fd) != 0) {
2805 if (errno != EINTR) {
2810 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2814 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2819 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2820 sizeof(PerlIO_funcs),
2827 PerlIOBase_binmode, /* binmode */
2837 PerlIOBase_noop_ok, /* flush */
2838 PerlIOBase_noop_fail, /* fill */
2841 PerlIOBase_clearerr,
2842 PerlIOBase_setlinebuf,
2843 NULL, /* get_base */
2844 NULL, /* get_bufsiz */
2847 NULL, /* set_ptrcnt */
2850 /*--------------------------------------------------------------------------------------*/
2855 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2856 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2857 broken by the last second glibc 2.3 fix
2859 #define STDIO_BUFFER_WRITABLE
2864 struct _PerlIO base;
2865 FILE *stdio; /* The stream */
2869 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2871 PERL_UNUSED_CONTEXT;
2873 if (PerlIOValid(f)) {
2874 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2876 return PerlSIO_fileno(s);
2883 PerlIOStdio_mode(const char *mode, char *tmode)
2885 char * const ret = tmode;
2891 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2899 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2902 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2903 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2904 if (toptab == tab) {
2905 /* Top is already stdio - pop self (duplicate) and use original */
2906 PerlIO_pop(aTHX_ f);
2909 const int fd = PerlIO_fileno(n);
2912 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2913 mode = PerlIOStdio_mode(mode, tmode)))) {
2914 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2915 /* We never call down so do any pending stuff now */
2916 PerlIO_flush(PerlIONext(f));
2917 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2924 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2929 PerlIO_importFILE(FILE *stdio, const char *mode)
2935 int fd0 = fileno(stdio);
2939 if (!mode || !*mode) {
2940 /* We need to probe to see how we can open the stream
2941 so start with read/write and then try write and read
2942 we dup() so that we can fclose without loosing the fd.
2944 Note that the errno value set by a failing fdopen
2945 varies between stdio implementations.
2947 const int fd = PerlLIO_dup(fd0);
2952 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2954 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2957 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2960 /* Don't seem to be able to open */
2966 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2967 s = PerlIOSelf(f, PerlIOStdio);
2969 PerlIOUnix_refcnt_inc(fileno(stdio));
2976 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2977 IV n, const char *mode, int fd, int imode,
2978 int perm, PerlIO *f, int narg, SV **args)
2981 if (PerlIOValid(f)) {
2983 const char * const path = SvPV_const(*args, len);
2984 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2986 if (!IS_SAFE_PATHNAME(path, len, "open"))
2988 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2989 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
2994 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3000 const char * const path = SvPV_const(*args, len);
3001 if (!IS_SAFE_PATHNAME(path, len, "open"))
3003 if (*mode == IoTYPE_NUMERIC) {
3005 fd = PerlLIO_open3(path, imode, perm);
3009 bool appended = FALSE;
3011 /* Cygwin wants its 'b' early. */
3013 mode = PerlIOStdio_mode(mode, tmode);
3015 stdio = PerlSIO_fopen(path, mode);
3018 f = PerlIO_allocate(aTHX);
3021 mode = PerlIOStdio_mode(mode, tmode);
3022 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3024 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3025 PerlIOUnix_refcnt_inc(fileno(stdio));
3027 PerlSIO_fclose(stdio);
3039 if (*mode == IoTYPE_IMPLICIT) {
3046 stdio = PerlSIO_stdin;
3049 stdio = PerlSIO_stdout;
3052 stdio = PerlSIO_stderr;
3057 stdio = PerlSIO_fdopen(fd, mode =
3058 PerlIOStdio_mode(mode, tmode));
3062 f = PerlIO_allocate(aTHX);
3064 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3065 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3066 PerlIOUnix_refcnt_inc(fileno(stdio));
3077 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3079 /* This assumes no layers underneath - which is what
3080 happens, but is not how I remember it. NI-S 2001/10/16
3082 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3083 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3084 const int fd = fileno(stdio);
3086 if (flags & PERLIO_DUP_FD) {
3087 const int dfd = PerlLIO_dup(fileno(stdio));
3089 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3094 /* FIXME: To avoid messy error recovery if dup fails
3095 re-use the existing stdio as though flag was not set
3099 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3101 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3103 PerlIOUnix_refcnt_inc(fileno(stdio));
3110 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3112 PERL_UNUSED_CONTEXT;
3114 /* XXX this could use PerlIO_canset_fileno() and
3115 * PerlIO_set_fileno() support from Configure
3117 # if defined(__UCLIBC__)
3118 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3121 # elif defined(__GLIBC__)
3122 /* There may be a better way for GLIBC:
3123 - libio.h defines a flag to not close() on cleanup
3127 # elif defined(__sun)
3130 # elif defined(__hpux)
3134 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3135 your platform does not have special entry try this one.
3136 [For OSF only have confirmation for Tru64 (alpha)
3137 but assume other OSFs will be similar.]
3139 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3142 # elif defined(__FreeBSD__)
3143 /* There may be a better way on FreeBSD:
3144 - we could insert a dummy func in the _close function entry
3145 f->_close = (int (*)(void *)) dummy_close;
3149 # elif defined(__OpenBSD__)
3150 /* There may be a better way on OpenBSD:
3151 - we could insert a dummy func in the _close function entry
3152 f->_close = (int (*)(void *)) dummy_close;
3156 # elif defined(__EMX__)
3157 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3160 # elif defined(__CYGWIN__)
3161 /* There may be a better way on CYGWIN:
3162 - we could insert a dummy func in the _close function entry
3163 f->_close = (int (*)(void *)) dummy_close;
3167 # elif defined(WIN32)
3168 # if defined(UNDER_CE)
3169 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3178 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3179 (which isn't thread safe) instead
3181 # error "Don't know how to set FILE.fileno on your platform"
3189 PerlIOStdio_close(pTHX_ PerlIO *f)
3191 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3197 const int fd = fileno(stdio);
3205 #ifdef SOCKS5_VERSION_NAME
3206 /* Socks lib overrides close() but stdio isn't linked to
3207 that library (though we are) - so we must call close()
3208 on sockets on stdio's behalf.
3211 Sock_size_t optlen = sizeof(int);
3212 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3215 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3216 that a subsequent fileno() on it returns -1. Don't want to croak()
3217 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3218 trying to close an already closed handle which somehow it still has
3219 a reference to. (via.xs, I'm looking at you). */
3220 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3221 /* File descriptor still in use */
3225 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3226 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3228 if (stdio == stdout || stdio == stderr)
3229 return PerlIO_flush(f);
3230 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3231 Use Sarathy's trick from maint-5.6 to invalidate the
3232 fileno slot of the FILE *
3234 result = PerlIO_flush(f);
3236 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3239 MUTEX_LOCK(&PL_perlio_mutex);
3240 /* Right. We need a mutex here because for a brief while we
3241 will have the situation that fd is actually closed. Hence if
3242 a second thread were to get into this block, its dup() would
3243 likely return our fd as its dupfd. (after all, it is closed)
3244 Then if we get to the dup2() first, we blat the fd back
3245 (messing up its temporary as a side effect) only for it to
3246 then close its dupfd (== our fd) in its close(dupfd) */
3248 /* There is, of course, a race condition, that any other thread
3249 trying to input/output/whatever on this fd will be stuffed
3250 for the duration of this little manoeuvrer. Perhaps we
3251 should hold an IO mutex for the duration of every IO
3252 operation if we know that invalidate doesn't work on this
3253 platform, but that would suck, and could kill performance.
3255 Except that correctness trumps speed.
3256 Advice from klortho #11912. */
3258 dupfd = PerlLIO_dup(fd);
3261 MUTEX_UNLOCK(&PL_perlio_mutex);
3262 /* Oh cXap. This isn't going to go well. Not sure if we can
3263 recover from here, or if closing this particular FILE *
3264 is a good idea now. */
3269 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3271 result = PerlSIO_fclose(stdio);
3272 /* We treat error from stdio as success if we invalidated
3273 errno may NOT be expected EBADF
3275 if (invalidate && result != 0) {
3279 #ifdef SOCKS5_VERSION_NAME
3280 /* in SOCKS' case, let close() determine return value */
3284 PerlLIO_dup2(dupfd,fd);
3285 PerlLIO_close(dupfd);
3287 MUTEX_UNLOCK(&PL_perlio_mutex);
3295 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3299 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3301 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3304 STDCHAR *buf = (STDCHAR *) vbuf;
3306 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3307 * stdio does not do that for fread()
3309 const int ch = PerlSIO_fgetc(s);
3316 got = PerlSIO_fread(vbuf, 1, count, s);
3317 if (got == 0 && PerlSIO_ferror(s))
3319 if (got >= 0 || errno != EINTR)
3321 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3323 SETERRNO(0,0); /* just in case */
3329 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3332 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3334 #ifdef STDIO_BUFFER_WRITABLE
3335 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3336 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3337 STDCHAR *base = PerlIO_get_base(f);
3338 SSize_t cnt = PerlIO_get_cnt(f);
3339 STDCHAR *ptr = PerlIO_get_ptr(f);
3340 SSize_t avail = ptr - base;
3342 if (avail > count) {
3346 Move(buf-avail,ptr,avail,STDCHAR);
3349 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3350 if (PerlSIO_feof(s) && unread >= 0)
3351 PerlSIO_clearerr(s);
3356 if (PerlIO_has_cntptr(f)) {
3357 /* We can get pointer to buffer but not its base
3358 Do ungetc() but check chars are ending up in the
3361 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3362 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3364 const int ch = *--buf & 0xFF;
3365 if (ungetc(ch,s) != ch) {
3366 /* ungetc did not work */
3369 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3370 /* Did not change pointer as expected */
3371 if (fgetc(s) != EOF) /* get char back again */
3381 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3387 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3390 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3393 got = PerlSIO_fwrite(vbuf, 1, count,
3394 PerlIOSelf(f, PerlIOStdio)->stdio);
3395 if (got >= 0 || errno != EINTR)
3397 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3399 SETERRNO(0,0); /* just in case */
3405 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3407 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3408 PERL_UNUSED_CONTEXT;
3410 return PerlSIO_fseek(stdio, offset, whence);
3414 PerlIOStdio_tell(pTHX_ PerlIO *f)
3416 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3417 PERL_UNUSED_CONTEXT;
3419 return PerlSIO_ftell(stdio);
3423 PerlIOStdio_flush(pTHX_ PerlIO *f)
3425 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3426 PERL_UNUSED_CONTEXT;
3428 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3429 return PerlSIO_fflush(stdio);
3435 * FIXME: This discards ungetc() and pre-read stuff which is not
3436 * right if this is just a "sync" from a layer above Suspect right
3437 * design is to do _this_ but not have layer above flush this
3438 * layer read-to-read
3441 * Not writeable - sync by attempting a seek
3444 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3452 PerlIOStdio_eof(pTHX_ PerlIO *f)
3454 PERL_UNUSED_CONTEXT;
3456 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3460 PerlIOStdio_error(pTHX_ PerlIO *f)
3462 PERL_UNUSED_CONTEXT;
3464 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3468 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3470 PERL_UNUSED_CONTEXT;
3472 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3476 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3478 PERL_UNUSED_CONTEXT;
3480 #ifdef HAS_SETLINEBUF
3481 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3483 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3489 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3491 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3492 return (STDCHAR*)PerlSIO_get_base(stdio);
3496 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3498 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3499 return PerlSIO_get_bufsiz(stdio);
3503 #ifdef USE_STDIO_PTR
3505 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3507 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3508 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3512 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3514 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3515 return PerlSIO_get_cnt(stdio);
3519 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3521 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3523 #ifdef STDIO_PTR_LVALUE
3524 /* This is a long-standing infamous mess. The root of the
3525 * problem is that one cannot know the signedness of char, and
3526 * more precisely the signedness of FILE._ptr. The following
3527 * things have been tried, and they have all failed (across
3528 * different compilers (remember that core needs to to build
3529 * also with c++) and compiler options:
3531 * - casting the RHS to (void*) -- works in *some* places
3532 * - casting the LHS to (void*) -- totally unportable
3534 * So let's try silencing the warning at least for gcc. */
3535 GCC_DIAG_IGNORE(-Wpointer-sign);
3536 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3538 #ifdef STDIO_PTR_LVAL_SETS_CNT
3539 assert(PerlSIO_get_cnt(stdio) == (cnt));
3541 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3543 * Setting ptr _does_ change cnt - we are done
3547 #else /* STDIO_PTR_LVALUE */
3549 #endif /* STDIO_PTR_LVALUE */
3552 * Now (or only) set cnt
3554 #ifdef STDIO_CNT_LVALUE
3555 PerlSIO_set_cnt(stdio, cnt);
3556 #else /* STDIO_CNT_LVALUE */
3557 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3558 PerlSIO_set_ptr(stdio,
3559 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3561 #else /* STDIO_PTR_LVAL_SETS_CNT */
3563 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3564 #endif /* STDIO_CNT_LVALUE */
3571 PerlIOStdio_fill(pTHX_ PerlIO *f)
3575 PERL_UNUSED_CONTEXT;
3576 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3578 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3581 * fflush()ing read-only streams can cause trouble on some stdio-s
3583 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3584 if (PerlSIO_fflush(stdio) != 0)
3588 c = PerlSIO_fgetc(stdio);
3591 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3593 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3598 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3600 #ifdef STDIO_BUFFER_WRITABLE
3601 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3602 /* Fake ungetc() to the real buffer in case system's ungetc
3605 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3606 SSize_t cnt = PerlSIO_get_cnt(stdio);
3607 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3608 if (ptr == base+1) {
3609 *--ptr = (STDCHAR) c;
3610 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3611 if (PerlSIO_feof(stdio))
3612 PerlSIO_clearerr(stdio);
3618 if (PerlIO_has_cntptr(f)) {
3620 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3626 /* If buffer snoop scheme above fails fall back to
3629 if (PerlSIO_ungetc(c, stdio) != c)
3637 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3638 sizeof(PerlIO_funcs),
3640 sizeof(PerlIOStdio),
3641 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3645 PerlIOBase_binmode, /* binmode */
3659 PerlIOStdio_clearerr,
3660 PerlIOStdio_setlinebuf,
3662 PerlIOStdio_get_base,
3663 PerlIOStdio_get_bufsiz,
3668 #ifdef USE_STDIO_PTR
3669 PerlIOStdio_get_ptr,
3670 PerlIOStdio_get_cnt,
3671 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3672 PerlIOStdio_set_ptrcnt,
3675 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3680 #endif /* USE_STDIO_PTR */
3683 /* Note that calls to PerlIO_exportFILE() are reversed using
3684 * PerlIO_releaseFILE(), not importFILE. */
3686 PerlIO_exportFILE(PerlIO * f, const char *mode)
3690 if (PerlIOValid(f)) {
3692 int fd = PerlIO_fileno(f);
3697 if (!mode || !*mode) {
3698 mode = PerlIO_modestr(f, buf);
3700 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3704 /* De-link any lower layers so new :stdio sticks */
3706 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3707 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3709 PerlIOUnix_refcnt_inc(fileno(stdio));
3710 /* Link previous lower layers under new one */
3714 /* restore layers list */
3724 PerlIO_findFILE(PerlIO *f)
3729 if (l->tab == &PerlIO_stdio) {
3730 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3733 l = *PerlIONext(&l);
3735 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3736 /* However, we're not really exporting a FILE * to someone else (who
3737 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3738 So we need to undo its reference count increase on the underlying file
3739 descriptor. We have to do this, because if the loop above returns you
3740 the FILE *, then *it* didn't increase any reference count. So there's
3741 only one way to be consistent. */
3742 stdio = PerlIO_exportFILE(f, NULL);
3744 const int fd = fileno(stdio);
3746 PerlIOUnix_refcnt_dec(fd);
3751 /* Use this to reverse PerlIO_exportFILE calls. */
3753 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3757 if (l->tab == &PerlIO_stdio) {
3758 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3759 if (s->stdio == f) { /* not in a loop */
3760 const int fd = fileno(f);
3762 PerlIOUnix_refcnt_dec(fd);
3765 PerlIO_pop(aTHX_ p);
3775 /*--------------------------------------------------------------------------------------*/
3777 * perlio buffer layer
3781 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3783 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3784 const int fd = PerlIO_fileno(f);
3785 if (fd >= 0 && PerlLIO_isatty(fd)) {
3786 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3788 if (*PerlIONext(f)) {
3789 const Off_t posn = PerlIO_tell(PerlIONext(f));
3790 if (posn != (Off_t) - 1) {
3794 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3798 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3799 IV n, const char *mode, int fd, int imode, int perm,
3800 PerlIO *f, int narg, SV **args)
3802 if (PerlIOValid(f)) {
3803 PerlIO *next = PerlIONext(f);
3805 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3806 if (tab && tab->Open)
3808 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3810 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3815 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3817 if (*mode == IoTYPE_IMPLICIT) {
3823 if (tab && tab->Open)
3824 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3827 SETERRNO(EINVAL, LIB_INVARG);
3829 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3831 * if push fails during open, open fails. close will pop us.
3836 fd = PerlIO_fileno(f);
3837 if (init && fd == 2) {
3839 * Initial stderr is unbuffered
3841 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3843 #ifdef PERLIO_USING_CRLF
3844 # ifdef PERLIO_IS_BINMODE_FD
3845 if (PERLIO_IS_BINMODE_FD(fd))
3846 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3850 * do something about failing setmode()? --jhi
3852 PerlLIO_setmode(fd, O_BINARY);
3855 /* Enable line buffering with record-oriented regular files
3856 * so we don't introduce an extraneous record boundary when
3857 * the buffer fills up.
3859 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3861 if (PerlLIO_fstat(fd, &st) == 0
3862 && S_ISREG(st.st_mode)
3863 && (st.st_fab_rfm == FAB$C_VAR
3864 || st.st_fab_rfm == FAB$C_VFC)) {
3865 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3876 * This "flush" is akin to sfio's sync in that it handles files in either
3877 * read or write state. For write state, we put the postponed data through
3878 * the next layers. For read state, we seek() the next layers to the
3879 * offset given by current position in the buffer, and discard the buffer
3880 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3881 * in any case?). Then the pass the stick further in chain.
3884 PerlIOBuf_flush(pTHX_ PerlIO *f)
3886 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3888 PerlIO *n = PerlIONext(f);
3889 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3891 * write() the buffer
3893 const STDCHAR *buf = b->buf;
3894 const STDCHAR *p = buf;
3895 while (p < b->ptr) {
3896 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3900 else if (count < 0 || PerlIO_error(n)) {
3901 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3906 b->posn += (p - buf);
3908 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3909 STDCHAR *buf = PerlIO_get_base(f);
3911 * Note position change
3913 b->posn += (b->ptr - buf);
3914 if (b->ptr < b->end) {
3915 /* We did not consume all of it - try and seek downstream to
3916 our logical position
3918 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3919 /* Reload n as some layers may pop themselves on seek */
3920 b->posn = PerlIO_tell(n = PerlIONext(f));
3923 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3924 data is lost for good - so return saying "ok" having undone
3927 b->posn -= (b->ptr - buf);
3932 b->ptr = b->end = b->buf;
3933 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3934 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3935 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3940 /* This discards the content of the buffer after b->ptr, and rereads
3941 * the buffer from the position off in the layer downstream; here off
3942 * is at offset corresponding to b->ptr - b->buf.
3945 PerlIOBuf_fill(pTHX_ PerlIO *f)
3947 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3948 PerlIO *n = PerlIONext(f);
3951 * Down-stream flush is defined not to loose read data so is harmless.
3952 * we would not normally be fill'ing if there was data left in anycase.
3954 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3956 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3957 PerlIOBase_flush_linebuf(aTHX);
3960 PerlIO_get_base(f); /* allocate via vtable */
3962 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3964 b->ptr = b->end = b->buf;
3966 if (!PerlIOValid(n)) {
3967 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3971 if (PerlIO_fast_gets(n)) {
3973 * Layer below is also buffered. We do _NOT_ want to call its
3974 * ->Read() because that will loop till it gets what we asked for
3975 * which may hang on a pipe etc. Instead take anything it has to
3976 * hand, or ask it to fill _once_.
3978 avail = PerlIO_get_cnt(n);
3980 avail = PerlIO_fill(n);
3982 avail = PerlIO_get_cnt(n);
3984 if (!PerlIO_error(n) && PerlIO_eof(n))
3989 STDCHAR *ptr = PerlIO_get_ptr(n);
3990 const SSize_t cnt = avail;
3991 if (avail > (SSize_t)b->bufsiz)
3993 Copy(ptr, b->buf, avail, STDCHAR);
3994 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3998 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4002 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4004 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4007 b->end = b->buf + avail;
4008 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4013 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4015 if (PerlIOValid(f)) {
4016 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4019 return PerlIOBase_read(aTHX_ f, vbuf, count);
4025 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4027 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4028 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4031 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4036 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4038 * Buffer is already a read buffer, we can overwrite any chars
4039 * which have been read back to buffer start
4041 avail = (b->ptr - b->buf);
4045 * Buffer is idle, set it up so whole buffer is available for
4049 b->end = b->buf + avail;
4051 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4053 * Buffer extends _back_ from where we are now
4055 b->posn -= b->bufsiz;
4057 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4059 * If we have space for more than count, just move count
4067 * In simple stdio-like ungetc() case chars will be already
4070 if (buf != b->ptr) {
4071 Copy(buf, b->ptr, avail, STDCHAR);
4075 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4079 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4085 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4087 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4088 const STDCHAR *buf = (const STDCHAR *) vbuf;
4089 const STDCHAR *flushptr = buf;
4093 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4095 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4096 if (PerlIO_flush(f) != 0) {
4100 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4101 flushptr = buf + count;
4102 while (flushptr > buf && *(flushptr - 1) != '\n')
4106 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4107 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4109 if (flushptr > buf && flushptr <= buf + avail)
4110 avail = flushptr - buf;
4111 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4113 Copy(buf, b->ptr, avail, STDCHAR);
4118 if (buf == flushptr)
4121 if (b->ptr >= (b->buf + b->bufsiz))
4122 if (PerlIO_flush(f) == -1)
4125 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4131 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4134 if ((code = PerlIO_flush(f)) == 0) {
4135 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4136 code = PerlIO_seek(PerlIONext(f), offset, whence);
4138 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4139 b->posn = PerlIO_tell(PerlIONext(f));
4146 PerlIOBuf_tell(pTHX_ PerlIO *f)
4148 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4150 * b->posn is file position where b->buf was read, or will be written
4152 Off_t posn = b->posn;
4153 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4154 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4156 /* As O_APPEND files are normally shared in some sense it is better
4161 /* when file is NOT shared then this is sufficient */
4162 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4164 posn = b->posn = PerlIO_tell(PerlIONext(f));
4168 * If buffer is valid adjust position by amount in buffer
4170 posn += (b->ptr - b->buf);
4176 PerlIOBuf_popped(pTHX_ PerlIO *f)
4178 const IV code = PerlIOBase_popped(aTHX_ f);
4179 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4180 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4183 b->ptr = b->end = b->buf = NULL;
4184 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4189 PerlIOBuf_close(pTHX_ PerlIO *f)
4191 const IV code = PerlIOBase_close(aTHX_ f);
4192 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4193 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4196 b->ptr = b->end = b->buf = NULL;
4197 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4202 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4204 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4211 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4213 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4216 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4217 return (b->end - b->ptr);
4222 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4224 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4225 PERL_UNUSED_CONTEXT;
4229 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4230 Newxz(b->buf,b->bufsiz, STDCHAR);
4232 b->buf = (STDCHAR *) & b->oneword;
4233 b->bufsiz = sizeof(b->oneword);
4235 b->end = b->ptr = b->buf;
4241 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4243 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4246 return (b->end - b->buf);
4250 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4252 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4254 PERL_UNUSED_ARG(cnt);
4259 assert(PerlIO_get_cnt(f) == cnt);
4260 assert(b->ptr >= b->buf);
4261 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4265 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4267 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4272 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4273 sizeof(PerlIO_funcs),
4276 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4280 PerlIOBase_binmode, /* binmode */
4294 PerlIOBase_clearerr,
4295 PerlIOBase_setlinebuf,
4300 PerlIOBuf_set_ptrcnt,
4303 /*--------------------------------------------------------------------------------------*/
4305 * Temp layer to hold unread chars when cannot do it any other way
4309 PerlIOPending_fill(pTHX_ PerlIO *f)
4312 * Should never happen
4319 PerlIOPending_close(pTHX_ PerlIO *f)
4322 * A tad tricky - flush pops us, then we close new top
4325 return PerlIO_close(f);
4329 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4332 * A tad tricky - flush pops us, then we seek new top
4335 return PerlIO_seek(f, offset, whence);
4340 PerlIOPending_flush(pTHX_ PerlIO *f)
4342 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4343 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4347 PerlIO_pop(aTHX_ f);
4352 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4358 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4363 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4365 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4366 PerlIOl * const l = PerlIOBase(f);
4368 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4369 * etc. get muddled when it changes mid-string when we auto-pop.
4371 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4372 (PerlIOBase(PerlIONext(f))->
4373 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4378 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4380 SSize_t avail = PerlIO_get_cnt(f);
4382 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4385 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4386 if (got >= 0 && got < (SSize_t)count) {
4387 const SSize_t more =
4388 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4389 if (more >= 0 || got == 0)
4395 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4396 sizeof(PerlIO_funcs),
4399 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4400 PerlIOPending_pushed,
4403 PerlIOBase_binmode, /* binmode */
4412 PerlIOPending_close,
4413 PerlIOPending_flush,
4417 PerlIOBase_clearerr,
4418 PerlIOBase_setlinebuf,
4423 PerlIOPending_set_ptrcnt,
4428 /*--------------------------------------------------------------------------------------*/
4430 * crlf - translation On read translate CR,LF to "\n" we do this by
4431 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4432 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4434 * c->nl points on the first byte of CR LF pair when it is temporarily
4435 * replaced by LF, or to the last CR of the buffer. In the former case
4436 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4437 * that it ends at c->nl; these two cases can be distinguished by
4438 * *c->nl. c->nl is set during _getcnt() call, and unset during
4439 * _unread() and _flush() calls.
4440 * It only matters for read operations.
4444 PerlIOBuf base; /* PerlIOBuf stuff */
4445 STDCHAR *nl; /* Position of crlf we "lied" about in the
4449 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4450 * Otherwise the :crlf layer would always revert back to
4454 S_inherit_utf8_flag(PerlIO *f)
4456 PerlIO *g = PerlIONext(f);
4457 if (PerlIOValid(g)) {
4458 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4459 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4465 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4468 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4469 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4471 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4472 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4473 PerlIOBase(f)->flags);
4476 /* If the old top layer is a CRLF layer, reactivate it (if
4477 * necessary) and remove this new layer from the stack */
4478 PerlIO *g = PerlIONext(f);
4479 if (PerlIOValid(g)) {
4480 PerlIOl *b = PerlIOBase(g);
4481 if (b && b->tab == &PerlIO_crlf) {
4482 if (!(b->flags & PERLIO_F_CRLF))
4483 b->flags |= PERLIO_F_CRLF;
4484 S_inherit_utf8_flag(g);
4485 PerlIO_pop(aTHX_ f);
4490 S_inherit_utf8_flag(f);
4496 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4498 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4499 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4500 *(c->nl) = NATIVE_0xd;
4503 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4504 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4506 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4507 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4509 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4514 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4515 b->end = b->ptr = b->buf + b->bufsiz;
4516 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4517 b->posn -= b->bufsiz;
4519 while (count > 0 && b->ptr > b->buf) {
4520 const int ch = *--buf;
4522 if (b->ptr - 2 >= b->buf) {
4523 *--(b->ptr) = NATIVE_0xa;
4524 *--(b->ptr) = NATIVE_0xd;
4529 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4530 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4544 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4549 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4551 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4553 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4556 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4557 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4558 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4559 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4561 while (nl < b->end && *nl != NATIVE_0xd)
4563 if (nl < b->end && *nl == NATIVE_0xd) {
4565 if (nl + 1 < b->end) {
4566 if (nl[1] == NATIVE_0xa) {
4572 * Not CR,LF but just CR
4580 * Blast - found CR as last char in buffer
4585 * They may not care, defer work as long as
4589 return (nl - b->ptr);
4593 b->ptr++; /* say we have read it as far as
4594 * flush() is concerned */
4595 b->buf++; /* Leave space in front of buffer */
4596 /* Note as we have moved buf up flush's
4598 will naturally make posn point at CR
4600 b->bufsiz--; /* Buffer is thus smaller */
4601 code = PerlIO_fill(f); /* Fetch some more */
4602 b->bufsiz++; /* Restore size for next time */
4603 b->buf--; /* Point at space */
4604 b->ptr = nl = b->buf; /* Which is what we hand
4606 *nl = NATIVE_0xd; /* Fill in the CR */
4608 goto test; /* fill() call worked */
4610 * CR at EOF - just fall through
4612 /* Should we clear EOF though ??? */
4617 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4623 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4625 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4626 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4632 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4633 /* Deferred CR at end of buffer case - we lied about count */
4646 * Test code - delete when it works ...
4648 IV flags = PerlIOBase(f)->flags;
4649 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4650 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4651 /* Deferred CR at end of buffer case - we lied about count */
4657 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4658 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4659 flags, c->nl, b->end, cnt);
4666 * They have taken what we lied about
4668 *(c->nl) = NATIVE_0xd;
4674 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4678 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4680 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4681 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4683 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4684 const STDCHAR *buf = (const STDCHAR *) vbuf;
4685 const STDCHAR * const ebuf = buf + count;
4688 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4690 while (buf < ebuf) {
4691 const STDCHAR * const eptr = b->buf + b->bufsiz;
4692 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4693 while (buf < ebuf && b->ptr < eptr) {
4695 if ((b->ptr + 2) > eptr) {
4703 *(b->ptr)++ = NATIVE_0xd; /* CR */
4704 *(b->ptr)++ = NATIVE_0xa; /* LF */
4706 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4713 *(b->ptr)++ = *buf++;
4715 if (b->ptr >= eptr) {
4721 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4723 return (buf - (STDCHAR *) vbuf);
4728 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4730 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4732 *(c->nl) = NATIVE_0xd;
4735 return PerlIOBuf_flush(aTHX_ f);
4739 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4741 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4742 /* In text mode - flush any pending stuff and flip it */
4743 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4744 #ifndef PERLIO_USING_CRLF
4745 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4746 PerlIO_pop(aTHX_ f);
4752 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4753 sizeof(PerlIO_funcs),
4756 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4758 PerlIOBuf_popped, /* popped */
4760 PerlIOCrlf_binmode, /* binmode */
4764 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4765 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4766 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4774 PerlIOBase_clearerr,
4775 PerlIOBase_setlinebuf,
4780 PerlIOCrlf_set_ptrcnt,
4784 Perl_PerlIO_stdin(pTHX)
4787 PerlIO_stdstreams(aTHX);
4789 return (PerlIO*)&PL_perlio[1];
4793 Perl_PerlIO_stdout(pTHX)
4796 PerlIO_stdstreams(aTHX);
4798 return (PerlIO*)&PL_perlio[2];
4802 Perl_PerlIO_stderr(pTHX)
4805 PerlIO_stdstreams(aTHX);
4807 return (PerlIO*)&PL_perlio[3];
4810 /*--------------------------------------------------------------------------------------*/
4813 PerlIO_getname(PerlIO *f, char *buf)
4818 bool exported = FALSE;
4819 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4821 stdio = PerlIO_exportFILE(f,0);
4825 name = fgetname(stdio, buf);
4826 if (exported) PerlIO_releaseFILE(f,stdio);
4831 PERL_UNUSED_ARG(buf);
4832 Perl_croak_nocontext("Don't know how to get file name");
4838 /*--------------------------------------------------------------------------------------*/
4840 * Functions which can be called on any kind of PerlIO implemented in
4844 #undef PerlIO_fdopen
4846 PerlIO_fdopen(int fd, const char *mode)
4849 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4854 PerlIO_open(const char *path, const char *mode)
4857 SV *name = sv_2mortal(newSVpv(path, 0));
4858 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4861 #undef Perlio_reopen
4863 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4866 SV *name = sv_2mortal(newSVpv(path,0));
4867 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4872 PerlIO_getc(PerlIO *f)
4876 if ( 1 == PerlIO_read(f, buf, 1) ) {
4877 return (unsigned char) buf[0];
4882 #undef PerlIO_ungetc
4884 PerlIO_ungetc(PerlIO *f, int ch)
4889 if (PerlIO_unread(f, &buf, 1) == 1)
4897 PerlIO_putc(PerlIO *f, int ch)
4901 return PerlIO_write(f, &buf, 1);
4906 PerlIO_puts(PerlIO *f, const char *s)
4909 return PerlIO_write(f, s, strlen(s));
4912 #undef PerlIO_rewind
4914 PerlIO_rewind(PerlIO *f)
4917 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4921 #undef PerlIO_vprintf
4923 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4932 Perl_va_copy(ap, apc);
4933 sv = vnewSVpvf(fmt, &apc);
4936 sv = vnewSVpvf(fmt, &ap);
4938 s = SvPV_const(sv, len);
4939 wrote = PerlIO_write(f, s, len);
4944 #undef PerlIO_printf
4946 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4951 result = PerlIO_vprintf(f, fmt, ap);
4956 #undef PerlIO_stdoutf
4958 PerlIO_stdoutf(const char *fmt, ...)
4964 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4969 #undef PerlIO_tmpfile
4971 PerlIO_tmpfile(void)
4978 const int fd = win32_tmpfd();
4980 f = PerlIO_fdopen(fd, "w+b");
4982 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4984 char tempname[] = "/tmp/PerlIO_XXXXXX";
4985 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
4987 int old_umask = umask(0600);
4989 * I have no idea how portable mkstemp() is ... NI-S
4991 if (tmpdir && *tmpdir) {
4992 /* if TMPDIR is set and not empty, we try that first */
4993 sv = newSVpv(tmpdir, 0);
4994 sv_catpv(sv, tempname + 4);
4995 fd = mkstemp(SvPVX(sv));
5000 /* else we try /tmp */
5001 fd = mkstemp(tempname);
5006 sv_catpv(sv, tempname + 4);
5007 fd = mkstemp(SvPVX(sv));
5011 f = PerlIO_fdopen(fd, "w+");
5013 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5014 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5017 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5018 FILE * const stdio = PerlSIO_tmpfile();
5021 f = PerlIO_fdopen(fileno(stdio), "w+");
5023 # endif /* else HAS_MKSTEMP */
5024 #endif /* else WIN32 */
5031 #endif /* PERLIO_IS_STDIO */
5033 /*======================================================================================*/
5035 * Now some functions in terms of above which may be needed even if we are
5036 * not in true PerlIO mode
5039 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5041 const char *direction = NULL;
5044 * Need to supply default layer info from open.pm
5050 if (mode && mode[0] != 'r') {
5051 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5052 direction = "open>";
5054 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5055 direction = "open<";
5060 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5063 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5068 #undef PerlIO_setpos
5070 PerlIO_setpos(PerlIO *f, SV *pos)
5075 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5076 if (f && len == sizeof(Off_t))
5077 return PerlIO_seek(f, *posn, SEEK_SET);
5079 SETERRNO(EINVAL, SS_IVCHAN);
5083 #undef PerlIO_setpos
5085 PerlIO_setpos(PerlIO *f, SV *pos)
5090 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5091 if (f && len == sizeof(Fpos_t)) {
5092 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5093 return fsetpos64(f, fpos);
5095 return fsetpos(f, fpos);
5099 SETERRNO(EINVAL, SS_IVCHAN);
5105 #undef PerlIO_getpos
5107 PerlIO_getpos(PerlIO *f, SV *pos)
5110 Off_t posn = PerlIO_tell(f);
5111 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5112 return (posn == (Off_t) - 1) ? -1 : 0;
5115 #undef PerlIO_getpos
5117 PerlIO_getpos(PerlIO *f, SV *pos)
5122 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5123 code = fgetpos64(f, &fpos);
5125 code = fgetpos(f, &fpos);
5127 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5132 #if !defined(HAS_VPRINTF)
5135 vprintf(char *pat, char *args)
5137 _doprnt(pat, args, stdout);
5138 return 0; /* wrong, but perl doesn't use the return
5143 vfprintf(FILE *fd, char *pat, char *args)
5145 _doprnt(pat, args, fd);
5146 return 0; /* wrong, but perl doesn't use the return
5154 * c-indentation-style: bsd
5156 * indent-tabs-mode: nil
5159 * ex: set ts=8 sts=4 sw=4 et: