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
38 # ifndef USE_CROSS_COMPILE
45 #define PERLIO_NOT_STDIO 0
46 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
52 * This file provides those parts of PerlIO abstraction
53 * which are not #defined in perlio.h.
54 * Which these are depends on various Configure #ifdef's
58 #define PERL_IN_PERLIO_C
61 #ifdef PERL_IMPLICIT_CONTEXT
69 /* Missing proto on LynxOS */
77 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
79 /* Call the callback or PerlIOBase, and return failure. */
80 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
81 if (PerlIOValid(f)) { \
82 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
83 if (tab && tab->callback) \
84 return (*tab->callback) args; \
86 return PerlIOBase_ ## base args; \
89 SETERRNO(EBADF, SS_IVCHAN); \
92 /* Call the callback or fail, and return failure. */
93 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
94 if (PerlIOValid(f)) { \
95 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
96 if (tab && tab->callback) \
97 return (*tab->callback) args; \
98 SETERRNO(EINVAL, LIB_INVARG); \
101 SETERRNO(EBADF, SS_IVCHAN); \
104 /* Call the callback or PerlIOBase, and be void. */
105 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
106 if (PerlIOValid(f)) { \
107 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
108 if (tab && tab->callback) \
109 (*tab->callback) args; \
111 PerlIOBase_ ## base args; \
114 SETERRNO(EBADF, SS_IVCHAN)
116 /* Call the callback or fail, and be void. */
117 #define Perl_PerlIO_or_fail_void(f, callback, args) \
118 if (PerlIOValid(f)) { \
119 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
120 if (tab && tab->callback) \
121 (*tab->callback) args; \
123 SETERRNO(EINVAL, LIB_INVARG); \
126 SETERRNO(EBADF, SS_IVCHAN)
128 #if defined(__osf__) && _XOPEN_SOURCE < 500
129 extern int fseeko(FILE *, off_t, int);
130 extern off_t ftello(FILE *);
135 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
138 perlsio_binmode(FILE *fp, int iotype, int mode)
141 * This used to be contents of do_binmode in doio.c
145 PERL_UNUSED_ARG(iotype);
147 if (PerlLIO_setmode(fp, mode) != -1) {
149 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
156 # if defined(USEMYBINMODE)
158 # if defined(__CYGWIN__)
159 PERL_UNUSED_ARG(iotype);
161 if (my_binmode(fp, iotype, mode) != FALSE)
167 PERL_UNUSED_ARG(iotype);
168 PERL_UNUSED_ARG(mode);
176 #define O_ACCMODE 3 /* Assume traditional implementation */
180 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
182 const int result = rawmode & O_ACCMODE;
187 ptype = IoTYPE_RDONLY;
190 ptype = IoTYPE_WRONLY;
198 *writing = (result != O_RDONLY);
200 if (result == O_RDONLY) {
204 else if (rawmode & O_APPEND) {
206 if (result != O_WRONLY)
211 if (result == O_WRONLY)
218 if (rawmode & O_BINARY)
224 #ifndef PERLIO_LAYERS
226 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
228 if (!names || !*names
229 || strEQ(names, ":crlf")
230 || strEQ(names, ":raw")
231 || strEQ(names, ":bytes")
235 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
243 PerlIO_destruct(pTHX)
248 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
251 PERL_UNUSED_ARG(iotype);
252 PERL_UNUSED_ARG(mode);
253 PERL_UNUSED_ARG(names);
256 return perlsio_binmode(fp, iotype, mode);
261 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
263 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
266 #ifdef PERL_IMPLICIT_SYS
267 return PerlSIO_fdupopen(f);
270 return win32_fdupopen(f);
273 const int fd = PerlLIO_dup(PerlIO_fileno(f));
277 const int omode = djgpp_get_stream_mode(f);
279 const int omode = fcntl(fd, F_GETFL);
281 PerlIO_intmode2str(omode,mode,NULL);
282 /* the r+ is a hack */
283 return PerlIO_fdopen(fd, mode);
288 SETERRNO(EBADF, SS_IVCHAN);
298 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
302 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
303 int imode, int perm, PerlIO *old, int narg, SV **args)
307 Perl_croak(aTHX_ "More than one argument to open");
309 if (*args == &PL_sv_undef)
310 return PerlIO_tmpfile();
312 const char *name = SvPV_nolen_const(*args);
313 if (*mode == IoTYPE_NUMERIC) {
314 fd = PerlLIO_open3(name, imode, perm);
316 return PerlIO_fdopen(fd, mode + 1);
319 return PerlIO_reopen(name, mode, old);
322 return PerlIO_open(name, mode);
327 return PerlIO_fdopen(fd, (char *) mode);
332 XS(XS_PerlIO__Layer__find)
336 Perl_croak(aTHX_ "Usage class->find(name[,load])");
338 const char * const name = SvPV_nolen_const(ST(1));
339 ST(0) = (strEQ(name, "crlf")
340 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
347 Perl_boot_core_PerlIO(pTHX)
349 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
355 #ifdef PERLIO_IS_STDIO
362 * Does nothing (yet) except force this file to be included in perl
363 * binary. That allows this file to force inclusion of other functions
364 * that may be required by loadable extensions e.g. for
365 * FileHandle::tmpfile
369 #undef PerlIO_tmpfile
376 #else /* PERLIO_IS_STDIO */
384 * This section is just to make sure these functions get pulled in from
388 #undef PerlIO_tmpfile
400 * Force this file to be included in perl binary. Which allows this
401 * file to force inclusion of other functions that may be required by
402 * loadable extensions e.g. for FileHandle::tmpfile
406 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
407 * results in a lot of lseek()s to regular files and lot of small
410 sfset(sfstdout, SF_SHARE, 0);
413 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
415 PerlIO_importFILE(FILE *stdio, const char *mode)
417 const int fd = fileno(stdio);
418 if (!mode || !*mode) {
421 return PerlIO_fdopen(fd, mode);
425 PerlIO_findFILE(PerlIO *pio)
427 const int fd = PerlIO_fileno(pio);
428 FILE * const f = fdopen(fd, "r+");
430 if (!f && errno == EINVAL)
432 if (!f && errno == EINVAL)
439 /*======================================================================================*/
441 * Implement all the PerlIO interface ourselves.
447 PerlIO_debug(const char *fmt, ...)
452 if (!PL_perlio_debug_fd) {
454 PerlProc_getuid() == PerlProc_geteuid() &&
455 PerlProc_getgid() == PerlProc_getegid()) {
456 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
459 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
461 PL_perlio_debug_fd = -1;
463 /* tainting or set*id, so ignore the environment, and ensure we
464 skip these tests next time through. */
465 PL_perlio_debug_fd = -1;
468 if (PL_perlio_debug_fd > 0) {
470 const char * const s = CopFILE(PL_curcop);
471 /* Use fixed buffer as sv_catpvf etc. needs SVs */
473 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
474 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
475 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
477 const char *s = CopFILE(PL_curcop);
479 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
480 (IV) CopLINE(PL_curcop));
481 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
483 s = SvPV_const(sv, len);
484 PerlLIO_write(PL_perlio_debug_fd, s, len);
491 /*--------------------------------------------------------------------------------------*/
494 * Inner level routines
497 /* check that the head field of each layer points back to the head */
500 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
502 PerlIO_verify_head(pTHX_ PerlIO *f)
508 p = head = PerlIOBase(f)->head;
511 assert(p->head == head);
512 if (p == (PerlIOl*)f)
519 # define VERIFY_HEAD(f)
524 * Table of pointers to the PerlIO structs (malloc'ed)
526 #define PERLIO_TABLE_SIZE 64
529 PerlIO_init_table(pTHX)
533 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
539 PerlIO_allocate(pTHX)
543 * Find a free slot in the table, allocating new table as necessary
548 while ((f = *last)) {
550 last = (PerlIOl **) (f);
551 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
552 if (!((++f)->next)) {
553 f->flags = 0; /* lockcnt */
560 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
564 *last = (PerlIOl*) f++;
565 f->flags = 0; /* lockcnt */
571 #undef PerlIO_fdupopen
573 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
575 if (PerlIOValid(f)) {
576 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
577 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
579 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
581 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
585 SETERRNO(EBADF, SS_IVCHAN);
591 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
593 PerlIOl * const table = *tablep;
596 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
597 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
598 PerlIOl * const f = table + i;
600 PerlIO_close(&(f->next));
610 PerlIO_list_alloc(pTHX)
614 Newxz(list, 1, PerlIO_list_t);
620 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
623 if (--list->refcnt == 0) {
626 for (i = 0; i < list->cur; i++)
627 SvREFCNT_dec(list->array[i].arg);
628 Safefree(list->array);
636 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
642 if (list->cur >= list->len) {
645 Renew(list->array, list->len, PerlIO_pair_t);
647 Newx(list->array, list->len, PerlIO_pair_t);
649 p = &(list->array[list->cur++]);
651 if ((p->arg = arg)) {
652 SvREFCNT_inc_simple_void_NN(arg);
657 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
659 PerlIO_list_t *list = NULL;
662 list = PerlIO_list_alloc(aTHX);
663 for (i=0; i < proto->cur; i++) {
664 SV *arg = proto->array[i].arg;
667 arg = sv_dup(arg, param);
669 PERL_UNUSED_ARG(param);
671 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
678 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
681 PerlIOl **table = &proto->Iperlio;
684 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
685 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
686 PerlIO_init_table(aTHX);
687 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
688 while ((f = *table)) {
690 table = (PerlIOl **) (f++);
691 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
693 (void) fp_dup(&(f->next), 0, param);
700 PERL_UNUSED_ARG(proto);
701 PERL_UNUSED_ARG(param);
706 PerlIO_destruct(pTHX)
709 PerlIOl **table = &PL_perlio;
712 PerlIO_debug("Destruct %p\n",(void*)aTHX);
714 while ((f = *table)) {
716 table = (PerlIOl **) (f++);
717 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
718 PerlIO *x = &(f->next);
721 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
722 PerlIO_debug("Destruct popping %s\n", l->tab->name);
736 PerlIO_pop(pTHX_ PerlIO *f)
738 const PerlIOl *l = *f;
741 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
742 l->tab ? l->tab->name : "(Null)");
743 if (l->tab && l->tab->Popped) {
745 * If popped returns non-zero do not free its layer structure
746 * it has either done so itself, or it is shared and still in
749 if ((*l->tab->Popped) (aTHX_ f) != 0)
752 if (PerlIO_lockcnt(f)) {
753 /* we're in use; defer freeing the structure */
754 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
755 PerlIOBase(f)->tab = NULL;
765 /* Return as an array the stack of layers on a filehandle. Note that
766 * the stack is returned top-first in the array, and there are three
767 * times as many array elements as there are layers in the stack: the
768 * first element of a layer triplet is the name, the second one is the
769 * arguments, and the third one is the flags. */
772 PerlIO_get_layers(pTHX_ PerlIO *f)
775 AV * const av = newAV();
777 if (PerlIOValid(f)) {
778 PerlIOl *l = PerlIOBase(f);
781 /* There is some collusion in the implementation of
782 XS_PerlIO_get_layers - it knows that name and flags are
783 generated as fresh SVs here, and takes advantage of that to
784 "copy" them by taking a reference. If it changes here, it needs
785 to change there too. */
786 SV * const name = l->tab && l->tab->name ?
787 newSVpv(l->tab->name, 0) : &PL_sv_undef;
788 SV * const arg = l->tab && l->tab->Getarg ?
789 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
792 av_push(av, newSViv((IV)l->flags));
800 /*--------------------------------------------------------------------------------------*/
802 * XS Interface for perl code
806 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
810 if ((SSize_t) len <= 0)
812 for (i = 0; i < PL_known_layers->cur; i++) {
813 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
814 if (memEQ(f->name, name, len) && f->name[len] == 0) {
815 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
819 if (load && PL_subname && PL_def_layerlist
820 && PL_def_layerlist->cur >= 2) {
821 if (PL_in_load_module) {
822 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
825 SV * const pkgsv = newSVpvs("PerlIO");
826 SV * const layer = newSVpvn(name, len);
827 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
829 SAVEBOOL(PL_in_load_module);
831 SAVEGENERICSV(PL_warnhook);
832 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
834 PL_in_load_module = TRUE;
836 * The two SVs are magically freed by load_module
838 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
840 return PerlIO_find_layer(aTHX_ name, len, 0);
843 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
847 #ifdef USE_ATTRIBUTES_FOR_PERLIO
850 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
853 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
854 PerlIO * const ifp = IoIFP(io);
855 PerlIO * const ofp = IoOFP(io);
856 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
857 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
863 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
866 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
867 PerlIO * const ifp = IoIFP(io);
868 PerlIO * const ofp = IoOFP(io);
869 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
870 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
876 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
878 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
883 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
885 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
889 MGVTBL perlio_vtab = {
897 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
900 SV * const sv = SvRV(ST(1));
901 AV * const av = newAV();
905 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
907 mg = mg_find(sv, PERL_MAGIC_ext);
908 mg->mg_virtual = &perlio_vtab;
910 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
911 for (i = 2; i < items; i++) {
913 const char * const name = SvPV_const(ST(i), len);
914 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
916 av_push(av, SvREFCNT_inc_simple_NN(layer));
927 #endif /* USE_ATTIBUTES_FOR_PERLIO */
930 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
932 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
933 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
937 XS(XS_PerlIO__Layer__NoWarnings)
939 /* This is used as a %SIG{__WARN__} handler to suppress warnings
940 during loading of layers.
946 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
950 XS(XS_PerlIO__Layer__find)
956 Perl_croak(aTHX_ "Usage class->find(name[,load])");
959 const char * const name = SvPV_const(ST(1), len);
960 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
961 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
963 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
970 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
973 if (!PL_known_layers)
974 PL_known_layers = PerlIO_list_alloc(aTHX);
975 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
976 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
980 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
984 const char *s = names;
986 while (isSPACE(*s) || *s == ':')
991 const char *as = NULL;
993 if (!isIDFIRST(*s)) {
995 * Message is consistent with how attribute lists are
996 * passed. Even though this means "foo : : bar" is
997 * seen as an invalid separator character.
999 const char q = ((*s == '\'') ? '"' : '\'');
1000 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1001 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1003 SETERRNO(EINVAL, LIB_INVARG);
1008 } while (isALNUM(*e));
1017 alen = (e - 1) - as;
1024 * It's a nul terminated string, not allowed
1025 * to \ the terminating null. Anything other
1026 * character is passed over.
1036 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1037 "Argument list not closed for PerlIO layer \"%.*s\"",
1049 PerlIO_funcs * const layer =
1050 PerlIO_find_layer(aTHX_ s, llen, 1);
1054 arg = newSVpvn(as, alen);
1055 PerlIO_list_push(aTHX_ av, layer,
1056 (arg) ? arg : &PL_sv_undef);
1060 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1073 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1076 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1077 #ifdef PERLIO_USING_CRLF
1080 if (PerlIO_stdio.Set_ptrcnt)
1081 tab = &PerlIO_stdio;
1083 PerlIO_debug("Pushing %s\n", tab->name);
1084 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1089 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1091 return av->array[n].arg;
1095 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1097 if (n >= 0 && n < av->cur) {
1098 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1099 av->array[n].funcs->name);
1100 return av->array[n].funcs;
1103 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1108 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1110 PERL_UNUSED_ARG(mode);
1111 PERL_UNUSED_ARG(arg);
1112 PERL_UNUSED_ARG(tab);
1113 if (PerlIOValid(f)) {
1115 PerlIO_pop(aTHX_ f);
1121 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1122 sizeof(PerlIO_funcs),
1125 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1145 NULL, /* get_base */
1146 NULL, /* get_bufsiz */
1149 NULL, /* set_ptrcnt */
1153 PerlIO_default_layers(pTHX)
1156 if (!PL_def_layerlist) {
1157 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1158 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1159 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1160 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1162 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1164 osLayer = &PerlIO_win32;
1167 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1168 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1169 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1170 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1171 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1172 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1173 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1174 PerlIO_list_push(aTHX_ PL_def_layerlist,
1175 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1178 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1181 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1184 if (PL_def_layerlist->cur < 2) {
1185 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1187 return PL_def_layerlist;
1191 Perl_boot_core_PerlIO(pTHX)
1193 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1194 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1197 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1198 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1202 PerlIO_default_layer(pTHX_ I32 n)
1205 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1208 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1211 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1212 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1215 PerlIO_stdstreams(pTHX)
1219 PerlIO_init_table(aTHX);
1220 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1221 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1222 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1227 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1230 if (tab->fsize != sizeof(PerlIO_funcs)) {
1232 "%s (%"UVuf") does not match %s (%"UVuf")",
1233 "PerlIO layer function table size", (UV)tab->fsize,
1234 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1238 if (tab->size < sizeof(PerlIOl)) {
1240 "%s (%"UVuf") smaller than %s (%"UVuf")",
1241 "PerlIO layer instance size", (UV)tab->size,
1242 "size expected by this perl", (UV)sizeof(PerlIOl) );
1244 /* Real layer with a data area */
1247 Newxz(temp, tab->size, char);
1251 l->tab = (PerlIO_funcs*) tab;
1252 l->head = ((PerlIOl*)f)->head;
1254 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1255 (void*)f, tab->name,
1256 (mode) ? mode : "(Null)", (void*)arg);
1257 if (*l->tab->Pushed &&
1259 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1260 PerlIO_pop(aTHX_ f);
1269 /* Pseudo-layer where push does its own stack adjust */
1270 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1271 (mode) ? mode : "(Null)", (void*)arg);
1273 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1281 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1282 IV n, const char *mode, int fd, int imode, int perm,
1283 PerlIO *old, int narg, SV **args)
1285 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1286 if (tab && tab->Open) {
1287 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1288 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1294 SETERRNO(EINVAL, LIB_INVARG);
1299 PerlIOBase_binmode(pTHX_ PerlIO *f)
1301 if (PerlIOValid(f)) {
1302 /* Is layer suitable for raw stream ? */
1303 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1304 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1305 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1308 /* Not suitable - pop it */
1309 PerlIO_pop(aTHX_ f);
1317 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1319 PERL_UNUSED_ARG(mode);
1320 PERL_UNUSED_ARG(arg);
1321 PERL_UNUSED_ARG(tab);
1323 if (PerlIOValid(f)) {
1328 * Strip all layers that are not suitable for a raw stream
1331 while (t && (l = *t)) {
1332 if (l->tab && l->tab->Binmode) {
1333 /* Has a handler - normal case */
1334 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1336 /* Layer still there - move down a layer */
1345 /* No handler - pop it */
1346 PerlIO_pop(aTHX_ t);
1349 if (PerlIOValid(f)) {
1350 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1351 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1359 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1360 PerlIO_list_t *layers, IV n, IV max)
1364 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1366 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1377 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1381 save_scalar(PL_errgv);
1383 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1384 code = PerlIO_parse_layers(aTHX_ layers, names);
1386 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1388 PerlIO_list_free(aTHX_ layers);
1395 /*--------------------------------------------------------------------------------------*/
1397 * Given the abstraction above the public API functions
1401 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1403 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1404 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1405 PerlIOBase(f)->tab->name : "(Null)",
1406 iotype, mode, (names) ? names : "(Null)");
1409 /* Do not flush etc. if (e.g.) switching encodings.
1410 if a pushed layer knows it needs to flush lower layers
1411 (for example :unix which is never going to call them)
1412 it can do the flush when it is pushed.
1414 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1417 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1418 #ifdef PERLIO_USING_CRLF
1419 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1420 O_BINARY so we can look for it in mode.
1422 if (!(mode & O_BINARY)) {
1424 /* FIXME?: Looking down the layer stack seems wrong,
1425 but is a way of reaching past (say) an encoding layer
1426 to flip CRLF-ness of the layer(s) below
1429 /* Perhaps we should turn on bottom-most aware layer
1430 e.g. Ilya's idea that UNIX TTY could serve
1432 if (PerlIOBase(f)->tab &&
1433 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1435 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1436 /* Not in text mode - flush any pending stuff and flip it */
1438 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1440 /* Only need to turn it on in one layer so we are done */
1445 /* Not finding a CRLF aware layer presumably means we are binary
1446 which is not what was requested - so we failed
1447 We _could_ push :crlf layer but so could caller
1452 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1453 So code that used to be here is now in PerlIORaw_pushed().
1455 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1460 PerlIO__close(pTHX_ PerlIO *f)
1462 if (PerlIOValid(f)) {
1463 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1464 if (tab && tab->Close)
1465 return (*tab->Close)(aTHX_ f);
1467 return PerlIOBase_close(aTHX_ f);
1470 SETERRNO(EBADF, SS_IVCHAN);
1476 Perl_PerlIO_close(pTHX_ PerlIO *f)
1478 const int code = PerlIO__close(aTHX_ f);
1479 while (PerlIOValid(f)) {
1480 PerlIO_pop(aTHX_ f);
1481 if (PerlIO_lockcnt(f))
1482 /* we're in use; the 'pop' deferred freeing the structure */
1489 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1492 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1496 static PerlIO_funcs *
1497 PerlIO_layer_from_ref(pTHX_ SV *sv)
1501 * For any scalar type load the handler which is bundled with perl
1503 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1504 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1505 /* This isn't supposed to happen, since PerlIO::scalar is core,
1506 * but could happen anyway in smaller installs or with PAR */
1508 /* diag_listed_as: Unknown PerlIO layer "%s" */
1509 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1514 * For other types allow if layer is known but don't try and load it
1516 switch (SvTYPE(sv)) {
1518 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1520 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1522 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1524 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1531 PerlIO_resolve_layers(pTHX_ const char *layers,
1532 const char *mode, int narg, SV **args)
1535 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1538 PerlIO_stdstreams(aTHX);
1540 SV * const arg = *args;
1542 * If it is a reference but not an object see if we have a handler
1545 if (SvROK(arg) && !sv_isobject(arg)) {
1546 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1548 def = PerlIO_list_alloc(aTHX);
1549 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1553 * Don't fail if handler cannot be found :via(...) etc. may do
1554 * something sensible else we will just stringfy and open
1559 if (!layers || !*layers)
1560 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1561 if (layers && *layers) {
1564 av = PerlIO_clone_list(aTHX_ def, NULL);
1569 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1573 PerlIO_list_free(aTHX_ av);
1585 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1586 int imode, int perm, PerlIO *f, int narg, SV **args)
1589 if (!f && narg == 1 && *args == &PL_sv_undef) {
1590 if ((f = PerlIO_tmpfile())) {
1591 if (!layers || !*layers)
1592 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1593 if (layers && *layers)
1594 PerlIO_apply_layers(aTHX_ f, mode, layers);
1598 PerlIO_list_t *layera;
1600 PerlIO_funcs *tab = NULL;
1601 if (PerlIOValid(f)) {
1603 * This is "reopen" - it is not tested as perl does not use it
1607 layera = PerlIO_list_alloc(aTHX);
1610 if (l->tab && l->tab->Getarg)
1611 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1612 PerlIO_list_push(aTHX_ layera, l->tab,
1613 (arg) ? arg : &PL_sv_undef);
1615 l = *PerlIONext(&l);
1619 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1625 * Start at "top" of layer stack
1627 n = layera->cur - 1;
1629 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1638 * Found that layer 'n' can do opens - call it
1640 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1641 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1643 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1644 tab->name, layers ? layers : "(Null)", mode, fd,
1645 imode, perm, (void*)f, narg, (void*)args);
1647 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1650 SETERRNO(EINVAL, LIB_INVARG);
1654 if (n + 1 < layera->cur) {
1656 * More layers above the one that we used to open -
1659 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1660 /* If pushing layers fails close the file */
1667 PerlIO_list_free(aTHX_ layera);
1674 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1676 PERL_ARGS_ASSERT_PERLIO_READ;
1678 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1682 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1684 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1686 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1690 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1692 PERL_ARGS_ASSERT_PERLIO_WRITE;
1694 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1698 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1700 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1704 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1706 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1710 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1715 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1717 if (tab && tab->Flush)
1718 return (*tab->Flush) (aTHX_ f);
1720 return 0; /* If no Flush defined, silently succeed. */
1723 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1724 SETERRNO(EBADF, SS_IVCHAN);
1730 * Is it good API design to do flush-all on NULL, a potentially
1731 * erroneous input? Maybe some magical value (PerlIO*
1732 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1733 * things on fflush(NULL), but should we be bound by their design
1736 PerlIOl **table = &PL_perlio;
1739 while ((ff = *table)) {
1741 table = (PerlIOl **) (ff++);
1742 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1743 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1753 PerlIOBase_flush_linebuf(pTHX)
1756 PerlIOl **table = &PL_perlio;
1758 while ((f = *table)) {
1760 table = (PerlIOl **) (f++);
1761 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1763 && (PerlIOBase(&(f->next))->
1764 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1765 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1766 PerlIO_flush(&(f->next));
1773 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1775 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1779 PerlIO_isutf8(PerlIO *f)
1782 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1784 SETERRNO(EBADF, SS_IVCHAN);
1790 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1792 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1796 Perl_PerlIO_error(pTHX_ PerlIO *f)
1798 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1802 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1804 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1808 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1810 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1814 PerlIO_has_base(PerlIO *f)
1816 if (PerlIOValid(f)) {
1817 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1820 return (tab->Get_base != NULL);
1827 PerlIO_fast_gets(PerlIO *f)
1829 if (PerlIOValid(f)) {
1830 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1831 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1834 return (tab->Set_ptrcnt != NULL);
1842 PerlIO_has_cntptr(PerlIO *f)
1844 if (PerlIOValid(f)) {
1845 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1848 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1855 PerlIO_canset_cnt(PerlIO *f)
1857 if (PerlIOValid(f)) {
1858 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1861 return (tab->Set_ptrcnt != NULL);
1868 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1870 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1874 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1876 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1880 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1882 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1886 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1888 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1892 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1894 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1898 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1900 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1904 /*--------------------------------------------------------------------------------------*/
1906 * utf8 and raw dummy layers
1910 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1912 PERL_UNUSED_CONTEXT;
1913 PERL_UNUSED_ARG(mode);
1914 PERL_UNUSED_ARG(arg);
1915 if (PerlIOValid(f)) {
1916 if (tab && tab->kind & PERLIO_K_UTF8)
1917 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1919 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1925 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1926 sizeof(PerlIO_funcs),
1929 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1949 NULL, /* get_base */
1950 NULL, /* get_bufsiz */
1953 NULL, /* set_ptrcnt */
1956 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1957 sizeof(PerlIO_funcs),
1960 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1980 NULL, /* get_base */
1981 NULL, /* get_bufsiz */
1984 NULL, /* set_ptrcnt */
1987 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1988 sizeof(PerlIO_funcs),
2011 NULL, /* get_base */
2012 NULL, /* get_bufsiz */
2015 NULL, /* set_ptrcnt */
2017 /*--------------------------------------------------------------------------------------*/
2018 /*--------------------------------------------------------------------------------------*/
2020 * "Methods" of the "base class"
2024 PerlIOBase_fileno(pTHX_ PerlIO *f)
2026 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2030 PerlIO_modestr(PerlIO * f, char *buf)
2033 if (PerlIOValid(f)) {
2034 const IV flags = PerlIOBase(f)->flags;
2035 if (flags & PERLIO_F_APPEND) {
2037 if (flags & PERLIO_F_CANREAD) {
2041 else if (flags & PERLIO_F_CANREAD) {
2043 if (flags & PERLIO_F_CANWRITE)
2046 else if (flags & PERLIO_F_CANWRITE) {
2048 if (flags & PERLIO_F_CANREAD) {
2052 #ifdef PERLIO_USING_CRLF
2053 if (!(flags & PERLIO_F_CRLF))
2063 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2065 PerlIOl * const l = PerlIOBase(f);
2066 PERL_UNUSED_CONTEXT;
2067 PERL_UNUSED_ARG(arg);
2069 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2070 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2071 if (tab && tab->Set_ptrcnt != NULL)
2072 l->flags |= PERLIO_F_FASTGETS;
2074 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2078 l->flags |= PERLIO_F_CANREAD;
2081 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2084 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2087 SETERRNO(EINVAL, LIB_INVARG);
2093 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2096 l->flags &= ~PERLIO_F_CRLF;
2099 l->flags |= PERLIO_F_CRLF;
2102 SETERRNO(EINVAL, LIB_INVARG);
2109 l->flags |= l->next->flags &
2110 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2115 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2116 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2117 l->flags, PerlIO_modestr(f, temp));
2123 PerlIOBase_popped(pTHX_ PerlIO *f)
2125 PERL_UNUSED_CONTEXT;
2131 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2134 * Save the position as current head considers it
2136 const Off_t old = PerlIO_tell(f);
2137 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2138 PerlIOSelf(f, PerlIOBuf)->posn = old;
2139 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2143 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2145 STDCHAR *buf = (STDCHAR *) vbuf;
2147 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2148 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2149 SETERRNO(EBADF, SS_IVCHAN);
2155 SSize_t avail = PerlIO_get_cnt(f);
2158 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2160 STDCHAR *ptr = PerlIO_get_ptr(f);
2161 Copy(ptr, buf, take, STDCHAR);
2162 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2165 if (avail == 0) /* set_ptrcnt could have reset avail */
2168 if (count > 0 && avail <= 0) {
2169 if (PerlIO_fill(f) != 0)
2174 return (buf - (STDCHAR *) vbuf);
2180 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2182 PERL_UNUSED_CONTEXT;
2188 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2190 PERL_UNUSED_CONTEXT;
2196 PerlIOBase_close(pTHX_ PerlIO *f)
2199 if (PerlIOValid(f)) {
2200 PerlIO *n = PerlIONext(f);
2201 code = PerlIO_flush(f);
2202 PerlIOBase(f)->flags &=
2203 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2204 while (PerlIOValid(n)) {
2205 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2206 if (tab && tab->Close) {
2207 if ((*tab->Close)(aTHX_ n) != 0)
2212 PerlIOBase(n)->flags &=
2213 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2219 SETERRNO(EBADF, SS_IVCHAN);
2225 PerlIOBase_eof(pTHX_ PerlIO *f)
2227 PERL_UNUSED_CONTEXT;
2228 if (PerlIOValid(f)) {
2229 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2235 PerlIOBase_error(pTHX_ PerlIO *f)
2237 PERL_UNUSED_CONTEXT;
2238 if (PerlIOValid(f)) {
2239 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2245 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2247 if (PerlIOValid(f)) {
2248 PerlIO * const n = PerlIONext(f);
2249 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2256 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2258 PERL_UNUSED_CONTEXT;
2259 if (PerlIOValid(f)) {
2260 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2265 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2271 arg = sv_dup(arg, param);
2272 SvREFCNT_inc_simple_void_NN(arg);
2276 return newSVsv(arg);
2279 PERL_UNUSED_ARG(param);
2280 return newSVsv(arg);
2285 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2287 PerlIO * const nexto = PerlIONext(o);
2288 if (PerlIOValid(nexto)) {
2289 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2290 if (tab && tab->Dup)
2291 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2293 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2296 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2299 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2300 self ? self->name : "(Null)",
2301 (void*)f, (void*)o, (void*)param);
2302 if (self && self->Getarg)
2303 arg = (*self->Getarg)(aTHX_ o, param, flags);
2304 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2305 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2306 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2312 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2314 /* Must be called with PL_perlio_mutex locked. */
2316 S_more_refcounted_fds(pTHX_ const int new_fd) {
2318 const int old_max = PL_perlio_fd_refcnt_size;
2319 const int new_max = 16 + (new_fd & ~15);
2322 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2323 old_max, new_fd, new_max);
2325 if (new_fd < old_max) {
2329 assert (new_max > new_fd);
2331 /* Use plain realloc() since we need this memory to be really
2332 * global and visible to all the interpreters and/or threads. */
2333 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2337 MUTEX_UNLOCK(&PL_perlio_mutex);
2342 PL_perlio_fd_refcnt_size = new_max;
2343 PL_perlio_fd_refcnt = new_array;
2345 PerlIO_debug("Zeroing %p, %d\n",
2346 (void*)(new_array + old_max),
2349 Zero(new_array + old_max, new_max - old_max, int);
2356 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2357 PERL_UNUSED_CONTEXT;
2361 PerlIOUnix_refcnt_inc(int fd)
2368 MUTEX_LOCK(&PL_perlio_mutex);
2370 if (fd >= PL_perlio_fd_refcnt_size)
2371 S_more_refcounted_fds(aTHX_ fd);
2373 PL_perlio_fd_refcnt[fd]++;
2374 if (PL_perlio_fd_refcnt[fd] <= 0) {
2375 /* diag_listed_as: refcnt_inc: fd %d%s */
2376 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2377 fd, PL_perlio_fd_refcnt[fd]);
2379 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2380 fd, PL_perlio_fd_refcnt[fd]);
2383 MUTEX_UNLOCK(&PL_perlio_mutex);
2386 /* diag_listed_as: refcnt_inc: fd %d%s */
2387 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2392 PerlIOUnix_refcnt_dec(int fd)
2398 MUTEX_LOCK(&PL_perlio_mutex);
2400 if (fd >= PL_perlio_fd_refcnt_size) {
2401 /* diag_listed_as: refcnt_dec: fd %d%s */
2402 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2403 fd, PL_perlio_fd_refcnt_size);
2405 if (PL_perlio_fd_refcnt[fd] <= 0) {
2406 /* diag_listed_as: refcnt_dec: fd %d%s */
2407 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2408 fd, PL_perlio_fd_refcnt[fd]);
2410 cnt = --PL_perlio_fd_refcnt[fd];
2411 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2413 MUTEX_UNLOCK(&PL_perlio_mutex);
2416 /* diag_listed_as: refcnt_dec: fd %d%s */
2417 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2423 PerlIOUnix_refcnt(int fd)
2430 MUTEX_LOCK(&PL_perlio_mutex);
2432 if (fd >= PL_perlio_fd_refcnt_size) {
2433 /* diag_listed_as: refcnt: fd %d%s */
2434 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2435 fd, PL_perlio_fd_refcnt_size);
2437 if (PL_perlio_fd_refcnt[fd] <= 0) {
2438 /* diag_listed_as: refcnt: fd %d%s */
2439 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2440 fd, PL_perlio_fd_refcnt[fd]);
2442 cnt = PL_perlio_fd_refcnt[fd];
2444 MUTEX_UNLOCK(&PL_perlio_mutex);
2447 /* diag_listed_as: refcnt: fd %d%s */
2448 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2454 PerlIO_cleanup(pTHX)
2459 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2461 PerlIO_debug("Cleanup layers\n");
2464 /* Raise STDIN..STDERR refcount so we don't close them */
2465 for (i=0; i < 3; i++)
2466 PerlIOUnix_refcnt_inc(i);
2467 PerlIO_cleantable(aTHX_ &PL_perlio);
2468 /* Restore STDIN..STDERR refcount */
2469 for (i=0; i < 3; i++)
2470 PerlIOUnix_refcnt_dec(i);
2472 if (PL_known_layers) {
2473 PerlIO_list_free(aTHX_ PL_known_layers);
2474 PL_known_layers = NULL;
2476 if (PL_def_layerlist) {
2477 PerlIO_list_free(aTHX_ PL_def_layerlist);
2478 PL_def_layerlist = NULL;
2482 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2486 /* XXX we can't rely on an interpreter being present at this late stage,
2487 XXX so we can't use a function like PerlLIO_write that relies on one
2488 being present (at least in win32) :-(.
2493 /* By now all filehandles should have been closed, so any
2494 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2496 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2497 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2498 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2500 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2501 if (PL_perlio_fd_refcnt[i]) {
2503 my_snprintf(buf, sizeof(buf),
2504 "PerlIO_teardown: fd %d refcnt=%d\n",
2505 i, PL_perlio_fd_refcnt[i]);
2506 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2512 /* Not bothering with PL_perlio_mutex since by now
2513 * all the interpreters are gone. */
2514 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2515 && PL_perlio_fd_refcnt) {
2516 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2517 PL_perlio_fd_refcnt = NULL;
2518 PL_perlio_fd_refcnt_size = 0;
2522 /*--------------------------------------------------------------------------------------*/
2524 * Bottom-most level for UNIX-like case
2528 struct _PerlIO base; /* The generic part */
2529 int fd; /* UNIX like file descriptor */
2530 int oflags; /* open/fcntl flags */
2534 S_lockcnt_dec(pTHX_ const void* f)
2536 PerlIO_lockcnt((PerlIO*)f)--;
2540 /* call the signal handler, and if that handler happens to clear
2541 * this handle, free what we can and return true */
2544 S_perlio_async_run(pTHX_ PerlIO* f) {
2546 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2547 PerlIO_lockcnt(f)++;
2549 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2553 /* we've just run some perl-level code that could have done
2554 * anything, including closing the file or clearing this layer.
2555 * If so, free any lower layers that have already been
2556 * cleared, then return an error. */
2557 while (PerlIOValid(f) &&
2558 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2560 const PerlIOl *l = *f;
2569 PerlIOUnix_oflags(const char *mode)
2572 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2577 if (*++mode == '+') {
2584 oflags = O_CREAT | O_TRUNC;
2585 if (*++mode == '+') {
2594 oflags = O_CREAT | O_APPEND;
2595 if (*++mode == '+') {
2608 else if (*mode == 't') {
2610 oflags &= ~O_BINARY;
2614 * Always open in binary mode
2617 if (*mode || oflags == -1) {
2618 SETERRNO(EINVAL, LIB_INVARG);
2625 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2627 PERL_UNUSED_CONTEXT;
2628 return PerlIOSelf(f, PerlIOUnix)->fd;
2632 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2634 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2637 if (PerlLIO_fstat(fd, &st) == 0) {
2638 if (!S_ISREG(st.st_mode)) {
2639 PerlIO_debug("%d is not regular file\n",fd);
2640 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2643 PerlIO_debug("%d _is_ a regular file\n",fd);
2649 PerlIOUnix_refcnt_inc(fd);
2650 PERL_UNUSED_CONTEXT;
2654 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2656 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2657 if (*PerlIONext(f)) {
2658 /* We never call down so do any pending stuff now */
2659 PerlIO_flush(PerlIONext(f));
2661 * XXX could (or should) we retrieve the oflags from the open file
2662 * handle rather than believing the "mode" we are passed in? XXX
2663 * Should the value on NULL mode be 0 or -1?
2665 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2666 mode ? PerlIOUnix_oflags(mode) : -1);
2668 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2674 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2676 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2678 PERL_UNUSED_CONTEXT;
2679 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2681 SETERRNO(ESPIPE, LIB_INVARG);
2683 SETERRNO(EINVAL, LIB_INVARG);
2687 new_loc = PerlLIO_lseek(fd, offset, whence);
2688 if (new_loc == (Off_t) - 1)
2690 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2695 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2696 IV n, const char *mode, int fd, int imode,
2697 int perm, PerlIO *f, int narg, SV **args)
2699 if (PerlIOValid(f)) {
2700 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2701 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2704 if (*mode == IoTYPE_NUMERIC)
2707 imode = PerlIOUnix_oflags(mode);
2709 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2715 const char *path = SvPV_nolen_const(*args);
2716 fd = PerlLIO_open3(path, imode, perm);
2720 if (*mode == IoTYPE_IMPLICIT)
2723 f = PerlIO_allocate(aTHX);
2725 if (!PerlIOValid(f)) {
2726 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2730 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2731 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2732 if (*mode == IoTYPE_APPEND)
2733 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2740 * FIXME: pop layers ???
2748 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2750 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2752 if (flags & PERLIO_DUP_FD) {
2753 fd = PerlLIO_dup(fd);
2756 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2758 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2759 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2768 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2772 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2774 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2775 #ifdef PERLIO_STD_SPECIAL
2777 return PERLIO_STD_IN(fd, vbuf, count);
2779 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2780 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2784 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2785 if (len >= 0 || errno != EINTR) {
2787 if (errno != EAGAIN) {
2788 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2791 else if (len == 0 && count != 0) {
2792 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2798 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2805 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2809 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2811 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2812 #ifdef PERLIO_STD_SPECIAL
2813 if (fd == 1 || fd == 2)
2814 return PERLIO_STD_OUT(fd, vbuf, count);
2817 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2818 if (len >= 0 || errno != EINTR) {
2820 if (errno != EAGAIN) {
2821 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2827 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2834 PerlIOUnix_tell(pTHX_ PerlIO *f)
2836 PERL_UNUSED_CONTEXT;
2838 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2843 PerlIOUnix_close(pTHX_ PerlIO *f)
2846 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2848 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2849 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2850 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2855 SETERRNO(EBADF,SS_IVCHAN);
2858 while (PerlLIO_close(fd) != 0) {
2859 if (errno != EINTR) {
2864 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2868 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2873 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2874 sizeof(PerlIO_funcs),
2881 PerlIOBase_binmode, /* binmode */
2891 PerlIOBase_noop_ok, /* flush */
2892 PerlIOBase_noop_fail, /* fill */
2895 PerlIOBase_clearerr,
2896 PerlIOBase_setlinebuf,
2897 NULL, /* get_base */
2898 NULL, /* get_bufsiz */
2901 NULL, /* set_ptrcnt */
2904 /*--------------------------------------------------------------------------------------*/
2909 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2910 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2911 broken by the last second glibc 2.3 fix
2913 #define STDIO_BUFFER_WRITABLE
2918 struct _PerlIO base;
2919 FILE *stdio; /* The stream */
2923 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2925 PERL_UNUSED_CONTEXT;
2927 if (PerlIOValid(f)) {
2928 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2930 return PerlSIO_fileno(s);
2937 PerlIOStdio_mode(const char *mode, char *tmode)
2939 char * const ret = tmode;
2945 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2953 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2956 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2957 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2958 if (toptab == tab) {
2959 /* Top is already stdio - pop self (duplicate) and use original */
2960 PerlIO_pop(aTHX_ f);
2963 const int fd = PerlIO_fileno(n);
2966 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2967 mode = PerlIOStdio_mode(mode, tmode)))) {
2968 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2969 /* We never call down so do any pending stuff now */
2970 PerlIO_flush(PerlIONext(f));
2977 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2982 PerlIO_importFILE(FILE *stdio, const char *mode)
2988 if (!mode || !*mode) {
2989 /* We need to probe to see how we can open the stream
2990 so start with read/write and then try write and read
2991 we dup() so that we can fclose without loosing the fd.
2993 Note that the errno value set by a failing fdopen
2994 varies between stdio implementations.
2996 const int fd = PerlLIO_dup(fileno(stdio));
2997 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2999 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3002 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3005 /* Don't seem to be able to open */
3011 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3012 s = PerlIOSelf(f, PerlIOStdio);
3014 PerlIOUnix_refcnt_inc(fileno(stdio));
3021 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3022 IV n, const char *mode, int fd, int imode,
3023 int perm, PerlIO *f, int narg, SV **args)
3026 if (PerlIOValid(f)) {
3027 const char * const path = SvPV_nolen_const(*args);
3028 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3030 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3031 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3036 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3041 const char * const path = SvPV_nolen_const(*args);
3042 if (*mode == IoTYPE_NUMERIC) {
3044 fd = PerlLIO_open3(path, imode, perm);
3048 bool appended = FALSE;
3050 /* Cygwin wants its 'b' early. */
3052 mode = PerlIOStdio_mode(mode, tmode);
3054 stdio = PerlSIO_fopen(path, mode);
3057 f = PerlIO_allocate(aTHX);
3060 mode = PerlIOStdio_mode(mode, tmode);
3061 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3063 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3064 PerlIOUnix_refcnt_inc(fileno(stdio));
3066 PerlSIO_fclose(stdio);
3078 if (*mode == IoTYPE_IMPLICIT) {
3085 stdio = PerlSIO_stdin;
3088 stdio = PerlSIO_stdout;
3091 stdio = PerlSIO_stderr;
3096 stdio = PerlSIO_fdopen(fd, mode =
3097 PerlIOStdio_mode(mode, tmode));
3101 f = PerlIO_allocate(aTHX);
3103 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3104 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3105 PerlIOUnix_refcnt_inc(fileno(stdio));
3115 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3117 /* This assumes no layers underneath - which is what
3118 happens, but is not how I remember it. NI-S 2001/10/16
3120 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3121 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3122 const int fd = fileno(stdio);
3124 if (flags & PERLIO_DUP_FD) {
3125 const int dfd = PerlLIO_dup(fileno(stdio));
3127 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3132 /* FIXME: To avoid messy error recovery if dup fails
3133 re-use the existing stdio as though flag was not set
3137 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3139 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3141 PerlIOUnix_refcnt_inc(fileno(stdio));
3148 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3150 PERL_UNUSED_CONTEXT;
3152 /* XXX this could use PerlIO_canset_fileno() and
3153 * PerlIO_set_fileno() support from Configure
3155 # if defined(__UCLIBC__)
3156 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3159 # elif defined(__GLIBC__)
3160 /* There may be a better way for GLIBC:
3161 - libio.h defines a flag to not close() on cleanup
3165 # elif defined(__sun__)
3168 # elif defined(__hpux)
3172 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3173 your platform does not have special entry try this one.
3174 [For OSF only have confirmation for Tru64 (alpha)
3175 but assume other OSFs will be similar.]
3177 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3180 # elif defined(__FreeBSD__)
3181 /* There may be a better way on FreeBSD:
3182 - we could insert a dummy func in the _close function entry
3183 f->_close = (int (*)(void *)) dummy_close;
3187 # elif defined(__OpenBSD__)
3188 /* There may be a better way on OpenBSD:
3189 - we could insert a dummy func in the _close function entry
3190 f->_close = (int (*)(void *)) dummy_close;
3194 # elif defined(__EMX__)
3195 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3198 # elif defined(__CYGWIN__)
3199 /* There may be a better way on CYGWIN:
3200 - we could insert a dummy func in the _close function entry
3201 f->_close = (int (*)(void *)) dummy_close;
3205 # elif defined(WIN32)
3206 # if defined(UNDER_CE)
3207 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3216 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3217 (which isn't thread safe) instead
3219 # error "Don't know how to set FILE.fileno on your platform"
3227 PerlIOStdio_close(pTHX_ PerlIO *f)
3229 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3235 const int fd = fileno(stdio);
3243 #ifdef SOCKS5_VERSION_NAME
3244 /* Socks lib overrides close() but stdio isn't linked to
3245 that library (though we are) - so we must call close()
3246 on sockets on stdio's behalf.
3249 Sock_size_t optlen = sizeof(int);
3250 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3253 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3254 that a subsequent fileno() on it returns -1. Don't want to croak()
3255 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3256 trying to close an already closed handle which somehow it still has
3257 a reference to. (via.xs, I'm looking at you). */
3258 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3259 /* File descriptor still in use */
3263 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3264 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3266 if (stdio == stdout || stdio == stderr)
3267 return PerlIO_flush(f);
3268 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3269 Use Sarathy's trick from maint-5.6 to invalidate the
3270 fileno slot of the FILE *
3272 result = PerlIO_flush(f);
3274 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3277 MUTEX_LOCK(&PL_perlio_mutex);
3278 /* Right. We need a mutex here because for a brief while we
3279 will have the situation that fd is actually closed. Hence if
3280 a second thread were to get into this block, its dup() would
3281 likely return our fd as its dupfd. (after all, it is closed)
3282 Then if we get to the dup2() first, we blat the fd back
3283 (messing up its temporary as a side effect) only for it to
3284 then close its dupfd (== our fd) in its close(dupfd) */
3286 /* There is, of course, a race condition, that any other thread
3287 trying to input/output/whatever on this fd will be stuffed
3288 for the duration of this little manoeuvrer. Perhaps we
3289 should hold an IO mutex for the duration of every IO
3290 operation if we know that invalidate doesn't work on this
3291 platform, but that would suck, and could kill performance.
3293 Except that correctness trumps speed.
3294 Advice from klortho #11912. */
3296 dupfd = PerlLIO_dup(fd);
3299 MUTEX_UNLOCK(&PL_perlio_mutex);
3300 /* Oh cXap. This isn't going to go well. Not sure if we can
3301 recover from here, or if closing this particular FILE *
3302 is a good idea now. */
3307 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3309 result = PerlSIO_fclose(stdio);
3310 /* We treat error from stdio as success if we invalidated
3311 errno may NOT be expected EBADF
3313 if (invalidate && result != 0) {
3317 #ifdef SOCKS5_VERSION_NAME
3318 /* in SOCKS' case, let close() determine return value */
3322 PerlLIO_dup2(dupfd,fd);
3323 PerlLIO_close(dupfd);
3325 MUTEX_UNLOCK(&PL_perlio_mutex);
3333 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3338 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3340 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3343 STDCHAR *buf = (STDCHAR *) vbuf;
3345 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3346 * stdio does not do that for fread()
3348 const int ch = PerlSIO_fgetc(s);
3355 got = PerlSIO_fread(vbuf, 1, count, s);
3356 if (got == 0 && PerlSIO_ferror(s))
3358 if (got >= 0 || errno != EINTR)
3360 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3362 SETERRNO(0,0); /* just in case */
3368 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3371 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3373 #ifdef STDIO_BUFFER_WRITABLE
3374 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3375 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3376 STDCHAR *base = PerlIO_get_base(f);
3377 SSize_t cnt = PerlIO_get_cnt(f);
3378 STDCHAR *ptr = PerlIO_get_ptr(f);
3379 SSize_t avail = ptr - base;
3381 if (avail > count) {
3385 Move(buf-avail,ptr,avail,STDCHAR);
3388 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3389 if (PerlSIO_feof(s) && unread >= 0)
3390 PerlSIO_clearerr(s);
3395 if (PerlIO_has_cntptr(f)) {
3396 /* We can get pointer to buffer but not its base
3397 Do ungetc() but check chars are ending up in the
3400 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3401 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3403 const int ch = *--buf & 0xFF;
3404 if (ungetc(ch,s) != ch) {
3405 /* ungetc did not work */
3408 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3409 /* Did not change pointer as expected */
3410 fgetc(s); /* get char back again */
3420 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3426 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3430 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3433 got = PerlSIO_fwrite(vbuf, 1, count,
3434 PerlIOSelf(f, PerlIOStdio)->stdio);
3435 if (got >= 0 || errno != EINTR)
3437 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3439 SETERRNO(0,0); /* just in case */
3445 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3447 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3448 PERL_UNUSED_CONTEXT;
3450 return PerlSIO_fseek(stdio, offset, whence);
3454 PerlIOStdio_tell(pTHX_ PerlIO *f)
3456 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3457 PERL_UNUSED_CONTEXT;
3459 return PerlSIO_ftell(stdio);
3463 PerlIOStdio_flush(pTHX_ PerlIO *f)
3465 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3466 PERL_UNUSED_CONTEXT;
3468 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3469 return PerlSIO_fflush(stdio);
3475 * FIXME: This discards ungetc() and pre-read stuff which is not
3476 * right if this is just a "sync" from a layer above Suspect right
3477 * design is to do _this_ but not have layer above flush this
3478 * layer read-to-read
3481 * Not writeable - sync by attempting a seek
3484 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3492 PerlIOStdio_eof(pTHX_ PerlIO *f)
3494 PERL_UNUSED_CONTEXT;
3496 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3500 PerlIOStdio_error(pTHX_ PerlIO *f)
3502 PERL_UNUSED_CONTEXT;
3504 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3508 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3510 PERL_UNUSED_CONTEXT;
3512 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3516 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3518 PERL_UNUSED_CONTEXT;
3520 #ifdef HAS_SETLINEBUF
3521 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3523 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3529 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3531 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3532 return (STDCHAR*)PerlSIO_get_base(stdio);
3536 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3538 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3539 return PerlSIO_get_bufsiz(stdio);
3543 #ifdef USE_STDIO_PTR
3545 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3547 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3548 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3552 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3554 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3555 return PerlSIO_get_cnt(stdio);
3559 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3561 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3563 #ifdef STDIO_PTR_LVALUE
3564 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3565 #ifdef STDIO_PTR_LVAL_SETS_CNT
3566 assert(PerlSIO_get_cnt(stdio) == (cnt));
3568 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3570 * Setting ptr _does_ change cnt - we are done
3574 #else /* STDIO_PTR_LVALUE */
3576 #endif /* STDIO_PTR_LVALUE */
3579 * Now (or only) set cnt
3581 #ifdef STDIO_CNT_LVALUE
3582 PerlSIO_set_cnt(stdio, cnt);
3583 #else /* STDIO_CNT_LVALUE */
3584 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3585 PerlSIO_set_ptr(stdio,
3586 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3588 #else /* STDIO_PTR_LVAL_SETS_CNT */
3590 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3591 #endif /* STDIO_CNT_LVALUE */
3598 PerlIOStdio_fill(pTHX_ PerlIO *f)
3602 PERL_UNUSED_CONTEXT;
3603 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3605 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3608 * fflush()ing read-only streams can cause trouble on some stdio-s
3610 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3611 if (PerlSIO_fflush(stdio) != 0)
3615 c = PerlSIO_fgetc(stdio);
3618 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3620 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3625 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3627 #ifdef STDIO_BUFFER_WRITABLE
3628 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3629 /* Fake ungetc() to the real buffer in case system's ungetc
3632 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3633 SSize_t cnt = PerlSIO_get_cnt(stdio);
3634 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3635 if (ptr == base+1) {
3636 *--ptr = (STDCHAR) c;
3637 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3638 if (PerlSIO_feof(stdio))
3639 PerlSIO_clearerr(stdio);
3645 if (PerlIO_has_cntptr(f)) {
3647 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3654 /* An ungetc()d char is handled separately from the regular
3655 * buffer, so we stuff it in the buffer ourselves.
3656 * Should never get called as should hit code above
3658 *(--((*stdio)->_ptr)) = (unsigned char) c;
3661 /* If buffer snoop scheme above fails fall back to
3664 if (PerlSIO_ungetc(c, stdio) != c)
3672 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3673 sizeof(PerlIO_funcs),
3675 sizeof(PerlIOStdio),
3676 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3680 PerlIOBase_binmode, /* binmode */
3694 PerlIOStdio_clearerr,
3695 PerlIOStdio_setlinebuf,
3697 PerlIOStdio_get_base,
3698 PerlIOStdio_get_bufsiz,
3703 #ifdef USE_STDIO_PTR
3704 PerlIOStdio_get_ptr,
3705 PerlIOStdio_get_cnt,
3706 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3707 PerlIOStdio_set_ptrcnt,
3710 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3715 #endif /* USE_STDIO_PTR */
3718 /* Note that calls to PerlIO_exportFILE() are reversed using
3719 * PerlIO_releaseFILE(), not importFILE. */
3721 PerlIO_exportFILE(PerlIO * f, const char *mode)
3725 if (PerlIOValid(f)) {
3728 if (!mode || !*mode) {
3729 mode = PerlIO_modestr(f, buf);
3731 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3735 /* De-link any lower layers so new :stdio sticks */
3737 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3738 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3740 PerlIOUnix_refcnt_inc(fileno(stdio));
3741 /* Link previous lower layers under new one */
3745 /* restore layers list */
3755 PerlIO_findFILE(PerlIO *f)
3760 if (l->tab == &PerlIO_stdio) {
3761 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3764 l = *PerlIONext(&l);
3766 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3767 /* However, we're not really exporting a FILE * to someone else (who
3768 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3769 So we need to undo its reference count increase on the underlying file
3770 descriptor. We have to do this, because if the loop above returns you
3771 the FILE *, then *it* didn't increase any reference count. So there's
3772 only one way to be consistent. */
3773 stdio = PerlIO_exportFILE(f, NULL);
3775 const int fd = fileno(stdio);
3777 PerlIOUnix_refcnt_dec(fd);
3782 /* Use this to reverse PerlIO_exportFILE calls. */
3784 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3789 if (l->tab == &PerlIO_stdio) {
3790 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3791 if (s->stdio == f) { /* not in a loop */
3792 const int fd = fileno(f);
3794 PerlIOUnix_refcnt_dec(fd);
3797 PerlIO_pop(aTHX_ p);
3807 /*--------------------------------------------------------------------------------------*/
3809 * perlio buffer layer
3813 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3815 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3816 const int fd = PerlIO_fileno(f);
3817 if (fd >= 0 && PerlLIO_isatty(fd)) {
3818 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3820 if (*PerlIONext(f)) {
3821 const Off_t posn = PerlIO_tell(PerlIONext(f));
3822 if (posn != (Off_t) - 1) {
3826 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3830 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3831 IV n, const char *mode, int fd, int imode, int perm,
3832 PerlIO *f, int narg, SV **args)
3834 if (PerlIOValid(f)) {
3835 PerlIO *next = PerlIONext(f);
3837 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3838 if (tab && tab->Open)
3840 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3842 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3847 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3849 if (*mode == IoTYPE_IMPLICIT) {
3855 if (tab && tab->Open)
3856 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3859 SETERRNO(EINVAL, LIB_INVARG);
3861 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3863 * if push fails during open, open fails. close will pop us.
3868 fd = PerlIO_fileno(f);
3869 if (init && fd == 2) {
3871 * Initial stderr is unbuffered
3873 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3875 #ifdef PERLIO_USING_CRLF
3876 # ifdef PERLIO_IS_BINMODE_FD
3877 if (PERLIO_IS_BINMODE_FD(fd))
3878 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3882 * do something about failing setmode()? --jhi
3884 PerlLIO_setmode(fd, O_BINARY);
3887 /* Enable line buffering with record-oriented regular files
3888 * so we don't introduce an extraneous record boundary when
3889 * the buffer fills up.
3891 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3893 if (PerlLIO_fstat(fd, &st) == 0
3894 && S_ISREG(st.st_mode)
3895 && (st.st_fab_rfm == FAB$C_VAR
3896 || st.st_fab_rfm == FAB$C_VFC)) {
3897 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3908 * This "flush" is akin to sfio's sync in that it handles files in either
3909 * read or write state. For write state, we put the postponed data through
3910 * the next layers. For read state, we seek() the next layers to the
3911 * offset given by current position in the buffer, and discard the buffer
3912 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3913 * in any case?). Then the pass the stick further in chain.
3916 PerlIOBuf_flush(pTHX_ PerlIO *f)
3918 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3920 PerlIO *n = PerlIONext(f);
3921 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3923 * write() the buffer
3925 const STDCHAR *buf = b->buf;
3926 const STDCHAR *p = buf;
3927 while (p < b->ptr) {
3928 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3932 else if (count < 0 || PerlIO_error(n)) {
3933 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3938 b->posn += (p - buf);
3940 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3941 STDCHAR *buf = PerlIO_get_base(f);
3943 * Note position change
3945 b->posn += (b->ptr - buf);
3946 if (b->ptr < b->end) {
3947 /* We did not consume all of it - try and seek downstream to
3948 our logical position
3950 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3951 /* Reload n as some layers may pop themselves on seek */
3952 b->posn = PerlIO_tell(n = PerlIONext(f));
3955 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3956 data is lost for good - so return saying "ok" having undone
3959 b->posn -= (b->ptr - buf);
3964 b->ptr = b->end = b->buf;
3965 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3966 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3967 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3972 /* This discards the content of the buffer after b->ptr, and rereads
3973 * the buffer from the position off in the layer downstream; here off
3974 * is at offset corresponding to b->ptr - b->buf.
3977 PerlIOBuf_fill(pTHX_ PerlIO *f)
3979 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3980 PerlIO *n = PerlIONext(f);
3983 * Down-stream flush is defined not to loose read data so is harmless.
3984 * we would not normally be fill'ing if there was data left in anycase.
3986 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3988 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3989 PerlIOBase_flush_linebuf(aTHX);
3992 PerlIO_get_base(f); /* allocate via vtable */
3994 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3996 b->ptr = b->end = b->buf;
3998 if (!PerlIOValid(n)) {
3999 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4003 if (PerlIO_fast_gets(n)) {
4005 * Layer below is also buffered. We do _NOT_ want to call its
4006 * ->Read() because that will loop till it gets what we asked for
4007 * which may hang on a pipe etc. Instead take anything it has to
4008 * hand, or ask it to fill _once_.
4010 avail = PerlIO_get_cnt(n);
4012 avail = PerlIO_fill(n);
4014 avail = PerlIO_get_cnt(n);
4016 if (!PerlIO_error(n) && PerlIO_eof(n))
4021 STDCHAR *ptr = PerlIO_get_ptr(n);
4022 const SSize_t cnt = avail;
4023 if (avail > (SSize_t)b->bufsiz)
4025 Copy(ptr, b->buf, avail, STDCHAR);
4026 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4030 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4034 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4036 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4039 b->end = b->buf + avail;
4040 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4045 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4047 if (PerlIOValid(f)) {
4048 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4051 return PerlIOBase_read(aTHX_ f, vbuf, count);
4057 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4059 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4060 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4063 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4068 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4070 * Buffer is already a read buffer, we can overwrite any chars
4071 * which have been read back to buffer start
4073 avail = (b->ptr - b->buf);
4077 * Buffer is idle, set it up so whole buffer is available for
4081 b->end = b->buf + avail;
4083 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4085 * Buffer extends _back_ from where we are now
4087 b->posn -= b->bufsiz;
4089 if (avail > (SSize_t) count) {
4091 * If we have space for more than count, just move count
4099 * In simple stdio-like ungetc() case chars will be already
4102 if (buf != b->ptr) {
4103 Copy(buf, b->ptr, avail, STDCHAR);
4107 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4111 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4117 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4119 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4120 const STDCHAR *buf = (const STDCHAR *) vbuf;
4121 const STDCHAR *flushptr = buf;
4125 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4127 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4128 if (PerlIO_flush(f) != 0) {
4132 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4133 flushptr = buf + count;
4134 while (flushptr > buf && *(flushptr - 1) != '\n')
4138 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4139 if ((SSize_t) count < avail)
4141 if (flushptr > buf && flushptr <= buf + avail)
4142 avail = flushptr - buf;
4143 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4145 Copy(buf, b->ptr, avail, STDCHAR);
4150 if (buf == flushptr)
4153 if (b->ptr >= (b->buf + b->bufsiz))
4154 if (PerlIO_flush(f) == -1)
4157 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4163 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4166 if ((code = PerlIO_flush(f)) == 0) {
4167 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4168 code = PerlIO_seek(PerlIONext(f), offset, whence);
4170 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4171 b->posn = PerlIO_tell(PerlIONext(f));
4178 PerlIOBuf_tell(pTHX_ PerlIO *f)
4180 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4182 * b->posn is file position where b->buf was read, or will be written
4184 Off_t posn = b->posn;
4185 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4186 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4188 /* As O_APPEND files are normally shared in some sense it is better
4193 /* when file is NOT shared then this is sufficient */
4194 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4196 posn = b->posn = PerlIO_tell(PerlIONext(f));
4200 * If buffer is valid adjust position by amount in buffer
4202 posn += (b->ptr - b->buf);
4208 PerlIOBuf_popped(pTHX_ PerlIO *f)
4210 const IV code = PerlIOBase_popped(aTHX_ f);
4211 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4212 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4215 b->ptr = b->end = b->buf = NULL;
4216 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4221 PerlIOBuf_close(pTHX_ PerlIO *f)
4223 const IV code = PerlIOBase_close(aTHX_ f);
4224 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4225 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4228 b->ptr = b->end = b->buf = NULL;
4229 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4234 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4236 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4243 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4245 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4248 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4249 return (b->end - b->ptr);
4254 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4256 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4257 PERL_UNUSED_CONTEXT;
4261 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4262 Newxz(b->buf,b->bufsiz, STDCHAR);
4264 b->buf = (STDCHAR *) & b->oneword;
4265 b->bufsiz = sizeof(b->oneword);
4267 b->end = b->ptr = b->buf;
4273 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4275 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4278 return (b->end - b->buf);
4282 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4284 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4286 PERL_UNUSED_ARG(cnt);
4291 assert(PerlIO_get_cnt(f) == cnt);
4292 assert(b->ptr >= b->buf);
4293 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4297 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4299 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4304 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4305 sizeof(PerlIO_funcs),
4308 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4312 PerlIOBase_binmode, /* binmode */
4326 PerlIOBase_clearerr,
4327 PerlIOBase_setlinebuf,
4332 PerlIOBuf_set_ptrcnt,
4335 /*--------------------------------------------------------------------------------------*/
4337 * Temp layer to hold unread chars when cannot do it any other way
4341 PerlIOPending_fill(pTHX_ PerlIO *f)
4344 * Should never happen
4351 PerlIOPending_close(pTHX_ PerlIO *f)
4354 * A tad tricky - flush pops us, then we close new top
4357 return PerlIO_close(f);
4361 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4364 * A tad tricky - flush pops us, then we seek new top
4367 return PerlIO_seek(f, offset, whence);
4372 PerlIOPending_flush(pTHX_ PerlIO *f)
4374 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4375 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4379 PerlIO_pop(aTHX_ f);
4384 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4390 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4395 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4397 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4398 PerlIOl * const l = PerlIOBase(f);
4400 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4401 * etc. get muddled when it changes mid-string when we auto-pop.
4403 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4404 (PerlIOBase(PerlIONext(f))->
4405 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4410 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4412 SSize_t avail = PerlIO_get_cnt(f);
4414 if ((SSize_t)count < avail)
4417 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4418 if (got >= 0 && got < (SSize_t)count) {
4419 const SSize_t more =
4420 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4421 if (more >= 0 || got == 0)
4427 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4428 sizeof(PerlIO_funcs),
4431 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4432 PerlIOPending_pushed,
4435 PerlIOBase_binmode, /* binmode */
4444 PerlIOPending_close,
4445 PerlIOPending_flush,
4449 PerlIOBase_clearerr,
4450 PerlIOBase_setlinebuf,
4455 PerlIOPending_set_ptrcnt,
4460 /*--------------------------------------------------------------------------------------*/
4462 * crlf - translation On read translate CR,LF to "\n" we do this by
4463 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4464 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4466 * c->nl points on the first byte of CR LF pair when it is temporarily
4467 * replaced by LF, or to the last CR of the buffer. In the former case
4468 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4469 * that it ends at c->nl; these two cases can be distinguished by
4470 * *c->nl. c->nl is set during _getcnt() call, and unset during
4471 * _unread() and _flush() calls.
4472 * It only matters for read operations.
4476 PerlIOBuf base; /* PerlIOBuf stuff */
4477 STDCHAR *nl; /* Position of crlf we "lied" about in the
4481 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4482 * Otherwise the :crlf layer would always revert back to
4486 S_inherit_utf8_flag(PerlIO *f)
4488 PerlIO *g = PerlIONext(f);
4489 if (PerlIOValid(g)) {
4490 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4491 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4497 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4500 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4501 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4503 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4504 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4505 PerlIOBase(f)->flags);
4508 /* If the old top layer is a CRLF layer, reactivate it (if
4509 * necessary) and remove this new layer from the stack */
4510 PerlIO *g = PerlIONext(f);
4511 if (PerlIOValid(g)) {
4512 PerlIOl *b = PerlIOBase(g);
4513 if (b && b->tab == &PerlIO_crlf) {
4514 if (!(b->flags & PERLIO_F_CRLF))
4515 b->flags |= PERLIO_F_CRLF;
4516 S_inherit_utf8_flag(g);
4517 PerlIO_pop(aTHX_ f);
4522 S_inherit_utf8_flag(f);
4528 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4530 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4531 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4535 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4536 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4538 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4539 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4541 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4546 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4547 b->end = b->ptr = b->buf + b->bufsiz;
4548 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4549 b->posn -= b->bufsiz;
4551 while (count > 0 && b->ptr > b->buf) {
4552 const int ch = *--buf;
4554 if (b->ptr - 2 >= b->buf) {
4561 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4562 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4578 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4580 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4582 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4585 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4586 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4587 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4588 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4590 while (nl < b->end && *nl != 0xd)
4592 if (nl < b->end && *nl == 0xd) {
4594 if (nl + 1 < b->end) {
4601 * Not CR,LF but just CR
4609 * Blast - found CR as last char in buffer
4614 * They may not care, defer work as long as
4618 return (nl - b->ptr);
4622 b->ptr++; /* say we have read it as far as
4623 * flush() is concerned */
4624 b->buf++; /* Leave space in front of buffer */
4625 /* Note as we have moved buf up flush's
4627 will naturally make posn point at CR
4629 b->bufsiz--; /* Buffer is thus smaller */
4630 code = PerlIO_fill(f); /* Fetch some more */
4631 b->bufsiz++; /* Restore size for next time */
4632 b->buf--; /* Point at space */
4633 b->ptr = nl = b->buf; /* Which is what we hand
4635 *nl = 0xd; /* Fill in the CR */
4637 goto test; /* fill() call worked */
4639 * CR at EOF - just fall through
4641 /* Should we clear EOF though ??? */
4646 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4652 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4654 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4655 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4661 if (ptr == b->end && *c->nl == 0xd) {
4662 /* Deferred CR at end of buffer case - we lied about count */
4675 * Test code - delete when it works ...
4677 IV flags = PerlIOBase(f)->flags;
4678 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4679 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4680 /* Deferred CR at end of buffer case - we lied about count */
4686 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4687 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4688 flags, c->nl, b->end, cnt);
4695 * They have taken what we lied about
4703 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4707 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4709 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4710 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4712 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4713 const STDCHAR *buf = (const STDCHAR *) vbuf;
4714 const STDCHAR * const ebuf = buf + count;
4717 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4719 while (buf < ebuf) {
4720 const STDCHAR * const eptr = b->buf + b->bufsiz;
4721 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4722 while (buf < ebuf && b->ptr < eptr) {
4724 if ((b->ptr + 2) > eptr) {
4732 *(b->ptr)++ = 0xd; /* CR */
4733 *(b->ptr)++ = 0xa; /* LF */
4735 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4742 *(b->ptr)++ = *buf++;
4744 if (b->ptr >= eptr) {
4750 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4752 return (buf - (STDCHAR *) vbuf);
4757 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4759 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4764 return PerlIOBuf_flush(aTHX_ f);
4768 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4770 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4771 /* In text mode - flush any pending stuff and flip it */
4772 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4773 #ifndef PERLIO_USING_CRLF
4774 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4775 PerlIO_pop(aTHX_ f);
4781 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4782 sizeof(PerlIO_funcs),
4785 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4787 PerlIOBuf_popped, /* popped */
4789 PerlIOCrlf_binmode, /* binmode */
4793 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4794 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4795 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4803 PerlIOBase_clearerr,
4804 PerlIOBase_setlinebuf,
4809 PerlIOCrlf_set_ptrcnt,
4813 Perl_PerlIO_stdin(pTHX)
4817 PerlIO_stdstreams(aTHX);
4819 return (PerlIO*)&PL_perlio[1];
4823 Perl_PerlIO_stdout(pTHX)
4827 PerlIO_stdstreams(aTHX);
4829 return (PerlIO*)&PL_perlio[2];
4833 Perl_PerlIO_stderr(pTHX)
4837 PerlIO_stdstreams(aTHX);
4839 return (PerlIO*)&PL_perlio[3];
4842 /*--------------------------------------------------------------------------------------*/
4845 PerlIO_getname(PerlIO *f, char *buf)
4850 bool exported = FALSE;
4851 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4853 stdio = PerlIO_exportFILE(f,0);
4857 name = fgetname(stdio, buf);
4858 if (exported) PerlIO_releaseFILE(f,stdio);
4863 PERL_UNUSED_ARG(buf);
4864 Perl_croak_nocontext("Don't know how to get file name");
4870 /*--------------------------------------------------------------------------------------*/
4872 * Functions which can be called on any kind of PerlIO implemented in
4876 #undef PerlIO_fdopen
4878 PerlIO_fdopen(int fd, const char *mode)
4881 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4886 PerlIO_open(const char *path, const char *mode)
4889 SV *name = sv_2mortal(newSVpv(path, 0));
4890 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4893 #undef Perlio_reopen
4895 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4898 SV *name = sv_2mortal(newSVpv(path,0));
4899 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4904 PerlIO_getc(PerlIO *f)
4908 if ( 1 == PerlIO_read(f, buf, 1) ) {
4909 return (unsigned char) buf[0];
4914 #undef PerlIO_ungetc
4916 PerlIO_ungetc(PerlIO *f, int ch)
4921 if (PerlIO_unread(f, &buf, 1) == 1)
4929 PerlIO_putc(PerlIO *f, int ch)
4933 return PerlIO_write(f, &buf, 1);
4938 PerlIO_puts(PerlIO *f, const char *s)
4941 return PerlIO_write(f, s, strlen(s));
4944 #undef PerlIO_rewind
4946 PerlIO_rewind(PerlIO *f)
4949 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4953 #undef PerlIO_vprintf
4955 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4964 Perl_va_copy(ap, apc);
4965 sv = vnewSVpvf(fmt, &apc);
4967 sv = vnewSVpvf(fmt, &ap);
4969 s = SvPV_const(sv, len);
4970 wrote = PerlIO_write(f, s, len);
4975 #undef PerlIO_printf
4977 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4982 result = PerlIO_vprintf(f, fmt, ap);
4987 #undef PerlIO_stdoutf
4989 PerlIO_stdoutf(const char *fmt, ...)
4995 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5000 #undef PerlIO_tmpfile
5002 PerlIO_tmpfile(void)
5009 const int fd = win32_tmpfd();
5011 f = PerlIO_fdopen(fd, "w+b");
5013 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5015 char tempname[] = "/tmp/PerlIO_XXXXXX";
5016 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5019 * I have no idea how portable mkstemp() is ... NI-S
5021 if (tmpdir && *tmpdir) {
5022 /* if TMPDIR is set and not empty, we try that first */
5023 sv = newSVpv(tmpdir, 0);
5024 sv_catpv(sv, tempname + 4);
5025 fd = mkstemp(SvPVX(sv));
5029 /* else we try /tmp */
5030 fd = mkstemp(tempname);
5033 f = PerlIO_fdopen(fd, "w+");
5035 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5036 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5039 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5040 FILE * const stdio = PerlSIO_tmpfile();
5043 f = PerlIO_fdopen(fileno(stdio), "w+");
5045 # endif /* else HAS_MKSTEMP */
5046 #endif /* else WIN32 */
5053 #endif /* USE_SFIO */
5054 #endif /* PERLIO_IS_STDIO */
5056 /*======================================================================================*/
5058 * Now some functions in terms of above which may be needed even if we are
5059 * not in true PerlIO mode
5062 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5065 const char *direction = NULL;
5068 * Need to supply default layer info from open.pm
5074 if (mode && mode[0] != 'r') {
5075 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5076 direction = "open>";
5078 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5079 direction = "open<";
5084 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5087 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5092 #undef PerlIO_setpos
5094 PerlIO_setpos(PerlIO *f, SV *pos)
5099 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5100 if (f && len == sizeof(Off_t))
5101 return PerlIO_seek(f, *posn, SEEK_SET);
5103 SETERRNO(EINVAL, SS_IVCHAN);
5107 #undef PerlIO_setpos
5109 PerlIO_setpos(PerlIO *f, SV *pos)
5114 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5115 if (f && len == sizeof(Fpos_t)) {
5116 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5117 return fsetpos64(f, fpos);
5119 return fsetpos(f, fpos);
5123 SETERRNO(EINVAL, SS_IVCHAN);
5129 #undef PerlIO_getpos
5131 PerlIO_getpos(PerlIO *f, SV *pos)
5134 Off_t posn = PerlIO_tell(f);
5135 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5136 return (posn == (Off_t) - 1) ? -1 : 0;
5139 #undef PerlIO_getpos
5141 PerlIO_getpos(PerlIO *f, SV *pos)
5146 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5147 code = fgetpos64(f, &fpos);
5149 code = fgetpos(f, &fpos);
5151 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5156 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5159 vprintf(char *pat, char *args)
5161 _doprnt(pat, args, stdout);
5162 return 0; /* wrong, but perl doesn't use the return
5167 vfprintf(FILE *fd, char *pat, char *args)
5169 _doprnt(pat, args, fd);
5170 return 0; /* wrong, but perl doesn't use the return
5176 #ifndef PerlIO_vsprintf
5178 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5181 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5182 PERL_UNUSED_CONTEXT;
5184 #ifndef PERL_MY_VSNPRINTF_GUARDED
5185 if (val < 0 || (n > 0 ? val >= n : 0)) {
5186 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5193 #ifndef PerlIO_sprintf
5195 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5200 result = PerlIO_vsprintf(s, n, fmt, ap);
5208 * c-indentation-style: bsd
5210 * indent-tabs-mode: nil
5213 * ex: set ts=8 sts=4 sw=4 et: