3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
17 /* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
28 #ifdef PERL_IMPLICIT_SYS
34 #define PERLIO_NOT_STDIO 0
36 * This file provides those parts of PerlIO abstraction
37 * which are not #defined in perlio.h.
38 * Which these are depends on various Configure #ifdef's
42 #define PERL_IN_PERLIO_C
45 #ifdef PERL_IMPLICIT_CONTEXT
53 /* Missing proto on LynxOS */
61 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
63 /* Call the callback or PerlIOBase, and return failure. */
64 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
65 if (PerlIOValid(f)) { \
66 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
67 if (tab && tab->callback) \
68 return (*tab->callback) args; \
70 return PerlIOBase_ ## base args; \
73 SETERRNO(EBADF, SS_IVCHAN); \
76 /* Call the callback or fail, and return failure. */
77 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
78 if (PerlIOValid(f)) { \
79 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
80 if (tab && tab->callback) \
81 return (*tab->callback) args; \
82 SETERRNO(EINVAL, LIB_INVARG); \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or PerlIOBase, and be void. */
89 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 (*tab->callback) args; \
95 PerlIOBase_ ## base args; \
98 SETERRNO(EBADF, SS_IVCHAN)
100 /* Call the callback or fail, and be void. */
101 #define Perl_PerlIO_or_fail_void(f, callback, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 SETERRNO(EINVAL, LIB_INVARG); \
110 SETERRNO(EBADF, SS_IVCHAN)
112 #if defined(__osf__) && _XOPEN_SOURCE < 500
113 extern int fseeko(FILE *, off_t, int);
114 extern off_t ftello(FILE *);
117 #define NATIVE_0xd CR_NATIVE
118 #define NATIVE_0xa LF_NATIVE
120 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
123 perlsio_binmode(FILE *fp, int iotype, int mode)
126 * This used to be contents of do_binmode in doio.c
130 PERL_UNUSED_ARG(iotype);
132 if (PerlLIO_setmode(fp, mode) != -1) {
134 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
141 # if defined(USEMYBINMODE)
143 # if defined(__CYGWIN__)
144 PERL_UNUSED_ARG(iotype);
146 if (my_binmode(fp, iotype, mode) != FALSE)
152 PERL_UNUSED_ARG(iotype);
153 PERL_UNUSED_ARG(mode);
160 #define O_ACCMODE 3 /* Assume traditional implementation */
164 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
166 const int result = rawmode & O_ACCMODE;
171 ptype = IoTYPE_RDONLY;
174 ptype = IoTYPE_WRONLY;
182 *writing = (result != O_RDONLY);
184 if (result == O_RDONLY) {
188 else if (rawmode & O_APPEND) {
190 if (result != O_WRONLY)
195 if (result == O_WRONLY)
202 if (rawmode & O_BINARY)
208 #ifndef PERLIO_LAYERS
210 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
212 if (!names || !*names
213 || strEQ(names, ":crlf")
214 || strEQ(names, ":raw")
215 || strEQ(names, ":bytes")
219 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
227 PerlIO_destruct(pTHX)
232 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
234 return perlsio_binmode(fp, iotype, mode);
238 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
240 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
243 #ifdef PERL_IMPLICIT_SYS
244 return PerlSIO_fdupopen(f);
247 return win32_fdupopen(f);
250 const int fd = PerlLIO_dup(PerlIO_fileno(f));
254 const int omode = djgpp_get_stream_mode(f);
256 const int omode = fcntl(fd, F_GETFL);
258 PerlIO_intmode2str(omode,mode,NULL);
259 /* the r+ is a hack */
260 return PerlIO_fdopen(fd, mode);
265 SETERRNO(EBADF, SS_IVCHAN);
275 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
279 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
280 int imode, int perm, PerlIO *old, int narg, SV **args)
284 Perl_croak(aTHX_ "More than one argument to open");
286 if (*args == &PL_sv_undef)
287 return PerlIO_tmpfile();
290 const char *name = SvPV_const(*args, len);
291 if (!IS_SAFE_PATHNAME(name, len, "open"))
294 if (*mode == IoTYPE_NUMERIC) {
295 fd = PerlLIO_open3(name, imode, perm);
297 return PerlIO_fdopen(fd, mode + 1);
300 return PerlIO_reopen(name, mode, old);
303 return PerlIO_open(name, mode);
308 return PerlIO_fdopen(fd, (char *) mode);
313 XS(XS_PerlIO__Layer__find)
317 Perl_croak(aTHX_ "Usage class->find(name[,load])");
319 const char * const name = SvPV_nolen_const(ST(1));
320 ST(0) = (strEQ(name, "crlf")
321 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
328 Perl_boot_core_PerlIO(pTHX)
330 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
336 #ifdef PERLIO_IS_STDIO
343 * Does nothing (yet) except force this file to be included in perl
344 * binary. That allows this file to force inclusion of other functions
345 * that may be required by loadable extensions e.g. for
346 * FileHandle::tmpfile
350 #undef PerlIO_tmpfile
357 #else /* PERLIO_IS_STDIO */
359 /*======================================================================================*/
361 * Implement all the PerlIO interface ourselves.
367 PerlIO_debug(const char *fmt, ...)
372 if (!PL_perlio_debug_fd) {
374 PerlProc_getuid() == PerlProc_geteuid() &&
375 PerlProc_getgid() == PerlProc_getegid()) {
376 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
379 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
381 PL_perlio_debug_fd = -1;
383 /* tainting or set*id, so ignore the environment, and ensure we
384 skip these tests next time through. */
385 PL_perlio_debug_fd = -1;
388 if (PL_perlio_debug_fd > 0) {
391 const char * const s = CopFILE(PL_curcop);
392 /* Use fixed buffer as sv_catpvf etc. needs SVs */
394 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
395 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
396 rc = PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
398 const char *s = CopFILE(PL_curcop);
400 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
401 (IV) CopLINE(PL_curcop));
402 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
404 s = SvPV_const(sv, len);
405 rc = PerlLIO_write(PL_perlio_debug_fd, s, len);
408 /* silently ignore failures */
414 /*--------------------------------------------------------------------------------------*/
417 * Inner level routines
420 /* check that the head field of each layer points back to the head */
423 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
425 PerlIO_verify_head(pTHX_ PerlIO *f)
431 p = head = PerlIOBase(f)->head;
434 assert(p->head == head);
435 if (p == (PerlIOl*)f)
442 # define VERIFY_HEAD(f)
447 * Table of pointers to the PerlIO structs (malloc'ed)
449 #define PERLIO_TABLE_SIZE 64
452 PerlIO_init_table(pTHX)
456 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
462 PerlIO_allocate(pTHX)
466 * Find a free slot in the table, allocating new table as necessary
471 while ((f = *last)) {
473 last = (PerlIOl **) (f);
474 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
475 if (!((++f)->next)) {
476 f->flags = 0; /* lockcnt */
483 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
487 *last = (PerlIOl*) f++;
488 f->flags = 0; /* lockcnt */
494 #undef PerlIO_fdupopen
496 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
498 if (PerlIOValid(f)) {
499 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
500 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
502 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
504 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
508 SETERRNO(EBADF, SS_IVCHAN);
514 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
516 PerlIOl * const table = *tablep;
519 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
520 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
521 PerlIOl * const f = table + i;
523 PerlIO_close(&(f->next));
533 PerlIO_list_alloc(pTHX)
537 Newxz(list, 1, PerlIO_list_t);
543 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
546 if (--list->refcnt == 0) {
549 for (i = 0; i < list->cur; i++)
550 SvREFCNT_dec(list->array[i].arg);
551 Safefree(list->array);
559 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
565 if (list->cur >= list->len) {
568 Renew(list->array, list->len, PerlIO_pair_t);
570 Newx(list->array, list->len, PerlIO_pair_t);
572 p = &(list->array[list->cur++]);
574 if ((p->arg = arg)) {
575 SvREFCNT_inc_simple_void_NN(arg);
580 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
582 PerlIO_list_t *list = NULL;
585 list = PerlIO_list_alloc(aTHX);
586 for (i=0; i < proto->cur; i++) {
587 SV *arg = proto->array[i].arg;
590 arg = sv_dup(arg, param);
592 PERL_UNUSED_ARG(param);
594 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
601 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
604 PerlIOl **table = &proto->Iperlio;
607 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
608 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
609 PerlIO_init_table(aTHX);
610 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
611 while ((f = *table)) {
613 table = (PerlIOl **) (f++);
614 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
616 (void) fp_dup(&(f->next), 0, param);
623 PERL_UNUSED_ARG(proto);
624 PERL_UNUSED_ARG(param);
629 PerlIO_destruct(pTHX)
632 PerlIOl **table = &PL_perlio;
635 PerlIO_debug("Destruct %p\n",(void*)aTHX);
637 while ((f = *table)) {
639 table = (PerlIOl **) (f++);
640 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
641 PerlIO *x = &(f->next);
644 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
645 PerlIO_debug("Destruct popping %s\n", l->tab->name);
659 PerlIO_pop(pTHX_ PerlIO *f)
661 const PerlIOl *l = *f;
664 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
665 l->tab ? l->tab->name : "(Null)");
666 if (l->tab && l->tab->Popped) {
668 * If popped returns non-zero do not free its layer structure
669 * it has either done so itself, or it is shared and still in
672 if ((*l->tab->Popped) (aTHX_ f) != 0)
675 if (PerlIO_lockcnt(f)) {
676 /* we're in use; defer freeing the structure */
677 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
678 PerlIOBase(f)->tab = NULL;
688 /* Return as an array the stack of layers on a filehandle. Note that
689 * the stack is returned top-first in the array, and there are three
690 * times as many array elements as there are layers in the stack: the
691 * first element of a layer triplet is the name, the second one is the
692 * arguments, and the third one is the flags. */
695 PerlIO_get_layers(pTHX_ PerlIO *f)
698 AV * const av = newAV();
700 if (PerlIOValid(f)) {
701 PerlIOl *l = PerlIOBase(f);
704 /* There is some collusion in the implementation of
705 XS_PerlIO_get_layers - it knows that name and flags are
706 generated as fresh SVs here, and takes advantage of that to
707 "copy" them by taking a reference. If it changes here, it needs
708 to change there too. */
709 SV * const name = l->tab && l->tab->name ?
710 newSVpv(l->tab->name, 0) : &PL_sv_undef;
711 SV * const arg = l->tab && l->tab->Getarg ?
712 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
715 av_push(av, newSViv((IV)l->flags));
723 /*--------------------------------------------------------------------------------------*/
725 * XS Interface for perl code
729 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
733 if ((SSize_t) len <= 0)
735 for (i = 0; i < PL_known_layers->cur; i++) {
736 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
737 const STRLEN this_len = strlen(f->name);
738 if (this_len == len && memEQ(f->name, name, len)) {
739 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
743 if (load && PL_subname && PL_def_layerlist
744 && PL_def_layerlist->cur >= 2) {
745 if (PL_in_load_module) {
746 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
749 SV * const pkgsv = newSVpvs("PerlIO");
750 SV * const layer = newSVpvn(name, len);
751 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
753 SAVEBOOL(PL_in_load_module);
755 SAVEGENERICSV(PL_warnhook);
756 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
758 PL_in_load_module = TRUE;
760 * The two SVs are magically freed by load_module
762 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
764 return PerlIO_find_layer(aTHX_ name, len, 0);
767 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
771 #ifdef USE_ATTRIBUTES_FOR_PERLIO
774 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
777 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
778 PerlIO * const ifp = IoIFP(io);
779 PerlIO * const ofp = IoOFP(io);
780 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
781 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
787 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
790 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
791 PerlIO * const ifp = IoIFP(io);
792 PerlIO * const ofp = IoOFP(io);
793 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
794 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
800 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
802 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
807 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
809 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
813 MGVTBL perlio_vtab = {
821 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
824 SV * const sv = SvRV(ST(1));
825 AV * const av = newAV();
829 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
831 mg = mg_find(sv, PERL_MAGIC_ext);
832 mg->mg_virtual = &perlio_vtab;
834 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
835 for (i = 2; i < items; i++) {
837 const char * const name = SvPV_const(ST(i), len);
838 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
840 av_push(av, SvREFCNT_inc_simple_NN(layer));
851 #endif /* USE_ATTIBUTES_FOR_PERLIO */
854 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
856 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
857 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
861 XS(XS_PerlIO__Layer__NoWarnings)
863 /* This is used as a %SIG{__WARN__} handler to suppress warnings
864 during loading of layers.
870 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
874 XS(XS_PerlIO__Layer__find)
880 Perl_croak(aTHX_ "Usage class->find(name[,load])");
883 const char * const name = SvPV_const(ST(1), len);
884 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
885 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
887 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
894 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
897 if (!PL_known_layers)
898 PL_known_layers = PerlIO_list_alloc(aTHX);
899 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
900 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
904 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
908 const char *s = names;
910 while (isSPACE(*s) || *s == ':')
915 const char *as = NULL;
917 if (!isIDFIRST(*s)) {
919 * Message is consistent with how attribute lists are
920 * passed. Even though this means "foo : : bar" is
921 * seen as an invalid separator character.
923 const char q = ((*s == '\'') ? '"' : '\'');
924 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
925 "Invalid separator character %c%c%c in PerlIO layer specification %s",
927 SETERRNO(EINVAL, LIB_INVARG);
932 } while (isWORDCHAR(*e));
948 * It's a nul terminated string, not allowed
949 * to \ the terminating null. Anything other
950 * character is passed over.
960 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
961 "Argument list not closed for PerlIO layer \"%.*s\"",
973 PerlIO_funcs * const layer =
974 PerlIO_find_layer(aTHX_ s, llen, 1);
978 arg = newSVpvn(as, alen);
979 PerlIO_list_push(aTHX_ av, layer,
980 (arg) ? arg : &PL_sv_undef);
984 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
997 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1000 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1001 #ifdef PERLIO_USING_CRLF
1004 if (PerlIO_stdio.Set_ptrcnt)
1005 tab = &PerlIO_stdio;
1007 PerlIO_debug("Pushing %s\n", tab->name);
1008 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1013 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1015 return av->array[n].arg;
1019 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1021 if (n >= 0 && n < av->cur) {
1022 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1023 av->array[n].funcs->name);
1024 return av->array[n].funcs;
1027 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1032 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1034 PERL_UNUSED_ARG(mode);
1035 PERL_UNUSED_ARG(arg);
1036 PERL_UNUSED_ARG(tab);
1037 if (PerlIOValid(f)) {
1039 PerlIO_pop(aTHX_ f);
1045 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1046 sizeof(PerlIO_funcs),
1049 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1069 NULL, /* get_base */
1070 NULL, /* get_bufsiz */
1073 NULL, /* set_ptrcnt */
1077 PerlIO_default_layers(pTHX)
1080 if (!PL_def_layerlist) {
1081 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1082 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1083 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1084 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1086 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1088 osLayer = &PerlIO_win32;
1091 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1092 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1093 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1094 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1095 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1096 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1097 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1098 PerlIO_list_push(aTHX_ PL_def_layerlist,
1099 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1102 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1105 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1108 if (PL_def_layerlist->cur < 2) {
1109 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1111 return PL_def_layerlist;
1115 Perl_boot_core_PerlIO(pTHX)
1117 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1118 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1121 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1122 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1126 PerlIO_default_layer(pTHX_ I32 n)
1129 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1132 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1135 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1136 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1139 PerlIO_stdstreams(pTHX)
1143 PerlIO_init_table(aTHX);
1144 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1145 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1146 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1151 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1154 if (tab->fsize != sizeof(PerlIO_funcs)) {
1156 "%s (%"UVuf") does not match %s (%"UVuf")",
1157 "PerlIO layer function table size", (UV)tab->fsize,
1158 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1162 if (tab->size < sizeof(PerlIOl)) {
1164 "%s (%"UVuf") smaller than %s (%"UVuf")",
1165 "PerlIO layer instance size", (UV)tab->size,
1166 "size expected by this perl", (UV)sizeof(PerlIOl) );
1168 /* Real layer with a data area */
1171 Newxz(temp, tab->size, char);
1175 l->tab = (PerlIO_funcs*) tab;
1176 l->head = ((PerlIOl*)f)->head;
1178 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1179 (void*)f, tab->name,
1180 (mode) ? mode : "(Null)", (void*)arg);
1181 if (*l->tab->Pushed &&
1183 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1184 PerlIO_pop(aTHX_ f);
1193 /* Pseudo-layer where push does its own stack adjust */
1194 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1195 (mode) ? mode : "(Null)", (void*)arg);
1197 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1205 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1206 IV n, const char *mode, int fd, int imode, int perm,
1207 PerlIO *old, int narg, SV **args)
1209 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1210 if (tab && tab->Open) {
1211 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1212 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1218 SETERRNO(EINVAL, LIB_INVARG);
1223 PerlIOBase_binmode(pTHX_ PerlIO *f)
1225 if (PerlIOValid(f)) {
1226 /* Is layer suitable for raw stream ? */
1227 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1228 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1229 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1232 /* Not suitable - pop it */
1233 PerlIO_pop(aTHX_ f);
1241 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1243 PERL_UNUSED_ARG(mode);
1244 PERL_UNUSED_ARG(arg);
1245 PERL_UNUSED_ARG(tab);
1247 if (PerlIOValid(f)) {
1252 * Strip all layers that are not suitable for a raw stream
1255 while (t && (l = *t)) {
1256 if (l->tab && l->tab->Binmode) {
1257 /* Has a handler - normal case */
1258 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1260 /* Layer still there - move down a layer */
1269 /* No handler - pop it */
1270 PerlIO_pop(aTHX_ t);
1273 if (PerlIOValid(f)) {
1274 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1275 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1283 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1284 PerlIO_list_t *layers, IV n, IV max)
1288 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1290 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1301 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1305 save_scalar(PL_errgv);
1307 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1308 code = PerlIO_parse_layers(aTHX_ layers, names);
1310 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1312 PerlIO_list_free(aTHX_ layers);
1319 /*--------------------------------------------------------------------------------------*/
1321 * Given the abstraction above the public API functions
1325 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1327 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1328 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1329 PerlIOBase(f)->tab->name : "(Null)",
1330 iotype, mode, (names) ? names : "(Null)");
1333 /* Do not flush etc. if (e.g.) switching encodings.
1334 if a pushed layer knows it needs to flush lower layers
1335 (for example :unix which is never going to call them)
1336 it can do the flush when it is pushed.
1338 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1341 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1342 #ifdef PERLIO_USING_CRLF
1343 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1344 O_BINARY so we can look for it in mode.
1346 if (!(mode & O_BINARY)) {
1348 /* FIXME?: Looking down the layer stack seems wrong,
1349 but is a way of reaching past (say) an encoding layer
1350 to flip CRLF-ness of the layer(s) below
1353 /* Perhaps we should turn on bottom-most aware layer
1354 e.g. Ilya's idea that UNIX TTY could serve
1356 if (PerlIOBase(f)->tab &&
1357 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1359 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1360 /* Not in text mode - flush any pending stuff and flip it */
1362 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1364 /* Only need to turn it on in one layer so we are done */
1369 /* Not finding a CRLF aware layer presumably means we are binary
1370 which is not what was requested - so we failed
1371 We _could_ push :crlf layer but so could caller
1376 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1377 So code that used to be here is now in PerlIORaw_pushed().
1379 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1384 PerlIO__close(pTHX_ PerlIO *f)
1386 if (PerlIOValid(f)) {
1387 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1388 if (tab && tab->Close)
1389 return (*tab->Close)(aTHX_ f);
1391 return PerlIOBase_close(aTHX_ f);
1394 SETERRNO(EBADF, SS_IVCHAN);
1400 Perl_PerlIO_close(pTHX_ PerlIO *f)
1402 const int code = PerlIO__close(aTHX_ f);
1403 while (PerlIOValid(f)) {
1404 PerlIO_pop(aTHX_ f);
1405 if (PerlIO_lockcnt(f))
1406 /* we're in use; the 'pop' deferred freeing the structure */
1413 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1416 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1420 static PerlIO_funcs *
1421 PerlIO_layer_from_ref(pTHX_ SV *sv)
1425 * For any scalar type load the handler which is bundled with perl
1427 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1428 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1429 /* This isn't supposed to happen, since PerlIO::scalar is core,
1430 * but could happen anyway in smaller installs or with PAR */
1432 /* diag_listed_as: Unknown PerlIO layer "%s" */
1433 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1438 * For other types allow if layer is known but don't try and load it
1440 switch (SvTYPE(sv)) {
1442 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1444 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1446 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1448 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1455 PerlIO_resolve_layers(pTHX_ const char *layers,
1456 const char *mode, int narg, SV **args)
1459 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1462 PerlIO_stdstreams(aTHX);
1464 SV * const arg = *args;
1466 * If it is a reference but not an object see if we have a handler
1469 if (SvROK(arg) && !sv_isobject(arg)) {
1470 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1472 def = PerlIO_list_alloc(aTHX);
1473 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1477 * Don't fail if handler cannot be found :via(...) etc. may do
1478 * something sensible else we will just stringfy and open
1483 if (!layers || !*layers)
1484 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1485 if (layers && *layers) {
1488 av = PerlIO_clone_list(aTHX_ def, NULL);
1493 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1497 PerlIO_list_free(aTHX_ av);
1509 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1510 int imode, int perm, PerlIO *f, int narg, SV **args)
1513 if (!f && narg == 1 && *args == &PL_sv_undef) {
1514 if ((f = PerlIO_tmpfile())) {
1515 if (!layers || !*layers)
1516 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1517 if (layers && *layers)
1518 PerlIO_apply_layers(aTHX_ f, mode, layers);
1522 PerlIO_list_t *layera;
1524 PerlIO_funcs *tab = NULL;
1525 if (PerlIOValid(f)) {
1527 * This is "reopen" - it is not tested as perl does not use it
1531 layera = PerlIO_list_alloc(aTHX);
1534 if (l->tab && l->tab->Getarg)
1535 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1536 PerlIO_list_push(aTHX_ layera, l->tab,
1537 (arg) ? arg : &PL_sv_undef);
1539 l = *PerlIONext(&l);
1543 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1549 * Start at "top" of layer stack
1551 n = layera->cur - 1;
1553 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1562 * Found that layer 'n' can do opens - call it
1564 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1565 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1567 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1568 tab->name, layers ? layers : "(Null)", mode, fd,
1569 imode, perm, (void*)f, narg, (void*)args);
1571 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1574 SETERRNO(EINVAL, LIB_INVARG);
1578 if (n + 1 < layera->cur) {
1580 * More layers above the one that we used to open -
1583 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1584 /* If pushing layers fails close the file */
1591 PerlIO_list_free(aTHX_ layera);
1598 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1600 PERL_ARGS_ASSERT_PERLIO_READ;
1602 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1606 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1608 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1610 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1614 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1616 PERL_ARGS_ASSERT_PERLIO_WRITE;
1618 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1622 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1624 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1628 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1630 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1634 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1639 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1641 if (tab && tab->Flush)
1642 return (*tab->Flush) (aTHX_ f);
1644 return 0; /* If no Flush defined, silently succeed. */
1647 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1648 SETERRNO(EBADF, SS_IVCHAN);
1654 * Is it good API design to do flush-all on NULL, a potentially
1655 * erroneous input? Maybe some magical value (PerlIO*
1656 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1657 * things on fflush(NULL), but should we be bound by their design
1660 PerlIOl **table = &PL_perlio;
1663 while ((ff = *table)) {
1665 table = (PerlIOl **) (ff++);
1666 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1667 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1677 PerlIOBase_flush_linebuf(pTHX)
1680 PerlIOl **table = &PL_perlio;
1682 while ((f = *table)) {
1684 table = (PerlIOl **) (f++);
1685 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1687 && (PerlIOBase(&(f->next))->
1688 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1689 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1690 PerlIO_flush(&(f->next));
1697 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1699 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1703 PerlIO_isutf8(PerlIO *f)
1706 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1708 SETERRNO(EBADF, SS_IVCHAN);
1714 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1716 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1720 Perl_PerlIO_error(pTHX_ PerlIO *f)
1722 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1726 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1728 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1732 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1734 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1738 PerlIO_has_base(PerlIO *f)
1740 if (PerlIOValid(f)) {
1741 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1744 return (tab->Get_base != NULL);
1751 PerlIO_fast_gets(PerlIO *f)
1753 if (PerlIOValid(f)) {
1754 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1755 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1758 return (tab->Set_ptrcnt != NULL);
1766 PerlIO_has_cntptr(PerlIO *f)
1768 if (PerlIOValid(f)) {
1769 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1772 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1779 PerlIO_canset_cnt(PerlIO *f)
1781 if (PerlIOValid(f)) {
1782 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1785 return (tab->Set_ptrcnt != NULL);
1792 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1794 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1798 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1800 /* Note that Get_bufsiz returns a Size_t */
1801 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1805 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1807 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1811 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1813 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1817 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1819 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1823 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1825 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1829 /*--------------------------------------------------------------------------------------*/
1831 * utf8 and raw dummy layers
1835 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1837 PERL_UNUSED_CONTEXT;
1838 PERL_UNUSED_ARG(mode);
1839 PERL_UNUSED_ARG(arg);
1840 if (PerlIOValid(f)) {
1841 if (tab && tab->kind & PERLIO_K_UTF8)
1842 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1844 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1850 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1851 sizeof(PerlIO_funcs),
1854 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1874 NULL, /* get_base */
1875 NULL, /* get_bufsiz */
1878 NULL, /* set_ptrcnt */
1881 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1882 sizeof(PerlIO_funcs),
1885 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1905 NULL, /* get_base */
1906 NULL, /* get_bufsiz */
1909 NULL, /* set_ptrcnt */
1912 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1913 sizeof(PerlIO_funcs),
1936 NULL, /* get_base */
1937 NULL, /* get_bufsiz */
1940 NULL, /* set_ptrcnt */
1942 /*--------------------------------------------------------------------------------------*/
1943 /*--------------------------------------------------------------------------------------*/
1945 * "Methods" of the "base class"
1949 PerlIOBase_fileno(pTHX_ PerlIO *f)
1951 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1955 PerlIO_modestr(PerlIO * f, char *buf)
1958 if (PerlIOValid(f)) {
1959 const IV flags = PerlIOBase(f)->flags;
1960 if (flags & PERLIO_F_APPEND) {
1962 if (flags & PERLIO_F_CANREAD) {
1966 else if (flags & PERLIO_F_CANREAD) {
1968 if (flags & PERLIO_F_CANWRITE)
1971 else if (flags & PERLIO_F_CANWRITE) {
1973 if (flags & PERLIO_F_CANREAD) {
1977 #ifdef PERLIO_USING_CRLF
1978 if (!(flags & PERLIO_F_CRLF))
1988 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1990 PerlIOl * const l = PerlIOBase(f);
1991 PERL_UNUSED_CONTEXT;
1992 PERL_UNUSED_ARG(arg);
1994 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1995 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1996 if (tab && tab->Set_ptrcnt != NULL)
1997 l->flags |= PERLIO_F_FASTGETS;
1999 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2003 l->flags |= PERLIO_F_CANREAD;
2006 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2009 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2012 SETERRNO(EINVAL, LIB_INVARG);
2018 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2021 l->flags &= ~PERLIO_F_CRLF;
2024 l->flags |= PERLIO_F_CRLF;
2027 SETERRNO(EINVAL, LIB_INVARG);
2034 l->flags |= l->next->flags &
2035 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2040 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2041 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2042 l->flags, PerlIO_modestr(f, temp));
2048 PerlIOBase_popped(pTHX_ PerlIO *f)
2050 PERL_UNUSED_CONTEXT;
2056 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2059 * Save the position as current head considers it
2061 const Off_t old = PerlIO_tell(f);
2062 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2063 PerlIOSelf(f, PerlIOBuf)->posn = old;
2064 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2068 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2070 STDCHAR *buf = (STDCHAR *) vbuf;
2072 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2073 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2074 SETERRNO(EBADF, SS_IVCHAN);
2080 SSize_t avail = PerlIO_get_cnt(f);
2083 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2085 STDCHAR *ptr = PerlIO_get_ptr(f);
2086 Copy(ptr, buf, take, STDCHAR);
2087 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2090 if (avail == 0) /* set_ptrcnt could have reset avail */
2093 if (count > 0 && avail <= 0) {
2094 if (PerlIO_fill(f) != 0)
2099 return (buf - (STDCHAR *) vbuf);
2105 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2107 PERL_UNUSED_CONTEXT;
2113 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2115 PERL_UNUSED_CONTEXT;
2121 PerlIOBase_close(pTHX_ PerlIO *f)
2124 if (PerlIOValid(f)) {
2125 PerlIO *n = PerlIONext(f);
2126 code = PerlIO_flush(f);
2127 PerlIOBase(f)->flags &=
2128 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2129 while (PerlIOValid(n)) {
2130 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2131 if (tab && tab->Close) {
2132 if ((*tab->Close)(aTHX_ n) != 0)
2137 PerlIOBase(n)->flags &=
2138 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2144 SETERRNO(EBADF, SS_IVCHAN);
2150 PerlIOBase_eof(pTHX_ PerlIO *f)
2152 PERL_UNUSED_CONTEXT;
2153 if (PerlIOValid(f)) {
2154 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2160 PerlIOBase_error(pTHX_ PerlIO *f)
2162 PERL_UNUSED_CONTEXT;
2163 if (PerlIOValid(f)) {
2164 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2170 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2172 if (PerlIOValid(f)) {
2173 PerlIO * const n = PerlIONext(f);
2174 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2181 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2183 PERL_UNUSED_CONTEXT;
2184 if (PerlIOValid(f)) {
2185 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2190 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2196 arg = sv_dup(arg, param);
2197 SvREFCNT_inc_simple_void_NN(arg);
2201 return newSVsv(arg);
2204 PERL_UNUSED_ARG(param);
2205 return newSVsv(arg);
2210 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2212 PerlIO * const nexto = PerlIONext(o);
2213 if (PerlIOValid(nexto)) {
2214 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2215 if (tab && tab->Dup)
2216 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2218 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2221 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2224 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2225 self ? self->name : "(Null)",
2226 (void*)f, (void*)o, (void*)param);
2227 if (self && self->Getarg)
2228 arg = (*self->Getarg)(aTHX_ o, param, flags);
2229 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2230 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2231 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2237 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2239 /* Must be called with PL_perlio_mutex locked. */
2241 S_more_refcounted_fds(pTHX_ const int new_fd) {
2243 const int old_max = PL_perlio_fd_refcnt_size;
2244 const int new_max = 16 + (new_fd & ~15);
2247 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2248 old_max, new_fd, new_max);
2250 if (new_fd < old_max) {
2254 assert (new_max > new_fd);
2256 /* Use plain realloc() since we need this memory to be really
2257 * global and visible to all the interpreters and/or threads. */
2258 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2262 MUTEX_UNLOCK(&PL_perlio_mutex);
2267 PL_perlio_fd_refcnt_size = new_max;
2268 PL_perlio_fd_refcnt = new_array;
2270 PerlIO_debug("Zeroing %p, %d\n",
2271 (void*)(new_array + old_max),
2274 Zero(new_array + old_max, new_max - old_max, int);
2281 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2282 PERL_UNUSED_CONTEXT;
2286 PerlIOUnix_refcnt_inc(int fd)
2293 MUTEX_LOCK(&PL_perlio_mutex);
2295 if (fd >= PL_perlio_fd_refcnt_size)
2296 S_more_refcounted_fds(aTHX_ fd);
2298 PL_perlio_fd_refcnt[fd]++;
2299 if (PL_perlio_fd_refcnt[fd] <= 0) {
2300 /* diag_listed_as: refcnt_inc: fd %d%s */
2301 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2302 fd, PL_perlio_fd_refcnt[fd]);
2304 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2305 fd, PL_perlio_fd_refcnt[fd]);
2308 MUTEX_UNLOCK(&PL_perlio_mutex);
2311 /* diag_listed_as: refcnt_inc: fd %d%s */
2312 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2317 PerlIOUnix_refcnt_dec(int fd)
2323 MUTEX_LOCK(&PL_perlio_mutex);
2325 if (fd >= PL_perlio_fd_refcnt_size) {
2326 /* diag_listed_as: refcnt_dec: fd %d%s */
2327 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2328 fd, PL_perlio_fd_refcnt_size);
2330 if (PL_perlio_fd_refcnt[fd] <= 0) {
2331 /* diag_listed_as: refcnt_dec: fd %d%s */
2332 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2333 fd, PL_perlio_fd_refcnt[fd]);
2335 cnt = --PL_perlio_fd_refcnt[fd];
2336 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2338 MUTEX_UNLOCK(&PL_perlio_mutex);
2341 /* diag_listed_as: refcnt_dec: fd %d%s */
2342 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2348 PerlIOUnix_refcnt(int fd)
2355 MUTEX_LOCK(&PL_perlio_mutex);
2357 if (fd >= PL_perlio_fd_refcnt_size) {
2358 /* diag_listed_as: refcnt: fd %d%s */
2359 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2360 fd, PL_perlio_fd_refcnt_size);
2362 if (PL_perlio_fd_refcnt[fd] <= 0) {
2363 /* diag_listed_as: refcnt: fd %d%s */
2364 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2365 fd, PL_perlio_fd_refcnt[fd]);
2367 cnt = PL_perlio_fd_refcnt[fd];
2369 MUTEX_UNLOCK(&PL_perlio_mutex);
2372 /* diag_listed_as: refcnt: fd %d%s */
2373 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2379 PerlIO_cleanup(pTHX)
2384 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2386 PerlIO_debug("Cleanup layers\n");
2389 /* Raise STDIN..STDERR refcount so we don't close them */
2390 for (i=0; i < 3; i++)
2391 PerlIOUnix_refcnt_inc(i);
2392 PerlIO_cleantable(aTHX_ &PL_perlio);
2393 /* Restore STDIN..STDERR refcount */
2394 for (i=0; i < 3; i++)
2395 PerlIOUnix_refcnt_dec(i);
2397 if (PL_known_layers) {
2398 PerlIO_list_free(aTHX_ PL_known_layers);
2399 PL_known_layers = NULL;
2401 if (PL_def_layerlist) {
2402 PerlIO_list_free(aTHX_ PL_def_layerlist);
2403 PL_def_layerlist = NULL;
2407 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2411 /* XXX we can't rely on an interpreter being present at this late stage,
2412 XXX so we can't use a function like PerlLIO_write that relies on one
2413 being present (at least in win32) :-(.
2418 /* By now all filehandles should have been closed, so any
2419 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2421 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2422 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2423 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2425 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2426 if (PL_perlio_fd_refcnt[i]) {
2428 my_snprintf(buf, sizeof(buf),
2429 "PerlIO_teardown: fd %d refcnt=%d\n",
2430 i, PL_perlio_fd_refcnt[i]);
2431 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2437 /* Not bothering with PL_perlio_mutex since by now
2438 * all the interpreters are gone. */
2439 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2440 && PL_perlio_fd_refcnt) {
2441 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2442 PL_perlio_fd_refcnt = NULL;
2443 PL_perlio_fd_refcnt_size = 0;
2447 /*--------------------------------------------------------------------------------------*/
2449 * Bottom-most level for UNIX-like case
2453 struct _PerlIO base; /* The generic part */
2454 int fd; /* UNIX like file descriptor */
2455 int oflags; /* open/fcntl flags */
2459 S_lockcnt_dec(pTHX_ const void* f)
2461 PerlIO_lockcnt((PerlIO*)f)--;
2465 /* call the signal handler, and if that handler happens to clear
2466 * this handle, free what we can and return true */
2469 S_perlio_async_run(pTHX_ PerlIO* f) {
2471 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2472 PerlIO_lockcnt(f)++;
2474 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2478 /* we've just run some perl-level code that could have done
2479 * anything, including closing the file or clearing this layer.
2480 * If so, free any lower layers that have already been
2481 * cleared, then return an error. */
2482 while (PerlIOValid(f) &&
2483 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2485 const PerlIOl *l = *f;
2494 PerlIOUnix_oflags(const char *mode)
2497 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2502 if (*++mode == '+') {
2509 oflags = O_CREAT | O_TRUNC;
2510 if (*++mode == '+') {
2519 oflags = O_CREAT | O_APPEND;
2520 if (*++mode == '+') {
2533 else if (*mode == 't') {
2535 oflags &= ~O_BINARY;
2539 #ifdef PERLIO_USING_CRLF
2541 * If neither "t" nor "b" was specified, open the file
2547 if (*mode || oflags == -1) {
2548 SETERRNO(EINVAL, LIB_INVARG);
2555 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2557 PERL_UNUSED_CONTEXT;
2558 return PerlIOSelf(f, PerlIOUnix)->fd;
2562 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2564 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2567 if (PerlLIO_fstat(fd, &st) == 0) {
2568 if (!S_ISREG(st.st_mode)) {
2569 PerlIO_debug("%d is not regular file\n",fd);
2570 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2573 PerlIO_debug("%d _is_ a regular file\n",fd);
2579 PerlIOUnix_refcnt_inc(fd);
2580 PERL_UNUSED_CONTEXT;
2584 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2586 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2587 if (*PerlIONext(f)) {
2588 /* We never call down so do any pending stuff now */
2589 PerlIO_flush(PerlIONext(f));
2591 * XXX could (or should) we retrieve the oflags from the open file
2592 * handle rather than believing the "mode" we are passed in? XXX
2593 * Should the value on NULL mode be 0 or -1?
2595 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2596 mode ? PerlIOUnix_oflags(mode) : -1);
2598 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2604 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2606 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2608 PERL_UNUSED_CONTEXT;
2609 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2611 SETERRNO(ESPIPE, LIB_INVARG);
2613 SETERRNO(EINVAL, LIB_INVARG);
2617 new_loc = PerlLIO_lseek(fd, offset, whence);
2618 if (new_loc == (Off_t) - 1)
2620 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2625 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2626 IV n, const char *mode, int fd, int imode,
2627 int perm, PerlIO *f, int narg, SV **args)
2629 if (PerlIOValid(f)) {
2630 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2631 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2634 if (*mode == IoTYPE_NUMERIC)
2637 imode = PerlIOUnix_oflags(mode);
2639 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2646 const char *path = SvPV_const(*args, len);
2647 if (!IS_SAFE_PATHNAME(path, len, "open"))
2649 fd = PerlLIO_open3(path, imode, perm);
2653 if (*mode == IoTYPE_IMPLICIT)
2656 f = PerlIO_allocate(aTHX);
2658 if (!PerlIOValid(f)) {
2659 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2663 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2664 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2665 if (*mode == IoTYPE_APPEND)
2666 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2673 * FIXME: pop layers ???
2681 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2683 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2685 if (flags & PERLIO_DUP_FD) {
2686 fd = PerlLIO_dup(fd);
2689 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2691 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2692 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2701 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2705 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2707 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2708 #ifdef PERLIO_STD_SPECIAL
2710 return PERLIO_STD_IN(fd, vbuf, count);
2712 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2713 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2717 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2718 if (len >= 0 || errno != EINTR) {
2720 if (errno != EAGAIN) {
2721 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2724 else if (len == 0 && count != 0) {
2725 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2731 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2738 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2742 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2744 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2745 #ifdef PERLIO_STD_SPECIAL
2746 if (fd == 1 || fd == 2)
2747 return PERLIO_STD_OUT(fd, vbuf, count);
2750 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2751 if (len >= 0 || errno != EINTR) {
2753 if (errno != EAGAIN) {
2754 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2760 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2767 PerlIOUnix_tell(pTHX_ PerlIO *f)
2769 PERL_UNUSED_CONTEXT;
2771 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2776 PerlIOUnix_close(pTHX_ PerlIO *f)
2779 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2781 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2782 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2783 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2788 SETERRNO(EBADF,SS_IVCHAN);
2791 while (PerlLIO_close(fd) != 0) {
2792 if (errno != EINTR) {
2797 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2801 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2806 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2807 sizeof(PerlIO_funcs),
2814 PerlIOBase_binmode, /* binmode */
2824 PerlIOBase_noop_ok, /* flush */
2825 PerlIOBase_noop_fail, /* fill */
2828 PerlIOBase_clearerr,
2829 PerlIOBase_setlinebuf,
2830 NULL, /* get_base */
2831 NULL, /* get_bufsiz */
2834 NULL, /* set_ptrcnt */
2837 /*--------------------------------------------------------------------------------------*/
2842 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2843 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2844 broken by the last second glibc 2.3 fix
2846 #define STDIO_BUFFER_WRITABLE
2851 struct _PerlIO base;
2852 FILE *stdio; /* The stream */
2856 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2858 PERL_UNUSED_CONTEXT;
2860 if (PerlIOValid(f)) {
2861 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2863 return PerlSIO_fileno(s);
2870 PerlIOStdio_mode(const char *mode, char *tmode)
2872 char * const ret = tmode;
2878 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2886 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2889 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2890 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2891 if (toptab == tab) {
2892 /* Top is already stdio - pop self (duplicate) and use original */
2893 PerlIO_pop(aTHX_ f);
2896 const int fd = PerlIO_fileno(n);
2899 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2900 mode = PerlIOStdio_mode(mode, tmode)))) {
2901 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2902 /* We never call down so do any pending stuff now */
2903 PerlIO_flush(PerlIONext(f));
2910 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2915 PerlIO_importFILE(FILE *stdio, const char *mode)
2921 if (!mode || !*mode) {
2922 /* We need to probe to see how we can open the stream
2923 so start with read/write and then try write and read
2924 we dup() so that we can fclose without loosing the fd.
2926 Note that the errno value set by a failing fdopen
2927 varies between stdio implementations.
2929 const int fd = PerlLIO_dup(fileno(stdio));
2930 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2932 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2935 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2938 /* Don't seem to be able to open */
2944 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2945 s = PerlIOSelf(f, PerlIOStdio);
2947 PerlIOUnix_refcnt_inc(fileno(stdio));
2954 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2955 IV n, const char *mode, int fd, int imode,
2956 int perm, PerlIO *f, int narg, SV **args)
2959 if (PerlIOValid(f)) {
2961 const char * const path = SvPV_const(*args, len);
2962 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2964 if (!IS_SAFE_PATHNAME(path, len, "open"))
2966 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2967 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2972 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2978 const char * const path = SvPV_const(*args, len);
2979 if (!IS_SAFE_PATHNAME(path, len, "open"))
2981 if (*mode == IoTYPE_NUMERIC) {
2983 fd = PerlLIO_open3(path, imode, perm);
2987 bool appended = FALSE;
2989 /* Cygwin wants its 'b' early. */
2991 mode = PerlIOStdio_mode(mode, tmode);
2993 stdio = PerlSIO_fopen(path, mode);
2996 f = PerlIO_allocate(aTHX);
2999 mode = PerlIOStdio_mode(mode, tmode);
3000 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3002 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3003 PerlIOUnix_refcnt_inc(fileno(stdio));
3005 PerlSIO_fclose(stdio);
3017 if (*mode == IoTYPE_IMPLICIT) {
3024 stdio = PerlSIO_stdin;
3027 stdio = PerlSIO_stdout;
3030 stdio = PerlSIO_stderr;
3035 stdio = PerlSIO_fdopen(fd, mode =
3036 PerlIOStdio_mode(mode, tmode));
3040 f = PerlIO_allocate(aTHX);
3042 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3043 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3044 PerlIOUnix_refcnt_inc(fileno(stdio));
3054 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3056 /* This assumes no layers underneath - which is what
3057 happens, but is not how I remember it. NI-S 2001/10/16
3059 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3060 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3061 const int fd = fileno(stdio);
3063 if (flags & PERLIO_DUP_FD) {
3064 const int dfd = PerlLIO_dup(fileno(stdio));
3066 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3071 /* FIXME: To avoid messy error recovery if dup fails
3072 re-use the existing stdio as though flag was not set
3076 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3078 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3080 PerlIOUnix_refcnt_inc(fileno(stdio));
3087 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3089 PERL_UNUSED_CONTEXT;
3091 /* XXX this could use PerlIO_canset_fileno() and
3092 * PerlIO_set_fileno() support from Configure
3094 # if defined(__UCLIBC__)
3095 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3098 # elif defined(__GLIBC__)
3099 /* There may be a better way for GLIBC:
3100 - libio.h defines a flag to not close() on cleanup
3104 # elif defined(__sun)
3107 # elif defined(__hpux)
3111 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3112 your platform does not have special entry try this one.
3113 [For OSF only have confirmation for Tru64 (alpha)
3114 but assume other OSFs will be similar.]
3116 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3119 # elif defined(__FreeBSD__)
3120 /* There may be a better way on FreeBSD:
3121 - we could insert a dummy func in the _close function entry
3122 f->_close = (int (*)(void *)) dummy_close;
3126 # elif defined(__OpenBSD__)
3127 /* There may be a better way on OpenBSD:
3128 - we could insert a dummy func in the _close function entry
3129 f->_close = (int (*)(void *)) dummy_close;
3133 # elif defined(__EMX__)
3134 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3137 # elif defined(__CYGWIN__)
3138 /* There may be a better way on CYGWIN:
3139 - we could insert a dummy func in the _close function entry
3140 f->_close = (int (*)(void *)) dummy_close;
3144 # elif defined(WIN32)
3145 # if defined(UNDER_CE)
3146 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3155 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3156 (which isn't thread safe) instead
3158 # error "Don't know how to set FILE.fileno on your platform"
3166 PerlIOStdio_close(pTHX_ PerlIO *f)
3168 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3174 const int fd = fileno(stdio);
3182 #ifdef SOCKS5_VERSION_NAME
3183 /* Socks lib overrides close() but stdio isn't linked to
3184 that library (though we are) - so we must call close()
3185 on sockets on stdio's behalf.
3188 Sock_size_t optlen = sizeof(int);
3189 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3192 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3193 that a subsequent fileno() on it returns -1. Don't want to croak()
3194 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3195 trying to close an already closed handle which somehow it still has
3196 a reference to. (via.xs, I'm looking at you). */
3197 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3198 /* File descriptor still in use */
3202 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3203 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3205 if (stdio == stdout || stdio == stderr)
3206 return PerlIO_flush(f);
3207 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3208 Use Sarathy's trick from maint-5.6 to invalidate the
3209 fileno slot of the FILE *
3211 result = PerlIO_flush(f);
3213 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3216 MUTEX_LOCK(&PL_perlio_mutex);
3217 /* Right. We need a mutex here because for a brief while we
3218 will have the situation that fd is actually closed. Hence if
3219 a second thread were to get into this block, its dup() would
3220 likely return our fd as its dupfd. (after all, it is closed)
3221 Then if we get to the dup2() first, we blat the fd back
3222 (messing up its temporary as a side effect) only for it to
3223 then close its dupfd (== our fd) in its close(dupfd) */
3225 /* There is, of course, a race condition, that any other thread
3226 trying to input/output/whatever on this fd will be stuffed
3227 for the duration of this little manoeuvrer. Perhaps we
3228 should hold an IO mutex for the duration of every IO
3229 operation if we know that invalidate doesn't work on this
3230 platform, but that would suck, and could kill performance.
3232 Except that correctness trumps speed.
3233 Advice from klortho #11912. */
3235 dupfd = PerlLIO_dup(fd);
3238 MUTEX_UNLOCK(&PL_perlio_mutex);
3239 /* Oh cXap. This isn't going to go well. Not sure if we can
3240 recover from here, or if closing this particular FILE *
3241 is a good idea now. */
3246 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3248 result = PerlSIO_fclose(stdio);
3249 /* We treat error from stdio as success if we invalidated
3250 errno may NOT be expected EBADF
3252 if (invalidate && result != 0) {
3256 #ifdef SOCKS5_VERSION_NAME
3257 /* in SOCKS' case, let close() determine return value */
3261 PerlLIO_dup2(dupfd,fd);
3262 PerlLIO_close(dupfd);
3264 MUTEX_UNLOCK(&PL_perlio_mutex);
3272 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3277 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3279 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3282 STDCHAR *buf = (STDCHAR *) vbuf;
3284 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3285 * stdio does not do that for fread()
3287 const int ch = PerlSIO_fgetc(s);
3294 got = PerlSIO_fread(vbuf, 1, count, s);
3295 if (got == 0 && PerlSIO_ferror(s))
3297 if (got >= 0 || errno != EINTR)
3299 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3301 SETERRNO(0,0); /* just in case */
3307 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3310 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3312 #ifdef STDIO_BUFFER_WRITABLE
3313 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3314 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3315 STDCHAR *base = PerlIO_get_base(f);
3316 SSize_t cnt = PerlIO_get_cnt(f);
3317 STDCHAR *ptr = PerlIO_get_ptr(f);
3318 SSize_t avail = ptr - base;
3320 if (avail > count) {
3324 Move(buf-avail,ptr,avail,STDCHAR);
3327 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3328 if (PerlSIO_feof(s) && unread >= 0)
3329 PerlSIO_clearerr(s);
3334 if (PerlIO_has_cntptr(f)) {
3335 /* We can get pointer to buffer but not its base
3336 Do ungetc() but check chars are ending up in the
3339 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3340 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3342 const int ch = *--buf & 0xFF;
3343 if (ungetc(ch,s) != ch) {
3344 /* ungetc did not work */
3347 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3348 /* Did not change pointer as expected */
3349 fgetc(s); /* get char back again */
3359 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3365 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3369 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3372 got = PerlSIO_fwrite(vbuf, 1, count,
3373 PerlIOSelf(f, PerlIOStdio)->stdio);
3374 if (got >= 0 || errno != EINTR)
3376 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3378 SETERRNO(0,0); /* just in case */
3384 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3386 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3387 PERL_UNUSED_CONTEXT;
3389 return PerlSIO_fseek(stdio, offset, whence);
3393 PerlIOStdio_tell(pTHX_ PerlIO *f)
3395 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3396 PERL_UNUSED_CONTEXT;
3398 return PerlSIO_ftell(stdio);
3402 PerlIOStdio_flush(pTHX_ PerlIO *f)
3404 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3405 PERL_UNUSED_CONTEXT;
3407 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3408 return PerlSIO_fflush(stdio);
3414 * FIXME: This discards ungetc() and pre-read stuff which is not
3415 * right if this is just a "sync" from a layer above Suspect right
3416 * design is to do _this_ but not have layer above flush this
3417 * layer read-to-read
3420 * Not writeable - sync by attempting a seek
3423 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3431 PerlIOStdio_eof(pTHX_ PerlIO *f)
3433 PERL_UNUSED_CONTEXT;
3435 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3439 PerlIOStdio_error(pTHX_ PerlIO *f)
3441 PERL_UNUSED_CONTEXT;
3443 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3447 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3449 PERL_UNUSED_CONTEXT;
3451 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3455 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3457 PERL_UNUSED_CONTEXT;
3459 #ifdef HAS_SETLINEBUF
3460 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3462 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3468 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3470 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3471 return (STDCHAR*)PerlSIO_get_base(stdio);
3475 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3477 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3478 return PerlSIO_get_bufsiz(stdio);
3482 #ifdef USE_STDIO_PTR
3484 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3486 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3487 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3491 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3493 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3494 return PerlSIO_get_cnt(stdio);
3498 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3500 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3502 #ifdef STDIO_PTR_LVALUE
3503 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3504 #ifdef STDIO_PTR_LVAL_SETS_CNT
3505 assert(PerlSIO_get_cnt(stdio) == (cnt));
3507 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3509 * Setting ptr _does_ change cnt - we are done
3513 #else /* STDIO_PTR_LVALUE */
3515 #endif /* STDIO_PTR_LVALUE */
3518 * Now (or only) set cnt
3520 #ifdef STDIO_CNT_LVALUE
3521 PerlSIO_set_cnt(stdio, cnt);
3522 #else /* STDIO_CNT_LVALUE */
3523 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3524 PerlSIO_set_ptr(stdio,
3525 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3527 #else /* STDIO_PTR_LVAL_SETS_CNT */
3529 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3530 #endif /* STDIO_CNT_LVALUE */
3537 PerlIOStdio_fill(pTHX_ PerlIO *f)
3541 PERL_UNUSED_CONTEXT;
3542 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3544 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3547 * fflush()ing read-only streams can cause trouble on some stdio-s
3549 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3550 if (PerlSIO_fflush(stdio) != 0)
3554 c = PerlSIO_fgetc(stdio);
3557 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3559 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3564 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3566 #ifdef STDIO_BUFFER_WRITABLE
3567 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3568 /* Fake ungetc() to the real buffer in case system's ungetc
3571 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3572 SSize_t cnt = PerlSIO_get_cnt(stdio);
3573 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3574 if (ptr == base+1) {
3575 *--ptr = (STDCHAR) c;
3576 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3577 if (PerlSIO_feof(stdio))
3578 PerlSIO_clearerr(stdio);
3584 if (PerlIO_has_cntptr(f)) {
3586 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3593 /* An ungetc()d char is handled separately from the regular
3594 * buffer, so we stuff it in the buffer ourselves.
3595 * Should never get called as should hit code above
3597 *(--((*stdio)->_ptr)) = (unsigned char) c;
3600 /* If buffer snoop scheme above fails fall back to
3603 if (PerlSIO_ungetc(c, stdio) != c)
3611 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3612 sizeof(PerlIO_funcs),
3614 sizeof(PerlIOStdio),
3615 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3619 PerlIOBase_binmode, /* binmode */
3633 PerlIOStdio_clearerr,
3634 PerlIOStdio_setlinebuf,
3636 PerlIOStdio_get_base,
3637 PerlIOStdio_get_bufsiz,
3642 #ifdef USE_STDIO_PTR
3643 PerlIOStdio_get_ptr,
3644 PerlIOStdio_get_cnt,
3645 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3646 PerlIOStdio_set_ptrcnt,
3649 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3654 #endif /* USE_STDIO_PTR */
3657 /* Note that calls to PerlIO_exportFILE() are reversed using
3658 * PerlIO_releaseFILE(), not importFILE. */
3660 PerlIO_exportFILE(PerlIO * f, const char *mode)
3664 if (PerlIOValid(f)) {
3667 if (!mode || !*mode) {
3668 mode = PerlIO_modestr(f, buf);
3670 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3674 /* De-link any lower layers so new :stdio sticks */
3676 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3677 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3679 PerlIOUnix_refcnt_inc(fileno(stdio));
3680 /* Link previous lower layers under new one */
3684 /* restore layers list */
3694 PerlIO_findFILE(PerlIO *f)
3699 if (l->tab == &PerlIO_stdio) {
3700 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3703 l = *PerlIONext(&l);
3705 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3706 /* However, we're not really exporting a FILE * to someone else (who
3707 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3708 So we need to undo its reference count increase on the underlying file
3709 descriptor. We have to do this, because if the loop above returns you
3710 the FILE *, then *it* didn't increase any reference count. So there's
3711 only one way to be consistent. */
3712 stdio = PerlIO_exportFILE(f, NULL);
3714 const int fd = fileno(stdio);
3716 PerlIOUnix_refcnt_dec(fd);
3721 /* Use this to reverse PerlIO_exportFILE calls. */
3723 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3728 if (l->tab == &PerlIO_stdio) {
3729 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3730 if (s->stdio == f) { /* not in a loop */
3731 const int fd = fileno(f);
3733 PerlIOUnix_refcnt_dec(fd);
3736 PerlIO_pop(aTHX_ p);
3746 /*--------------------------------------------------------------------------------------*/
3748 * perlio buffer layer
3752 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3754 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3755 const int fd = PerlIO_fileno(f);
3756 if (fd >= 0 && PerlLIO_isatty(fd)) {
3757 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3759 if (*PerlIONext(f)) {
3760 const Off_t posn = PerlIO_tell(PerlIONext(f));
3761 if (posn != (Off_t) - 1) {
3765 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3769 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3770 IV n, const char *mode, int fd, int imode, int perm,
3771 PerlIO *f, int narg, SV **args)
3773 if (PerlIOValid(f)) {
3774 PerlIO *next = PerlIONext(f);
3776 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3777 if (tab && tab->Open)
3779 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3781 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3786 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3788 if (*mode == IoTYPE_IMPLICIT) {
3794 if (tab && tab->Open)
3795 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3798 SETERRNO(EINVAL, LIB_INVARG);
3800 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3802 * if push fails during open, open fails. close will pop us.
3807 fd = PerlIO_fileno(f);
3808 if (init && fd == 2) {
3810 * Initial stderr is unbuffered
3812 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3814 #ifdef PERLIO_USING_CRLF
3815 # ifdef PERLIO_IS_BINMODE_FD
3816 if (PERLIO_IS_BINMODE_FD(fd))
3817 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3821 * do something about failing setmode()? --jhi
3823 PerlLIO_setmode(fd, O_BINARY);
3826 /* Enable line buffering with record-oriented regular files
3827 * so we don't introduce an extraneous record boundary when
3828 * the buffer fills up.
3830 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3832 if (PerlLIO_fstat(fd, &st) == 0
3833 && S_ISREG(st.st_mode)
3834 && (st.st_fab_rfm == FAB$C_VAR
3835 || st.st_fab_rfm == FAB$C_VFC)) {
3836 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3847 * This "flush" is akin to sfio's sync in that it handles files in either
3848 * read or write state. For write state, we put the postponed data through
3849 * the next layers. For read state, we seek() the next layers to the
3850 * offset given by current position in the buffer, and discard the buffer
3851 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3852 * in any case?). Then the pass the stick further in chain.
3855 PerlIOBuf_flush(pTHX_ PerlIO *f)
3857 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3859 PerlIO *n = PerlIONext(f);
3860 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3862 * write() the buffer
3864 const STDCHAR *buf = b->buf;
3865 const STDCHAR *p = buf;
3866 while (p < b->ptr) {
3867 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3871 else if (count < 0 || PerlIO_error(n)) {
3872 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3877 b->posn += (p - buf);
3879 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3880 STDCHAR *buf = PerlIO_get_base(f);
3882 * Note position change
3884 b->posn += (b->ptr - buf);
3885 if (b->ptr < b->end) {
3886 /* We did not consume all of it - try and seek downstream to
3887 our logical position
3889 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3890 /* Reload n as some layers may pop themselves on seek */
3891 b->posn = PerlIO_tell(n = PerlIONext(f));
3894 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3895 data is lost for good - so return saying "ok" having undone
3898 b->posn -= (b->ptr - buf);
3903 b->ptr = b->end = b->buf;
3904 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3905 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3906 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3911 /* This discards the content of the buffer after b->ptr, and rereads
3912 * the buffer from the position off in the layer downstream; here off
3913 * is at offset corresponding to b->ptr - b->buf.
3916 PerlIOBuf_fill(pTHX_ PerlIO *f)
3918 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3919 PerlIO *n = PerlIONext(f);
3922 * Down-stream flush is defined not to loose read data so is harmless.
3923 * we would not normally be fill'ing if there was data left in anycase.
3925 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3927 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3928 PerlIOBase_flush_linebuf(aTHX);
3931 PerlIO_get_base(f); /* allocate via vtable */
3933 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3935 b->ptr = b->end = b->buf;
3937 if (!PerlIOValid(n)) {
3938 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3942 if (PerlIO_fast_gets(n)) {
3944 * Layer below is also buffered. We do _NOT_ want to call its
3945 * ->Read() because that will loop till it gets what we asked for
3946 * which may hang on a pipe etc. Instead take anything it has to
3947 * hand, or ask it to fill _once_.
3949 avail = PerlIO_get_cnt(n);
3951 avail = PerlIO_fill(n);
3953 avail = PerlIO_get_cnt(n);
3955 if (!PerlIO_error(n) && PerlIO_eof(n))
3960 STDCHAR *ptr = PerlIO_get_ptr(n);
3961 const SSize_t cnt = avail;
3962 if (avail > (SSize_t)b->bufsiz)
3964 Copy(ptr, b->buf, avail, STDCHAR);
3965 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3969 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3973 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3975 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3978 b->end = b->buf + avail;
3979 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3984 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3986 if (PerlIOValid(f)) {
3987 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3990 return PerlIOBase_read(aTHX_ f, vbuf, count);
3996 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3998 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3999 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4002 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4007 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4009 * Buffer is already a read buffer, we can overwrite any chars
4010 * which have been read back to buffer start
4012 avail = (b->ptr - b->buf);
4016 * Buffer is idle, set it up so whole buffer is available for
4020 b->end = b->buf + avail;
4022 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4024 * Buffer extends _back_ from where we are now
4026 b->posn -= b->bufsiz;
4028 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4030 * If we have space for more than count, just move count
4038 * In simple stdio-like ungetc() case chars will be already
4041 if (buf != b->ptr) {
4042 Copy(buf, b->ptr, avail, STDCHAR);
4046 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4050 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4056 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4058 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4059 const STDCHAR *buf = (const STDCHAR *) vbuf;
4060 const STDCHAR *flushptr = buf;
4064 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4066 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4067 if (PerlIO_flush(f) != 0) {
4071 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4072 flushptr = buf + count;
4073 while (flushptr > buf && *(flushptr - 1) != '\n')
4077 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4078 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4080 if (flushptr > buf && flushptr <= buf + avail)
4081 avail = flushptr - buf;
4082 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4084 Copy(buf, b->ptr, avail, STDCHAR);
4089 if (buf == flushptr)
4092 if (b->ptr >= (b->buf + b->bufsiz))
4093 if (PerlIO_flush(f) == -1)
4096 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4102 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4105 if ((code = PerlIO_flush(f)) == 0) {
4106 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4107 code = PerlIO_seek(PerlIONext(f), offset, whence);
4109 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4110 b->posn = PerlIO_tell(PerlIONext(f));
4117 PerlIOBuf_tell(pTHX_ PerlIO *f)
4119 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4121 * b->posn is file position where b->buf was read, or will be written
4123 Off_t posn = b->posn;
4124 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4125 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4127 /* As O_APPEND files are normally shared in some sense it is better
4132 /* when file is NOT shared then this is sufficient */
4133 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4135 posn = b->posn = PerlIO_tell(PerlIONext(f));
4139 * If buffer is valid adjust position by amount in buffer
4141 posn += (b->ptr - b->buf);
4147 PerlIOBuf_popped(pTHX_ PerlIO *f)
4149 const IV code = PerlIOBase_popped(aTHX_ f);
4150 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4151 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4154 b->ptr = b->end = b->buf = NULL;
4155 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4160 PerlIOBuf_close(pTHX_ PerlIO *f)
4162 const IV code = PerlIOBase_close(aTHX_ f);
4163 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4164 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4167 b->ptr = b->end = b->buf = NULL;
4168 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4173 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4175 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4182 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4184 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4187 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4188 return (b->end - b->ptr);
4193 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4195 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4196 PERL_UNUSED_CONTEXT;
4200 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4201 Newxz(b->buf,b->bufsiz, STDCHAR);
4203 b->buf = (STDCHAR *) & b->oneword;
4204 b->bufsiz = sizeof(b->oneword);
4206 b->end = b->ptr = b->buf;
4212 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4214 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4217 return (b->end - b->buf);
4221 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4223 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4225 PERL_UNUSED_ARG(cnt);
4230 assert(PerlIO_get_cnt(f) == cnt);
4231 assert(b->ptr >= b->buf);
4232 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4236 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4238 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4243 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4244 sizeof(PerlIO_funcs),
4247 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4251 PerlIOBase_binmode, /* binmode */
4265 PerlIOBase_clearerr,
4266 PerlIOBase_setlinebuf,
4271 PerlIOBuf_set_ptrcnt,
4274 /*--------------------------------------------------------------------------------------*/
4276 * Temp layer to hold unread chars when cannot do it any other way
4280 PerlIOPending_fill(pTHX_ PerlIO *f)
4283 * Should never happen
4290 PerlIOPending_close(pTHX_ PerlIO *f)
4293 * A tad tricky - flush pops us, then we close new top
4296 return PerlIO_close(f);
4300 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4303 * A tad tricky - flush pops us, then we seek new top
4306 return PerlIO_seek(f, offset, whence);
4311 PerlIOPending_flush(pTHX_ PerlIO *f)
4313 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4314 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4318 PerlIO_pop(aTHX_ f);
4323 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4329 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4334 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4336 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4337 PerlIOl * const l = PerlIOBase(f);
4339 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4340 * etc. get muddled when it changes mid-string when we auto-pop.
4342 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4343 (PerlIOBase(PerlIONext(f))->
4344 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4349 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4351 SSize_t avail = PerlIO_get_cnt(f);
4353 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4356 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4357 if (got >= 0 && got < (SSize_t)count) {
4358 const SSize_t more =
4359 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4360 if (more >= 0 || got == 0)
4366 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4367 sizeof(PerlIO_funcs),
4370 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4371 PerlIOPending_pushed,
4374 PerlIOBase_binmode, /* binmode */
4383 PerlIOPending_close,
4384 PerlIOPending_flush,
4388 PerlIOBase_clearerr,
4389 PerlIOBase_setlinebuf,
4394 PerlIOPending_set_ptrcnt,
4399 /*--------------------------------------------------------------------------------------*/
4401 * crlf - translation On read translate CR,LF to "\n" we do this by
4402 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4403 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4405 * c->nl points on the first byte of CR LF pair when it is temporarily
4406 * replaced by LF, or to the last CR of the buffer. In the former case
4407 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4408 * that it ends at c->nl; these two cases can be distinguished by
4409 * *c->nl. c->nl is set during _getcnt() call, and unset during
4410 * _unread() and _flush() calls.
4411 * It only matters for read operations.
4415 PerlIOBuf base; /* PerlIOBuf stuff */
4416 STDCHAR *nl; /* Position of crlf we "lied" about in the
4420 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4421 * Otherwise the :crlf layer would always revert back to
4425 S_inherit_utf8_flag(PerlIO *f)
4427 PerlIO *g = PerlIONext(f);
4428 if (PerlIOValid(g)) {
4429 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4430 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4436 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4439 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4440 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4442 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4443 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4444 PerlIOBase(f)->flags);
4447 /* If the old top layer is a CRLF layer, reactivate it (if
4448 * necessary) and remove this new layer from the stack */
4449 PerlIO *g = PerlIONext(f);
4450 if (PerlIOValid(g)) {
4451 PerlIOl *b = PerlIOBase(g);
4452 if (b && b->tab == &PerlIO_crlf) {
4453 if (!(b->flags & PERLIO_F_CRLF))
4454 b->flags |= PERLIO_F_CRLF;
4455 S_inherit_utf8_flag(g);
4456 PerlIO_pop(aTHX_ f);
4461 S_inherit_utf8_flag(f);
4467 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4469 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4470 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4471 *(c->nl) = NATIVE_0xd;
4474 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4475 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4477 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4478 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4480 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4485 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4486 b->end = b->ptr = b->buf + b->bufsiz;
4487 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4488 b->posn -= b->bufsiz;
4490 while (count > 0 && b->ptr > b->buf) {
4491 const int ch = *--buf;
4493 if (b->ptr - 2 >= b->buf) {
4494 *--(b->ptr) = NATIVE_0xa;
4495 *--(b->ptr) = NATIVE_0xd;
4500 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4501 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4515 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4520 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4522 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4524 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4527 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4528 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4529 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4530 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4532 while (nl < b->end && *nl != NATIVE_0xd)
4534 if (nl < b->end && *nl == NATIVE_0xd) {
4536 if (nl + 1 < b->end) {
4537 if (nl[1] == NATIVE_0xa) {
4543 * Not CR,LF but just CR
4551 * Blast - found CR as last char in buffer
4556 * They may not care, defer work as long as
4560 return (nl - b->ptr);
4564 b->ptr++; /* say we have read it as far as
4565 * flush() is concerned */
4566 b->buf++; /* Leave space in front of buffer */
4567 /* Note as we have moved buf up flush's
4569 will naturally make posn point at CR
4571 b->bufsiz--; /* Buffer is thus smaller */
4572 code = PerlIO_fill(f); /* Fetch some more */
4573 b->bufsiz++; /* Restore size for next time */
4574 b->buf--; /* Point at space */
4575 b->ptr = nl = b->buf; /* Which is what we hand
4577 *nl = NATIVE_0xd; /* Fill in the CR */
4579 goto test; /* fill() call worked */
4581 * CR at EOF - just fall through
4583 /* Should we clear EOF though ??? */
4588 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4594 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4596 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4597 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4603 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4604 /* Deferred CR at end of buffer case - we lied about count */
4617 * Test code - delete when it works ...
4619 IV flags = PerlIOBase(f)->flags;
4620 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4621 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4622 /* Deferred CR at end of buffer case - we lied about count */
4628 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4629 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4630 flags, c->nl, b->end, cnt);
4637 * They have taken what we lied about
4639 *(c->nl) = NATIVE_0xd;
4645 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4649 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4651 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4652 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4654 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4655 const STDCHAR *buf = (const STDCHAR *) vbuf;
4656 const STDCHAR * const ebuf = buf + count;
4659 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4661 while (buf < ebuf) {
4662 const STDCHAR * const eptr = b->buf + b->bufsiz;
4663 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4664 while (buf < ebuf && b->ptr < eptr) {
4666 if ((b->ptr + 2) > eptr) {
4674 *(b->ptr)++ = NATIVE_0xd; /* CR */
4675 *(b->ptr)++ = NATIVE_0xa; /* LF */
4677 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4684 *(b->ptr)++ = *buf++;
4686 if (b->ptr >= eptr) {
4692 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4694 return (buf - (STDCHAR *) vbuf);
4699 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4701 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4703 *(c->nl) = NATIVE_0xd;
4706 return PerlIOBuf_flush(aTHX_ f);
4710 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4712 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4713 /* In text mode - flush any pending stuff and flip it */
4714 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4715 #ifndef PERLIO_USING_CRLF
4716 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4717 PerlIO_pop(aTHX_ f);
4723 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4724 sizeof(PerlIO_funcs),
4727 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4729 PerlIOBuf_popped, /* popped */
4731 PerlIOCrlf_binmode, /* binmode */
4735 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4736 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4737 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4745 PerlIOBase_clearerr,
4746 PerlIOBase_setlinebuf,
4751 PerlIOCrlf_set_ptrcnt,
4755 Perl_PerlIO_stdin(pTHX)
4759 PerlIO_stdstreams(aTHX);
4761 return (PerlIO*)&PL_perlio[1];
4765 Perl_PerlIO_stdout(pTHX)
4769 PerlIO_stdstreams(aTHX);
4771 return (PerlIO*)&PL_perlio[2];
4775 Perl_PerlIO_stderr(pTHX)
4779 PerlIO_stdstreams(aTHX);
4781 return (PerlIO*)&PL_perlio[3];
4784 /*--------------------------------------------------------------------------------------*/
4787 PerlIO_getname(PerlIO *f, char *buf)
4792 bool exported = FALSE;
4793 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4795 stdio = PerlIO_exportFILE(f,0);
4799 name = fgetname(stdio, buf);
4800 if (exported) PerlIO_releaseFILE(f,stdio);
4805 PERL_UNUSED_ARG(buf);
4806 Perl_croak_nocontext("Don't know how to get file name");
4812 /*--------------------------------------------------------------------------------------*/
4814 * Functions which can be called on any kind of PerlIO implemented in
4818 #undef PerlIO_fdopen
4820 PerlIO_fdopen(int fd, const char *mode)
4823 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4828 PerlIO_open(const char *path, const char *mode)
4831 SV *name = sv_2mortal(newSVpv(path, 0));
4832 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4835 #undef Perlio_reopen
4837 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4840 SV *name = sv_2mortal(newSVpv(path,0));
4841 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4846 PerlIO_getc(PerlIO *f)
4850 if ( 1 == PerlIO_read(f, buf, 1) ) {
4851 return (unsigned char) buf[0];
4856 #undef PerlIO_ungetc
4858 PerlIO_ungetc(PerlIO *f, int ch)
4863 if (PerlIO_unread(f, &buf, 1) == 1)
4871 PerlIO_putc(PerlIO *f, int ch)
4875 return PerlIO_write(f, &buf, 1);
4880 PerlIO_puts(PerlIO *f, const char *s)
4883 return PerlIO_write(f, s, strlen(s));
4886 #undef PerlIO_rewind
4888 PerlIO_rewind(PerlIO *f)
4891 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4895 #undef PerlIO_vprintf
4897 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4906 Perl_va_copy(ap, apc);
4907 sv = vnewSVpvf(fmt, &apc);
4909 sv = vnewSVpvf(fmt, &ap);
4911 s = SvPV_const(sv, len);
4912 wrote = PerlIO_write(f, s, len);
4917 #undef PerlIO_printf
4919 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4924 result = PerlIO_vprintf(f, fmt, ap);
4929 #undef PerlIO_stdoutf
4931 PerlIO_stdoutf(const char *fmt, ...)
4937 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4942 #undef PerlIO_tmpfile
4944 PerlIO_tmpfile(void)
4951 const int fd = win32_tmpfd();
4953 f = PerlIO_fdopen(fd, "w+b");
4955 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4957 char tempname[] = "/tmp/PerlIO_XXXXXX";
4958 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
4961 * I have no idea how portable mkstemp() is ... NI-S
4963 if (tmpdir && *tmpdir) {
4964 /* if TMPDIR is set and not empty, we try that first */
4965 sv = newSVpv(tmpdir, 0);
4966 sv_catpv(sv, tempname + 4);
4967 fd = mkstemp(SvPVX(sv));
4971 /* else we try /tmp */
4972 fd = mkstemp(tempname);
4975 f = PerlIO_fdopen(fd, "w+");
4977 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4978 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
4981 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
4982 FILE * const stdio = PerlSIO_tmpfile();
4985 f = PerlIO_fdopen(fileno(stdio), "w+");
4987 # endif /* else HAS_MKSTEMP */
4988 #endif /* else WIN32 */
4995 #endif /* PERLIO_IS_STDIO */
4997 /*======================================================================================*/
4999 * Now some functions in terms of above which may be needed even if we are
5000 * not in true PerlIO mode
5003 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5006 const char *direction = NULL;
5009 * Need to supply default layer info from open.pm
5015 if (mode && mode[0] != 'r') {
5016 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5017 direction = "open>";
5019 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5020 direction = "open<";
5025 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5028 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5033 #undef PerlIO_setpos
5035 PerlIO_setpos(PerlIO *f, SV *pos)
5040 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5041 if (f && len == sizeof(Off_t))
5042 return PerlIO_seek(f, *posn, SEEK_SET);
5044 SETERRNO(EINVAL, SS_IVCHAN);
5048 #undef PerlIO_setpos
5050 PerlIO_setpos(PerlIO *f, SV *pos)
5055 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5056 if (f && len == sizeof(Fpos_t)) {
5057 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5058 return fsetpos64(f, fpos);
5060 return fsetpos(f, fpos);
5064 SETERRNO(EINVAL, SS_IVCHAN);
5070 #undef PerlIO_getpos
5072 PerlIO_getpos(PerlIO *f, SV *pos)
5075 Off_t posn = PerlIO_tell(f);
5076 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5077 return (posn == (Off_t) - 1) ? -1 : 0;
5080 #undef PerlIO_getpos
5082 PerlIO_getpos(PerlIO *f, SV *pos)
5087 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5088 code = fgetpos64(f, &fpos);
5090 code = fgetpos(f, &fpos);
5092 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5097 #if !defined(HAS_VPRINTF)
5100 vprintf(char *pat, char *args)
5102 _doprnt(pat, args, stdout);
5103 return 0; /* wrong, but perl doesn't use the return
5108 vfprintf(FILE *fd, char *pat, char *args)
5110 _doprnt(pat, args, fd);
5111 return 0; /* wrong, but perl doesn't use the return
5119 * c-indentation-style: bsd
5121 * indent-tabs-mode: nil
5124 * ex: set ts=8 sts=4 sw=4 et: