3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
17 /* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
28 #ifdef PERL_IMPLICIT_SYS
38 # ifndef USE_CROSS_COMPILE
45 #define PERLIO_NOT_STDIO 0
46 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
52 * This file provides those parts of PerlIO abstraction
53 * which are not #defined in perlio.h.
54 * Which these are depends on various Configure #ifdef's
58 #define PERL_IN_PERLIO_C
61 #ifdef PERL_IMPLICIT_CONTEXT
69 /* Missing proto on LynxOS */
77 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
79 /* Call the callback or PerlIOBase, and return failure. */
80 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
81 if (PerlIOValid(f)) { \
82 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
83 if (tab && tab->callback) \
84 return (*tab->callback) args; \
86 return PerlIOBase_ ## base args; \
89 SETERRNO(EBADF, SS_IVCHAN); \
92 /* Call the callback or fail, and return failure. */
93 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
94 if (PerlIOValid(f)) { \
95 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
96 if (tab && tab->callback) \
97 return (*tab->callback) args; \
98 SETERRNO(EINVAL, LIB_INVARG); \
101 SETERRNO(EBADF, SS_IVCHAN); \
104 /* Call the callback or PerlIOBase, and be void. */
105 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
106 if (PerlIOValid(f)) { \
107 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
108 if (tab && tab->callback) \
109 (*tab->callback) args; \
111 PerlIOBase_ ## base args; \
114 SETERRNO(EBADF, SS_IVCHAN)
116 /* Call the callback or fail, and be void. */
117 #define Perl_PerlIO_or_fail_void(f, callback, args) \
118 if (PerlIOValid(f)) { \
119 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
120 if (tab && tab->callback) \
121 (*tab->callback) args; \
123 SETERRNO(EINVAL, LIB_INVARG); \
126 SETERRNO(EBADF, SS_IVCHAN)
128 #if defined(__osf__) && _XOPEN_SOURCE < 500
129 extern int fseeko(FILE *, off_t, int);
130 extern off_t ftello(FILE *);
135 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
138 perlsio_binmode(FILE *fp, int iotype, int mode)
141 * This used to be contents of do_binmode in doio.c
144 # if defined(atarist)
145 PERL_UNUSED_ARG(iotype);
148 ((FILE *) fp)->_flag |= _IOBIN;
150 ((FILE *) fp)->_flag &= ~_IOBIN;
156 PERL_UNUSED_ARG(iotype);
158 if (PerlLIO_setmode(fp, mode) != -1) {
160 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
168 # if defined(USEMYBINMODE)
170 # if defined(__CYGWIN__)
171 PERL_UNUSED_ARG(iotype);
173 if (my_binmode(fp, iotype, mode) != FALSE)
179 PERL_UNUSED_ARG(iotype);
180 PERL_UNUSED_ARG(mode);
188 #define O_ACCMODE 3 /* Assume traditional implementation */
192 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
194 const int result = rawmode & O_ACCMODE;
199 ptype = IoTYPE_RDONLY;
202 ptype = IoTYPE_WRONLY;
210 *writing = (result != O_RDONLY);
212 if (result == O_RDONLY) {
216 else if (rawmode & O_APPEND) {
218 if (result != O_WRONLY)
223 if (result == O_WRONLY)
230 if (rawmode & O_BINARY)
236 #ifndef PERLIO_LAYERS
238 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
240 if (!names || !*names
241 || strEQ(names, ":crlf")
242 || strEQ(names, ":raw")
243 || strEQ(names, ":bytes")
247 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
255 PerlIO_destruct(pTHX)
260 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
263 PERL_UNUSED_ARG(iotype);
264 PERL_UNUSED_ARG(mode);
265 PERL_UNUSED_ARG(names);
268 return perlsio_binmode(fp, iotype, mode);
273 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
275 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
278 #ifdef PERL_IMPLICIT_SYS
279 return PerlSIO_fdupopen(f);
282 return win32_fdupopen(f);
285 const int fd = PerlLIO_dup(PerlIO_fileno(f));
289 const int omode = djgpp_get_stream_mode(f);
291 const int omode = fcntl(fd, F_GETFL);
293 PerlIO_intmode2str(omode,mode,NULL);
294 /* the r+ is a hack */
295 return PerlIO_fdopen(fd, mode);
300 SETERRNO(EBADF, SS_IVCHAN);
310 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
314 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
315 int imode, int perm, PerlIO *old, int narg, SV **args)
319 Perl_croak(aTHX_ "More than one argument to open");
321 if (*args == &PL_sv_undef)
322 return PerlIO_tmpfile();
324 const char *name = SvPV_nolen_const(*args);
325 if (*mode == IoTYPE_NUMERIC) {
326 fd = PerlLIO_open3(name, imode, perm);
328 return PerlIO_fdopen(fd, mode + 1);
331 return PerlIO_reopen(name, mode, old);
334 return PerlIO_open(name, mode);
339 return PerlIO_fdopen(fd, (char *) mode);
344 XS(XS_PerlIO__Layer__find)
348 Perl_croak(aTHX_ "Usage class->find(name[,load])");
350 const char * const name = SvPV_nolen_const(ST(1));
351 ST(0) = (strEQ(name, "crlf")
352 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
359 Perl_boot_core_PerlIO(pTHX)
361 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
367 #ifdef PERLIO_IS_STDIO
374 * Does nothing (yet) except force this file to be included in perl
375 * binary. That allows this file to force inclusion of other functions
376 * that may be required by loadable extensions e.g. for
377 * FileHandle::tmpfile
381 #undef PerlIO_tmpfile
388 #else /* PERLIO_IS_STDIO */
396 * This section is just to make sure these functions get pulled in from
400 #undef PerlIO_tmpfile
412 * Force this file to be included in perl binary. Which allows this
413 * file to force inclusion of other functions that may be required by
414 * loadable extensions e.g. for FileHandle::tmpfile
418 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
419 * results in a lot of lseek()s to regular files and lot of small
422 sfset(sfstdout, SF_SHARE, 0);
425 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
427 PerlIO_importFILE(FILE *stdio, const char *mode)
429 const int fd = fileno(stdio);
430 if (!mode || !*mode) {
433 return PerlIO_fdopen(fd, mode);
437 PerlIO_findFILE(PerlIO *pio)
439 const int fd = PerlIO_fileno(pio);
440 FILE * const f = fdopen(fd, "r+");
442 if (!f && errno == EINVAL)
444 if (!f && errno == EINVAL)
451 /*======================================================================================*/
453 * Implement all the PerlIO interface ourselves.
459 PerlIO_debug(const char *fmt, ...)
464 if (!PL_perlio_debug_fd) {
466 PerlProc_getuid() == PerlProc_geteuid() &&
467 PerlProc_getgid() == PerlProc_getegid()) {
468 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
471 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
473 PL_perlio_debug_fd = -1;
475 /* tainting or set*id, so ignore the environment, and ensure we
476 skip these tests next time through. */
477 PL_perlio_debug_fd = -1;
480 if (PL_perlio_debug_fd > 0) {
483 const char * const s = CopFILE(PL_curcop);
484 /* Use fixed buffer as sv_catpvf etc. needs SVs */
486 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
487 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
488 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
490 const char *s = CopFILE(PL_curcop);
492 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
493 (IV) CopLINE(PL_curcop));
494 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
496 s = SvPV_const(sv, len);
497 PerlLIO_write(PL_perlio_debug_fd, s, len);
504 /*--------------------------------------------------------------------------------------*/
507 * Inner level routines
510 /* check that the head field of each layer points back to the head */
513 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
515 PerlIO_verify_head(pTHX_ PerlIO *f)
521 p = head = PerlIOBase(f)->head;
524 assert(p->head == head);
525 if (p == (PerlIOl*)f)
532 # define VERIFY_HEAD(f)
537 * Table of pointers to the PerlIO structs (malloc'ed)
539 #define PERLIO_TABLE_SIZE 64
542 PerlIO_init_table(pTHX)
546 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
552 PerlIO_allocate(pTHX)
556 * Find a free slot in the table, allocating new table as necessary
561 while ((f = *last)) {
563 last = (PerlIOl **) (f);
564 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
565 if (!((++f)->next)) {
566 f->flags = 0; /* lockcnt */
573 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
577 *last = (PerlIOl*) f++;
578 f->flags = 0; /* lockcnt */
584 #undef PerlIO_fdupopen
586 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
588 if (PerlIOValid(f)) {
589 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
590 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
592 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
594 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
598 SETERRNO(EBADF, SS_IVCHAN);
604 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
606 PerlIOl * const table = *tablep;
609 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
610 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
611 PerlIOl * const f = table + i;
613 PerlIO_close(&(f->next));
623 PerlIO_list_alloc(pTHX)
627 Newxz(list, 1, PerlIO_list_t);
633 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
636 if (--list->refcnt == 0) {
639 for (i = 0; i < list->cur; i++)
640 SvREFCNT_dec(list->array[i].arg);
641 Safefree(list->array);
649 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
655 if (list->cur >= list->len) {
658 Renew(list->array, list->len, PerlIO_pair_t);
660 Newx(list->array, list->len, PerlIO_pair_t);
662 p = &(list->array[list->cur++]);
664 if ((p->arg = arg)) {
665 SvREFCNT_inc_simple_void_NN(arg);
670 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
672 PerlIO_list_t *list = NULL;
675 list = PerlIO_list_alloc(aTHX);
676 for (i=0; i < proto->cur; i++) {
677 SV *arg = proto->array[i].arg;
680 arg = sv_dup(arg, param);
682 PERL_UNUSED_ARG(param);
684 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
691 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
694 PerlIOl **table = &proto->Iperlio;
697 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
698 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
699 PerlIO_init_table(aTHX);
700 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
701 while ((f = *table)) {
703 table = (PerlIOl **) (f++);
704 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
706 (void) fp_dup(&(f->next), 0, param);
713 PERL_UNUSED_ARG(proto);
714 PERL_UNUSED_ARG(param);
719 PerlIO_destruct(pTHX)
722 PerlIOl **table = &PL_perlio;
725 PerlIO_debug("Destruct %p\n",(void*)aTHX);
727 while ((f = *table)) {
729 table = (PerlIOl **) (f++);
730 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
731 PerlIO *x = &(f->next);
734 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
735 PerlIO_debug("Destruct popping %s\n", l->tab->name);
749 PerlIO_pop(pTHX_ PerlIO *f)
751 const PerlIOl *l = *f;
754 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
755 l->tab ? l->tab->name : "(Null)");
756 if (l->tab && l->tab->Popped) {
758 * If popped returns non-zero do not free its layer structure
759 * it has either done so itself, or it is shared and still in
762 if ((*l->tab->Popped) (aTHX_ f) != 0)
765 if (PerlIO_lockcnt(f)) {
766 /* we're in use; defer freeing the structure */
767 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
768 PerlIOBase(f)->tab = NULL;
778 /* Return as an array the stack of layers on a filehandle. Note that
779 * the stack is returned top-first in the array, and there are three
780 * times as many array elements as there are layers in the stack: the
781 * first element of a layer triplet is the name, the second one is the
782 * arguments, and the third one is the flags. */
785 PerlIO_get_layers(pTHX_ PerlIO *f)
788 AV * const av = newAV();
790 if (PerlIOValid(f)) {
791 PerlIOl *l = PerlIOBase(f);
794 /* There is some collusion in the implementation of
795 XS_PerlIO_get_layers - it knows that name and flags are
796 generated as fresh SVs here, and takes advantage of that to
797 "copy" them by taking a reference. If it changes here, it needs
798 to change there too. */
799 SV * const name = l->tab && l->tab->name ?
800 newSVpv(l->tab->name, 0) : &PL_sv_undef;
801 SV * const arg = l->tab && l->tab->Getarg ?
802 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
805 av_push(av, newSViv((IV)l->flags));
813 /*--------------------------------------------------------------------------------------*/
815 * XS Interface for perl code
819 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
823 if ((SSize_t) len <= 0)
825 for (i = 0; i < PL_known_layers->cur; i++) {
826 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
827 if (memEQ(f->name, name, len) && f->name[len] == 0) {
828 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
832 if (load && PL_subname && PL_def_layerlist
833 && PL_def_layerlist->cur >= 2) {
834 if (PL_in_load_module) {
835 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
838 SV * const pkgsv = newSVpvs("PerlIO");
839 SV * const layer = newSVpvn(name, len);
840 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
842 SAVEBOOL(PL_in_load_module);
844 SAVEGENERICSV(PL_warnhook);
845 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
847 PL_in_load_module = TRUE;
849 * The two SVs are magically freed by load_module
851 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
853 return PerlIO_find_layer(aTHX_ name, len, 0);
856 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
860 #ifdef USE_ATTRIBUTES_FOR_PERLIO
863 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
866 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
867 PerlIO * const ifp = IoIFP(io);
868 PerlIO * const ofp = IoOFP(io);
869 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
870 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
876 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
879 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
880 PerlIO * const ifp = IoIFP(io);
881 PerlIO * const ofp = IoOFP(io);
882 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
883 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
889 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
891 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
896 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
898 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
902 MGVTBL perlio_vtab = {
910 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
913 SV * const sv = SvRV(ST(1));
914 AV * const av = newAV();
918 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
920 mg = mg_find(sv, PERL_MAGIC_ext);
921 mg->mg_virtual = &perlio_vtab;
923 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
924 for (i = 2; i < items; i++) {
926 const char * const name = SvPV_const(ST(i), len);
927 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
929 av_push(av, SvREFCNT_inc_simple_NN(layer));
940 #endif /* USE_ATTIBUTES_FOR_PERLIO */
943 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
945 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
946 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
950 XS(XS_PerlIO__Layer__NoWarnings)
952 /* This is used as a %SIG{__WARN__} handler to suppress warnings
953 during loading of layers.
959 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
963 XS(XS_PerlIO__Layer__find)
969 Perl_croak(aTHX_ "Usage class->find(name[,load])");
972 const char * const name = SvPV_const(ST(1), len);
973 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
974 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
976 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
983 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
986 if (!PL_known_layers)
987 PL_known_layers = PerlIO_list_alloc(aTHX);
988 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
989 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
993 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
997 const char *s = names;
999 while (isSPACE(*s) || *s == ':')
1004 const char *as = NULL;
1006 if (!isIDFIRST(*s)) {
1008 * Message is consistent with how attribute lists are
1009 * passed. Even though this means "foo : : bar" is
1010 * seen as an invalid separator character.
1012 const char q = ((*s == '\'') ? '"' : '\'');
1013 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1014 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1016 SETERRNO(EINVAL, LIB_INVARG);
1021 } while (isALNUM(*e));
1030 alen = (e - 1) - as;
1037 * It's a nul terminated string, not allowed
1038 * to \ the terminating null. Anything other
1039 * character is passed over.
1049 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1050 "Argument list not closed for PerlIO layer \"%.*s\"",
1062 PerlIO_funcs * const layer =
1063 PerlIO_find_layer(aTHX_ s, llen, 1);
1067 arg = newSVpvn(as, alen);
1068 PerlIO_list_push(aTHX_ av, layer,
1069 (arg) ? arg : &PL_sv_undef);
1073 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1086 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1089 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1090 #ifdef PERLIO_USING_CRLF
1093 if (PerlIO_stdio.Set_ptrcnt)
1094 tab = &PerlIO_stdio;
1096 PerlIO_debug("Pushing %s\n", tab->name);
1097 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1102 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1104 return av->array[n].arg;
1108 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1110 if (n >= 0 && n < av->cur) {
1111 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1112 av->array[n].funcs->name);
1113 return av->array[n].funcs;
1116 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1121 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1123 PERL_UNUSED_ARG(mode);
1124 PERL_UNUSED_ARG(arg);
1125 PERL_UNUSED_ARG(tab);
1126 if (PerlIOValid(f)) {
1128 PerlIO_pop(aTHX_ f);
1134 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1135 sizeof(PerlIO_funcs),
1138 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1158 NULL, /* get_base */
1159 NULL, /* get_bufsiz */
1162 NULL, /* set_ptrcnt */
1166 PerlIO_default_layers(pTHX)
1169 if (!PL_def_layerlist) {
1170 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1171 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1172 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1173 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1175 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1177 osLayer = &PerlIO_win32;
1180 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1181 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1182 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1183 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1184 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1185 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1186 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1187 PerlIO_list_push(aTHX_ PL_def_layerlist,
1188 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1191 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1194 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1197 if (PL_def_layerlist->cur < 2) {
1198 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1200 return PL_def_layerlist;
1204 Perl_boot_core_PerlIO(pTHX)
1206 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1207 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1210 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1211 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1215 PerlIO_default_layer(pTHX_ I32 n)
1218 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1221 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1224 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1225 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1228 PerlIO_stdstreams(pTHX)
1232 PerlIO_init_table(aTHX);
1233 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1234 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1235 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1240 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1243 if (tab->fsize != sizeof(PerlIO_funcs)) {
1245 "%s (%"UVuf") does not match %s (%"UVuf")",
1246 "PerlIO layer function table size", (UV)tab->fsize,
1247 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1251 if (tab->size < sizeof(PerlIOl)) {
1253 "%s (%"UVuf") smaller than %s (%"UVuf")",
1254 "PerlIO layer instance size", (UV)tab->size,
1255 "size expected by this perl", (UV)sizeof(PerlIOl) );
1257 /* Real layer with a data area */
1260 Newxz(temp, tab->size, char);
1264 l->tab = (PerlIO_funcs*) tab;
1265 l->head = ((PerlIOl*)f)->head;
1267 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1268 (void*)f, tab->name,
1269 (mode) ? mode : "(Null)", (void*)arg);
1270 if (*l->tab->Pushed &&
1272 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1273 PerlIO_pop(aTHX_ f);
1282 /* Pseudo-layer where push does its own stack adjust */
1283 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1284 (mode) ? mode : "(Null)", (void*)arg);
1286 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1294 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1295 IV n, const char *mode, int fd, int imode, int perm,
1296 PerlIO *old, int narg, SV **args)
1298 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1299 if (tab && tab->Open) {
1300 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1301 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1307 SETERRNO(EINVAL, LIB_INVARG);
1312 PerlIOBase_binmode(pTHX_ PerlIO *f)
1314 if (PerlIOValid(f)) {
1315 /* Is layer suitable for raw stream ? */
1316 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1317 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1318 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1321 /* Not suitable - pop it */
1322 PerlIO_pop(aTHX_ f);
1330 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1332 PERL_UNUSED_ARG(mode);
1333 PERL_UNUSED_ARG(arg);
1334 PERL_UNUSED_ARG(tab);
1336 if (PerlIOValid(f)) {
1341 * Strip all layers that are not suitable for a raw stream
1344 while (t && (l = *t)) {
1345 if (l->tab && l->tab->Binmode) {
1346 /* Has a handler - normal case */
1347 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1349 /* Layer still there - move down a layer */
1358 /* No handler - pop it */
1359 PerlIO_pop(aTHX_ t);
1362 if (PerlIOValid(f)) {
1363 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1364 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1372 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1373 PerlIO_list_t *layers, IV n, IV max)
1377 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1379 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1390 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1394 save_scalar(PL_errgv);
1396 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1397 code = PerlIO_parse_layers(aTHX_ layers, names);
1399 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1401 PerlIO_list_free(aTHX_ layers);
1408 /*--------------------------------------------------------------------------------------*/
1410 * Given the abstraction above the public API functions
1414 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1416 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1417 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1418 PerlIOBase(f)->tab->name : "(Null)",
1419 iotype, mode, (names) ? names : "(Null)");
1422 /* Do not flush etc. if (e.g.) switching encodings.
1423 if a pushed layer knows it needs to flush lower layers
1424 (for example :unix which is never going to call them)
1425 it can do the flush when it is pushed.
1427 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1430 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1431 #ifdef PERLIO_USING_CRLF
1432 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1433 O_BINARY so we can look for it in mode.
1435 if (!(mode & O_BINARY)) {
1437 /* FIXME?: Looking down the layer stack seems wrong,
1438 but is a way of reaching past (say) an encoding layer
1439 to flip CRLF-ness of the layer(s) below
1442 /* Perhaps we should turn on bottom-most aware layer
1443 e.g. Ilya's idea that UNIX TTY could serve
1445 if (PerlIOBase(f)->tab &&
1446 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1448 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1449 /* Not in text mode - flush any pending stuff and flip it */
1451 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1453 /* Only need to turn it on in one layer so we are done */
1458 /* Not finding a CRLF aware layer presumably means we are binary
1459 which is not what was requested - so we failed
1460 We _could_ push :crlf layer but so could caller
1465 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1466 So code that used to be here is now in PerlIORaw_pushed().
1468 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1473 PerlIO__close(pTHX_ PerlIO *f)
1475 if (PerlIOValid(f)) {
1476 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1477 if (tab && tab->Close)
1478 return (*tab->Close)(aTHX_ f);
1480 return PerlIOBase_close(aTHX_ f);
1483 SETERRNO(EBADF, SS_IVCHAN);
1489 Perl_PerlIO_close(pTHX_ PerlIO *f)
1491 const int code = PerlIO__close(aTHX_ f);
1492 while (PerlIOValid(f)) {
1493 PerlIO_pop(aTHX_ f);
1494 if (PerlIO_lockcnt(f))
1495 /* we're in use; the 'pop' deferred freeing the structure */
1502 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1505 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1509 static PerlIO_funcs *
1510 PerlIO_layer_from_ref(pTHX_ SV *sv)
1514 * For any scalar type load the handler which is bundled with perl
1516 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1517 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1518 /* This isn't supposed to happen, since PerlIO::scalar is core,
1519 * but could happen anyway in smaller installs or with PAR */
1521 /* diag_listed_as: Unknown PerlIO layer "%s" */
1522 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1527 * For other types allow if layer is known but don't try and load it
1529 switch (SvTYPE(sv)) {
1531 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1533 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1535 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1537 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1544 PerlIO_resolve_layers(pTHX_ const char *layers,
1545 const char *mode, int narg, SV **args)
1548 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1551 PerlIO_stdstreams(aTHX);
1553 SV * const arg = *args;
1555 * If it is a reference but not an object see if we have a handler
1558 if (SvROK(arg) && !sv_isobject(arg)) {
1559 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1561 def = PerlIO_list_alloc(aTHX);
1562 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1566 * Don't fail if handler cannot be found :via(...) etc. may do
1567 * something sensible else we will just stringfy and open
1572 if (!layers || !*layers)
1573 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1574 if (layers && *layers) {
1577 av = PerlIO_clone_list(aTHX_ def, NULL);
1582 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1586 PerlIO_list_free(aTHX_ av);
1598 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1599 int imode, int perm, PerlIO *f, int narg, SV **args)
1602 if (!f && narg == 1 && *args == &PL_sv_undef) {
1603 if ((f = PerlIO_tmpfile())) {
1604 if (!layers || !*layers)
1605 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1606 if (layers && *layers)
1607 PerlIO_apply_layers(aTHX_ f, mode, layers);
1611 PerlIO_list_t *layera;
1613 PerlIO_funcs *tab = NULL;
1614 if (PerlIOValid(f)) {
1616 * This is "reopen" - it is not tested as perl does not use it
1620 layera = PerlIO_list_alloc(aTHX);
1623 if (l->tab && l->tab->Getarg)
1624 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1625 PerlIO_list_push(aTHX_ layera, l->tab,
1626 (arg) ? arg : &PL_sv_undef);
1628 l = *PerlIONext(&l);
1632 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1638 * Start at "top" of layer stack
1640 n = layera->cur - 1;
1642 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1651 * Found that layer 'n' can do opens - call it
1653 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1654 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1656 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1657 tab->name, layers ? layers : "(Null)", mode, fd,
1658 imode, perm, (void*)f, narg, (void*)args);
1660 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1663 SETERRNO(EINVAL, LIB_INVARG);
1667 if (n + 1 < layera->cur) {
1669 * More layers above the one that we used to open -
1672 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1673 /* If pushing layers fails close the file */
1680 PerlIO_list_free(aTHX_ layera);
1687 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1689 PERL_ARGS_ASSERT_PERLIO_READ;
1691 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1695 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1697 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1699 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1703 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1705 PERL_ARGS_ASSERT_PERLIO_WRITE;
1707 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1711 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1713 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1717 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1719 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1723 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1728 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1730 if (tab && tab->Flush)
1731 return (*tab->Flush) (aTHX_ f);
1733 return 0; /* If no Flush defined, silently succeed. */
1736 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1737 SETERRNO(EBADF, SS_IVCHAN);
1743 * Is it good API design to do flush-all on NULL, a potentially
1744 * erroneous input? Maybe some magical value (PerlIO*
1745 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1746 * things on fflush(NULL), but should we be bound by their design
1749 PerlIOl **table = &PL_perlio;
1752 while ((ff = *table)) {
1754 table = (PerlIOl **) (ff++);
1755 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1756 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1766 PerlIOBase_flush_linebuf(pTHX)
1769 PerlIOl **table = &PL_perlio;
1771 while ((f = *table)) {
1773 table = (PerlIOl **) (f++);
1774 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1776 && (PerlIOBase(&(f->next))->
1777 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1778 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1779 PerlIO_flush(&(f->next));
1786 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1788 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1792 PerlIO_isutf8(PerlIO *f)
1795 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1797 SETERRNO(EBADF, SS_IVCHAN);
1803 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1805 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1809 Perl_PerlIO_error(pTHX_ PerlIO *f)
1811 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1815 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1817 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1821 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1823 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1827 PerlIO_has_base(PerlIO *f)
1829 if (PerlIOValid(f)) {
1830 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1833 return (tab->Get_base != NULL);
1840 PerlIO_fast_gets(PerlIO *f)
1842 if (PerlIOValid(f)) {
1843 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1844 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1847 return (tab->Set_ptrcnt != NULL);
1855 PerlIO_has_cntptr(PerlIO *f)
1857 if (PerlIOValid(f)) {
1858 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1861 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1868 PerlIO_canset_cnt(PerlIO *f)
1870 if (PerlIOValid(f)) {
1871 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1874 return (tab->Set_ptrcnt != NULL);
1881 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1883 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1887 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1889 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1893 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1895 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1899 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1901 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1905 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1907 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1911 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1913 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1917 /*--------------------------------------------------------------------------------------*/
1919 * utf8 and raw dummy layers
1923 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1925 PERL_UNUSED_CONTEXT;
1926 PERL_UNUSED_ARG(mode);
1927 PERL_UNUSED_ARG(arg);
1928 if (PerlIOValid(f)) {
1929 if (tab && tab->kind & PERLIO_K_UTF8)
1930 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1932 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1938 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1939 sizeof(PerlIO_funcs),
1942 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1962 NULL, /* get_base */
1963 NULL, /* get_bufsiz */
1966 NULL, /* set_ptrcnt */
1969 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1970 sizeof(PerlIO_funcs),
1973 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1993 NULL, /* get_base */
1994 NULL, /* get_bufsiz */
1997 NULL, /* set_ptrcnt */
2000 PERLIO_FUNCS_DECL(PerlIO_raw) = {
2001 sizeof(PerlIO_funcs),
2024 NULL, /* get_base */
2025 NULL, /* get_bufsiz */
2028 NULL, /* set_ptrcnt */
2030 /*--------------------------------------------------------------------------------------*/
2031 /*--------------------------------------------------------------------------------------*/
2033 * "Methods" of the "base class"
2037 PerlIOBase_fileno(pTHX_ PerlIO *f)
2039 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2043 PerlIO_modestr(PerlIO * f, char *buf)
2046 if (PerlIOValid(f)) {
2047 const IV flags = PerlIOBase(f)->flags;
2048 if (flags & PERLIO_F_APPEND) {
2050 if (flags & PERLIO_F_CANREAD) {
2054 else if (flags & PERLIO_F_CANREAD) {
2056 if (flags & PERLIO_F_CANWRITE)
2059 else if (flags & PERLIO_F_CANWRITE) {
2061 if (flags & PERLIO_F_CANREAD) {
2065 #ifdef PERLIO_USING_CRLF
2066 if (!(flags & PERLIO_F_CRLF))
2076 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2078 PerlIOl * const l = PerlIOBase(f);
2079 PERL_UNUSED_CONTEXT;
2080 PERL_UNUSED_ARG(arg);
2082 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2083 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2084 if (tab && tab->Set_ptrcnt != NULL)
2085 l->flags |= PERLIO_F_FASTGETS;
2087 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2091 l->flags |= PERLIO_F_CANREAD;
2094 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2097 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2100 SETERRNO(EINVAL, LIB_INVARG);
2106 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2109 l->flags &= ~PERLIO_F_CRLF;
2112 l->flags |= PERLIO_F_CRLF;
2115 SETERRNO(EINVAL, LIB_INVARG);
2122 l->flags |= l->next->flags &
2123 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2128 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2129 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2130 l->flags, PerlIO_modestr(f, temp));
2136 PerlIOBase_popped(pTHX_ PerlIO *f)
2138 PERL_UNUSED_CONTEXT;
2144 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2147 * Save the position as current head considers it
2149 const Off_t old = PerlIO_tell(f);
2150 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2151 PerlIOSelf(f, PerlIOBuf)->posn = old;
2152 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2156 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2158 STDCHAR *buf = (STDCHAR *) vbuf;
2160 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2161 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2162 SETERRNO(EBADF, SS_IVCHAN);
2168 SSize_t avail = PerlIO_get_cnt(f);
2171 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2173 STDCHAR *ptr = PerlIO_get_ptr(f);
2174 Copy(ptr, buf, take, STDCHAR);
2175 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2178 if (avail == 0) /* set_ptrcnt could have reset avail */
2181 if (count > 0 && avail <= 0) {
2182 if (PerlIO_fill(f) != 0)
2187 return (buf - (STDCHAR *) vbuf);
2193 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2195 PERL_UNUSED_CONTEXT;
2201 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2203 PERL_UNUSED_CONTEXT;
2209 PerlIOBase_close(pTHX_ PerlIO *f)
2212 if (PerlIOValid(f)) {
2213 PerlIO *n = PerlIONext(f);
2214 code = PerlIO_flush(f);
2215 PerlIOBase(f)->flags &=
2216 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2217 while (PerlIOValid(n)) {
2218 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2219 if (tab && tab->Close) {
2220 if ((*tab->Close)(aTHX_ n) != 0)
2225 PerlIOBase(n)->flags &=
2226 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2232 SETERRNO(EBADF, SS_IVCHAN);
2238 PerlIOBase_eof(pTHX_ PerlIO *f)
2240 PERL_UNUSED_CONTEXT;
2241 if (PerlIOValid(f)) {
2242 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2248 PerlIOBase_error(pTHX_ PerlIO *f)
2250 PERL_UNUSED_CONTEXT;
2251 if (PerlIOValid(f)) {
2252 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2258 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2260 if (PerlIOValid(f)) {
2261 PerlIO * const n = PerlIONext(f);
2262 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2269 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2271 PERL_UNUSED_CONTEXT;
2272 if (PerlIOValid(f)) {
2273 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2278 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2284 arg = sv_dup(arg, param);
2285 SvREFCNT_inc_simple_void_NN(arg);
2289 return newSVsv(arg);
2292 PERL_UNUSED_ARG(param);
2293 return newSVsv(arg);
2298 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2300 PerlIO * const nexto = PerlIONext(o);
2301 if (PerlIOValid(nexto)) {
2302 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2303 if (tab && tab->Dup)
2304 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2306 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2309 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2312 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2313 self ? self->name : "(Null)",
2314 (void*)f, (void*)o, (void*)param);
2315 if (self && self->Getarg)
2316 arg = (*self->Getarg)(aTHX_ o, param, flags);
2317 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2318 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2319 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2325 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2327 /* Must be called with PL_perlio_mutex locked. */
2329 S_more_refcounted_fds(pTHX_ const int new_fd) {
2331 const int old_max = PL_perlio_fd_refcnt_size;
2332 const int new_max = 16 + (new_fd & ~15);
2335 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2336 old_max, new_fd, new_max);
2338 if (new_fd < old_max) {
2342 assert (new_max > new_fd);
2344 /* Use plain realloc() since we need this memory to be really
2345 * global and visible to all the interpreters and/or threads. */
2346 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2350 MUTEX_UNLOCK(&PL_perlio_mutex);
2352 /* Can't use PerlIO to write as it allocates memory */
2353 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2354 PL_no_mem, strlen(PL_no_mem));
2358 PL_perlio_fd_refcnt_size = new_max;
2359 PL_perlio_fd_refcnt = new_array;
2361 PerlIO_debug("Zeroing %p, %d\n",
2362 (void*)(new_array + old_max),
2365 Zero(new_array + old_max, new_max - old_max, int);
2372 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2373 PERL_UNUSED_CONTEXT;
2377 PerlIOUnix_refcnt_inc(int fd)
2384 MUTEX_LOCK(&PL_perlio_mutex);
2386 if (fd >= PL_perlio_fd_refcnt_size)
2387 S_more_refcounted_fds(aTHX_ fd);
2389 PL_perlio_fd_refcnt[fd]++;
2390 if (PL_perlio_fd_refcnt[fd] <= 0) {
2391 /* diag_listed_as: refcnt_inc: fd %d%s */
2392 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2393 fd, PL_perlio_fd_refcnt[fd]);
2395 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2396 fd, PL_perlio_fd_refcnt[fd]);
2399 MUTEX_UNLOCK(&PL_perlio_mutex);
2402 /* diag_listed_as: refcnt_inc: fd %d%s */
2403 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2408 PerlIOUnix_refcnt_dec(int fd)
2415 MUTEX_LOCK(&PL_perlio_mutex);
2417 if (fd >= PL_perlio_fd_refcnt_size) {
2418 /* diag_listed_as: refcnt_dec: fd %d%s */
2419 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2420 fd, PL_perlio_fd_refcnt_size);
2422 if (PL_perlio_fd_refcnt[fd] <= 0) {
2423 /* diag_listed_as: refcnt_dec: fd %d%s */
2424 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2425 fd, PL_perlio_fd_refcnt[fd]);
2427 cnt = --PL_perlio_fd_refcnt[fd];
2428 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2430 MUTEX_UNLOCK(&PL_perlio_mutex);
2433 /* diag_listed_as: refcnt_dec: fd %d%s */
2434 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2440 PerlIOUnix_refcnt(int fd)
2447 MUTEX_LOCK(&PL_perlio_mutex);
2449 if (fd >= PL_perlio_fd_refcnt_size) {
2450 /* diag_listed_as: refcnt: fd %d%s */
2451 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2452 fd, PL_perlio_fd_refcnt_size);
2454 if (PL_perlio_fd_refcnt[fd] <= 0) {
2455 /* diag_listed_as: refcnt: fd %d%s */
2456 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2457 fd, PL_perlio_fd_refcnt[fd]);
2459 cnt = PL_perlio_fd_refcnt[fd];
2461 MUTEX_UNLOCK(&PL_perlio_mutex);
2464 /* diag_listed_as: refcnt: fd %d%s */
2465 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2471 PerlIO_cleanup(pTHX)
2476 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2478 PerlIO_debug("Cleanup layers\n");
2481 /* Raise STDIN..STDERR refcount so we don't close them */
2482 for (i=0; i < 3; i++)
2483 PerlIOUnix_refcnt_inc(i);
2484 PerlIO_cleantable(aTHX_ &PL_perlio);
2485 /* Restore STDIN..STDERR refcount */
2486 for (i=0; i < 3; i++)
2487 PerlIOUnix_refcnt_dec(i);
2489 if (PL_known_layers) {
2490 PerlIO_list_free(aTHX_ PL_known_layers);
2491 PL_known_layers = NULL;
2493 if (PL_def_layerlist) {
2494 PerlIO_list_free(aTHX_ PL_def_layerlist);
2495 PL_def_layerlist = NULL;
2499 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2503 /* XXX we can't rely on an interpreter being present at this late stage,
2504 XXX so we can't use a function like PerlLIO_write that relies on one
2505 being present (at least in win32) :-(.
2510 /* By now all filehandles should have been closed, so any
2511 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2513 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2514 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2515 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2517 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2518 if (PL_perlio_fd_refcnt[i]) {
2520 my_snprintf(buf, sizeof(buf),
2521 "PerlIO_teardown: fd %d refcnt=%d\n",
2522 i, PL_perlio_fd_refcnt[i]);
2523 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2529 /* Not bothering with PL_perlio_mutex since by now
2530 * all the interpreters are gone. */
2531 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2532 && PL_perlio_fd_refcnt) {
2533 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2534 PL_perlio_fd_refcnt = NULL;
2535 PL_perlio_fd_refcnt_size = 0;
2539 /*--------------------------------------------------------------------------------------*/
2541 * Bottom-most level for UNIX-like case
2545 struct _PerlIO base; /* The generic part */
2546 int fd; /* UNIX like file descriptor */
2547 int oflags; /* open/fcntl flags */
2551 S_lockcnt_dec(pTHX_ const void* f)
2553 PerlIO_lockcnt((PerlIO*)f)--;
2557 /* call the signal handler, and if that handler happens to clear
2558 * this handle, free what we can and return true */
2561 S_perlio_async_run(pTHX_ PerlIO* f) {
2563 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2564 PerlIO_lockcnt(f)++;
2566 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2570 /* we've just run some perl-level code that could have done
2571 * anything, including closing the file or clearing this layer.
2572 * If so, free any lower layers that have already been
2573 * cleared, then return an error. */
2574 while (PerlIOValid(f) &&
2575 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2577 const PerlIOl *l = *f;
2586 PerlIOUnix_oflags(const char *mode)
2589 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2594 if (*++mode == '+') {
2601 oflags = O_CREAT | O_TRUNC;
2602 if (*++mode == '+') {
2611 oflags = O_CREAT | O_APPEND;
2612 if (*++mode == '+') {
2625 else if (*mode == 't') {
2627 oflags &= ~O_BINARY;
2631 * Always open in binary mode
2634 if (*mode || oflags == -1) {
2635 SETERRNO(EINVAL, LIB_INVARG);
2642 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2644 PERL_UNUSED_CONTEXT;
2645 return PerlIOSelf(f, PerlIOUnix)->fd;
2649 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2651 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2654 if (PerlLIO_fstat(fd, &st) == 0) {
2655 if (!S_ISREG(st.st_mode)) {
2656 PerlIO_debug("%d is not regular file\n",fd);
2657 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2660 PerlIO_debug("%d _is_ a regular file\n",fd);
2666 PerlIOUnix_refcnt_inc(fd);
2667 PERL_UNUSED_CONTEXT;
2671 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2673 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2674 if (*PerlIONext(f)) {
2675 /* We never call down so do any pending stuff now */
2676 PerlIO_flush(PerlIONext(f));
2678 * XXX could (or should) we retrieve the oflags from the open file
2679 * handle rather than believing the "mode" we are passed in? XXX
2680 * Should the value on NULL mode be 0 or -1?
2682 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2683 mode ? PerlIOUnix_oflags(mode) : -1);
2685 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2691 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2693 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2695 PERL_UNUSED_CONTEXT;
2696 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2698 SETERRNO(ESPIPE, LIB_INVARG);
2700 SETERRNO(EINVAL, LIB_INVARG);
2704 new_loc = PerlLIO_lseek(fd, offset, whence);
2705 if (new_loc == (Off_t) - 1)
2707 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2712 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2713 IV n, const char *mode, int fd, int imode,
2714 int perm, PerlIO *f, int narg, SV **args)
2716 if (PerlIOValid(f)) {
2717 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2718 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2721 if (*mode == IoTYPE_NUMERIC)
2724 imode = PerlIOUnix_oflags(mode);
2726 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2732 const char *path = SvPV_nolen_const(*args);
2733 fd = PerlLIO_open3(path, imode, perm);
2737 if (*mode == IoTYPE_IMPLICIT)
2740 f = PerlIO_allocate(aTHX);
2742 if (!PerlIOValid(f)) {
2743 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2747 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2748 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2749 if (*mode == IoTYPE_APPEND)
2750 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2757 * FIXME: pop layers ???
2765 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2767 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2769 if (flags & PERLIO_DUP_FD) {
2770 fd = PerlLIO_dup(fd);
2773 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2775 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2776 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2785 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2789 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2791 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2792 #ifdef PERLIO_STD_SPECIAL
2794 return PERLIO_STD_IN(fd, vbuf, count);
2796 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2797 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2801 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2802 if (len >= 0 || errno != EINTR) {
2804 if (errno != EAGAIN) {
2805 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2808 else if (len == 0 && count != 0) {
2809 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2815 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2822 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2826 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2828 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2829 #ifdef PERLIO_STD_SPECIAL
2830 if (fd == 1 || fd == 2)
2831 return PERLIO_STD_OUT(fd, vbuf, count);
2834 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2835 if (len >= 0 || errno != EINTR) {
2837 if (errno != EAGAIN) {
2838 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2844 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2851 PerlIOUnix_tell(pTHX_ PerlIO *f)
2853 PERL_UNUSED_CONTEXT;
2855 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2860 PerlIOUnix_close(pTHX_ PerlIO *f)
2863 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2865 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2866 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2867 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2872 SETERRNO(EBADF,SS_IVCHAN);
2875 while (PerlLIO_close(fd) != 0) {
2876 if (errno != EINTR) {
2881 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2885 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2890 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2891 sizeof(PerlIO_funcs),
2898 PerlIOBase_binmode, /* binmode */
2908 PerlIOBase_noop_ok, /* flush */
2909 PerlIOBase_noop_fail, /* fill */
2912 PerlIOBase_clearerr,
2913 PerlIOBase_setlinebuf,
2914 NULL, /* get_base */
2915 NULL, /* get_bufsiz */
2918 NULL, /* set_ptrcnt */
2921 /*--------------------------------------------------------------------------------------*/
2926 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2927 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2928 broken by the last second glibc 2.3 fix
2930 #define STDIO_BUFFER_WRITABLE
2935 struct _PerlIO base;
2936 FILE *stdio; /* The stream */
2940 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2942 PERL_UNUSED_CONTEXT;
2944 if (PerlIOValid(f)) {
2945 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2947 return PerlSIO_fileno(s);
2954 PerlIOStdio_mode(const char *mode, char *tmode)
2956 char * const ret = tmode;
2962 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2970 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2973 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2974 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2975 if (toptab == tab) {
2976 /* Top is already stdio - pop self (duplicate) and use original */
2977 PerlIO_pop(aTHX_ f);
2980 const int fd = PerlIO_fileno(n);
2983 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2984 mode = PerlIOStdio_mode(mode, tmode)))) {
2985 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2986 /* We never call down so do any pending stuff now */
2987 PerlIO_flush(PerlIONext(f));
2994 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2999 PerlIO_importFILE(FILE *stdio, const char *mode)
3005 if (!mode || !*mode) {
3006 /* We need to probe to see how we can open the stream
3007 so start with read/write and then try write and read
3008 we dup() so that we can fclose without loosing the fd.
3010 Note that the errno value set by a failing fdopen
3011 varies between stdio implementations.
3013 const int fd = PerlLIO_dup(fileno(stdio));
3014 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3016 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3019 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3022 /* Don't seem to be able to open */
3028 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3029 s = PerlIOSelf(f, PerlIOStdio);
3031 PerlIOUnix_refcnt_inc(fileno(stdio));
3038 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3039 IV n, const char *mode, int fd, int imode,
3040 int perm, PerlIO *f, int narg, SV **args)
3043 if (PerlIOValid(f)) {
3044 const char * const path = SvPV_nolen_const(*args);
3045 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3047 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3048 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3053 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3058 const char * const path = SvPV_nolen_const(*args);
3059 if (*mode == IoTYPE_NUMERIC) {
3061 fd = PerlLIO_open3(path, imode, perm);
3065 bool appended = FALSE;
3067 /* Cygwin wants its 'b' early. */
3069 mode = PerlIOStdio_mode(mode, tmode);
3071 stdio = PerlSIO_fopen(path, mode);
3074 f = PerlIO_allocate(aTHX);
3077 mode = PerlIOStdio_mode(mode, tmode);
3078 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3080 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3081 PerlIOUnix_refcnt_inc(fileno(stdio));
3083 PerlSIO_fclose(stdio);
3095 if (*mode == IoTYPE_IMPLICIT) {
3102 stdio = PerlSIO_stdin;
3105 stdio = PerlSIO_stdout;
3108 stdio = PerlSIO_stderr;
3113 stdio = PerlSIO_fdopen(fd, mode =
3114 PerlIOStdio_mode(mode, tmode));
3118 f = PerlIO_allocate(aTHX);
3120 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3121 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3122 PerlIOUnix_refcnt_inc(fileno(stdio));
3132 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3134 /* This assumes no layers underneath - which is what
3135 happens, but is not how I remember it. NI-S 2001/10/16
3137 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3138 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3139 const int fd = fileno(stdio);
3141 if (flags & PERLIO_DUP_FD) {
3142 const int dfd = PerlLIO_dup(fileno(stdio));
3144 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3149 /* FIXME: To avoid messy error recovery if dup fails
3150 re-use the existing stdio as though flag was not set
3154 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3156 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3158 PerlIOUnix_refcnt_inc(fileno(stdio));
3165 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3167 PERL_UNUSED_CONTEXT;
3169 /* XXX this could use PerlIO_canset_fileno() and
3170 * PerlIO_set_fileno() support from Configure
3172 # if defined(__UCLIBC__)
3173 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3176 # elif defined(__GLIBC__)
3177 /* There may be a better way for GLIBC:
3178 - libio.h defines a flag to not close() on cleanup
3182 # elif defined(__sun__)
3185 # elif defined(__hpux)
3189 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3190 your platform does not have special entry try this one.
3191 [For OSF only have confirmation for Tru64 (alpha)
3192 but assume other OSFs will be similar.]
3194 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3197 # elif defined(__FreeBSD__)
3198 /* There may be a better way on FreeBSD:
3199 - we could insert a dummy func in the _close function entry
3200 f->_close = (int (*)(void *)) dummy_close;
3204 # elif defined(__OpenBSD__)
3205 /* There may be a better way on OpenBSD:
3206 - we could insert a dummy func in the _close function entry
3207 f->_close = (int (*)(void *)) dummy_close;
3211 # elif defined(__EMX__)
3212 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3215 # elif defined(__CYGWIN__)
3216 /* There may be a better way on CYGWIN:
3217 - we could insert a dummy func in the _close function entry
3218 f->_close = (int (*)(void *)) dummy_close;
3222 # elif defined(WIN32)
3223 # if defined(UNDER_CE)
3224 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3233 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3234 (which isn't thread safe) instead
3236 # error "Don't know how to set FILE.fileno on your platform"
3244 PerlIOStdio_close(pTHX_ PerlIO *f)
3246 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3252 const int fd = fileno(stdio);
3260 #ifdef SOCKS5_VERSION_NAME
3261 /* Socks lib overrides close() but stdio isn't linked to
3262 that library (though we are) - so we must call close()
3263 on sockets on stdio's behalf.
3266 Sock_size_t optlen = sizeof(int);
3267 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3270 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3271 that a subsequent fileno() on it returns -1. Don't want to croak()
3272 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3273 trying to close an already closed handle which somehow it still has
3274 a reference to. (via.xs, I'm looking at you). */
3275 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3276 /* File descriptor still in use */
3280 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3281 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3283 if (stdio == stdout || stdio == stderr)
3284 return PerlIO_flush(f);
3285 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3286 Use Sarathy's trick from maint-5.6 to invalidate the
3287 fileno slot of the FILE *
3289 result = PerlIO_flush(f);
3291 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3294 MUTEX_LOCK(&PL_perlio_mutex);
3295 /* Right. We need a mutex here because for a brief while we
3296 will have the situation that fd is actually closed. Hence if
3297 a second thread were to get into this block, its dup() would
3298 likely return our fd as its dupfd. (after all, it is closed)
3299 Then if we get to the dup2() first, we blat the fd back
3300 (messing up its temporary as a side effect) only for it to
3301 then close its dupfd (== our fd) in its close(dupfd) */
3303 /* There is, of course, a race condition, that any other thread
3304 trying to input/output/whatever on this fd will be stuffed
3305 for the duration of this little manoeuvrer. Perhaps we
3306 should hold an IO mutex for the duration of every IO
3307 operation if we know that invalidate doesn't work on this
3308 platform, but that would suck, and could kill performance.
3310 Except that correctness trumps speed.
3311 Advice from klortho #11912. */
3313 dupfd = PerlLIO_dup(fd);
3316 MUTEX_UNLOCK(&PL_perlio_mutex);
3317 /* Oh cXap. This isn't going to go well. Not sure if we can
3318 recover from here, or if closing this particular FILE *
3319 is a good idea now. */
3324 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3326 result = PerlSIO_fclose(stdio);
3327 /* We treat error from stdio as success if we invalidated
3328 errno may NOT be expected EBADF
3330 if (invalidate && result != 0) {
3334 #ifdef SOCKS5_VERSION_NAME
3335 /* in SOCKS' case, let close() determine return value */
3339 PerlLIO_dup2(dupfd,fd);
3340 PerlLIO_close(dupfd);
3342 MUTEX_UNLOCK(&PL_perlio_mutex);
3350 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3355 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3357 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3360 STDCHAR *buf = (STDCHAR *) vbuf;
3362 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3363 * stdio does not do that for fread()
3365 const int ch = PerlSIO_fgetc(s);
3372 got = PerlSIO_fread(vbuf, 1, count, s);
3373 if (got == 0 && PerlSIO_ferror(s))
3375 if (got >= 0 || errno != EINTR)
3377 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3379 SETERRNO(0,0); /* just in case */
3385 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3388 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3390 #ifdef STDIO_BUFFER_WRITABLE
3391 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3392 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3393 STDCHAR *base = PerlIO_get_base(f);
3394 SSize_t cnt = PerlIO_get_cnt(f);
3395 STDCHAR *ptr = PerlIO_get_ptr(f);
3396 SSize_t avail = ptr - base;
3398 if (avail > count) {
3402 Move(buf-avail,ptr,avail,STDCHAR);
3405 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3406 if (PerlSIO_feof(s) && unread >= 0)
3407 PerlSIO_clearerr(s);
3412 if (PerlIO_has_cntptr(f)) {
3413 /* We can get pointer to buffer but not its base
3414 Do ungetc() but check chars are ending up in the
3417 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3418 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3420 const int ch = *--buf & 0xFF;
3421 if (ungetc(ch,s) != ch) {
3422 /* ungetc did not work */
3425 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3426 /* Did not change pointer as expected */
3427 fgetc(s); /* get char back again */
3437 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3443 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3447 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3450 got = PerlSIO_fwrite(vbuf, 1, count,
3451 PerlIOSelf(f, PerlIOStdio)->stdio);
3452 if (got >= 0 || errno != EINTR)
3454 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3456 SETERRNO(0,0); /* just in case */
3462 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3464 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3465 PERL_UNUSED_CONTEXT;
3467 return PerlSIO_fseek(stdio, offset, whence);
3471 PerlIOStdio_tell(pTHX_ PerlIO *f)
3473 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3474 PERL_UNUSED_CONTEXT;
3476 return PerlSIO_ftell(stdio);
3480 PerlIOStdio_flush(pTHX_ PerlIO *f)
3482 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3483 PERL_UNUSED_CONTEXT;
3485 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3486 return PerlSIO_fflush(stdio);
3492 * FIXME: This discards ungetc() and pre-read stuff which is not
3493 * right if this is just a "sync" from a layer above Suspect right
3494 * design is to do _this_ but not have layer above flush this
3495 * layer read-to-read
3498 * Not writeable - sync by attempting a seek
3501 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3509 PerlIOStdio_eof(pTHX_ PerlIO *f)
3511 PERL_UNUSED_CONTEXT;
3513 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3517 PerlIOStdio_error(pTHX_ PerlIO *f)
3519 PERL_UNUSED_CONTEXT;
3521 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3525 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3527 PERL_UNUSED_CONTEXT;
3529 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3533 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3535 PERL_UNUSED_CONTEXT;
3537 #ifdef HAS_SETLINEBUF
3538 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3540 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3546 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3548 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3549 return (STDCHAR*)PerlSIO_get_base(stdio);
3553 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3555 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3556 return PerlSIO_get_bufsiz(stdio);
3560 #ifdef USE_STDIO_PTR
3562 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3564 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3565 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3569 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3571 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3572 return PerlSIO_get_cnt(stdio);
3576 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3578 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3580 #ifdef STDIO_PTR_LVALUE
3581 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3582 #ifdef STDIO_PTR_LVAL_SETS_CNT
3583 assert(PerlSIO_get_cnt(stdio) == (cnt));
3585 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3587 * Setting ptr _does_ change cnt - we are done
3591 #else /* STDIO_PTR_LVALUE */
3593 #endif /* STDIO_PTR_LVALUE */
3596 * Now (or only) set cnt
3598 #ifdef STDIO_CNT_LVALUE
3599 PerlSIO_set_cnt(stdio, cnt);
3600 #else /* STDIO_CNT_LVALUE */
3601 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3602 PerlSIO_set_ptr(stdio,
3603 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3605 #else /* STDIO_PTR_LVAL_SETS_CNT */
3607 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3608 #endif /* STDIO_CNT_LVALUE */
3615 PerlIOStdio_fill(pTHX_ PerlIO *f)
3619 PERL_UNUSED_CONTEXT;
3620 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3622 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3625 * fflush()ing read-only streams can cause trouble on some stdio-s
3627 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3628 if (PerlSIO_fflush(stdio) != 0)
3632 c = PerlSIO_fgetc(stdio);
3635 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3637 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3642 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3644 #ifdef STDIO_BUFFER_WRITABLE
3645 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3646 /* Fake ungetc() to the real buffer in case system's ungetc
3649 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3650 SSize_t cnt = PerlSIO_get_cnt(stdio);
3651 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3652 if (ptr == base+1) {
3653 *--ptr = (STDCHAR) c;
3654 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3655 if (PerlSIO_feof(stdio))
3656 PerlSIO_clearerr(stdio);
3662 if (PerlIO_has_cntptr(f)) {
3664 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3671 /* An ungetc()d char is handled separately from the regular
3672 * buffer, so we stuff it in the buffer ourselves.
3673 * Should never get called as should hit code above
3675 *(--((*stdio)->_ptr)) = (unsigned char) c;
3678 /* If buffer snoop scheme above fails fall back to
3681 if (PerlSIO_ungetc(c, stdio) != c)
3689 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3690 sizeof(PerlIO_funcs),
3692 sizeof(PerlIOStdio),
3693 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3697 PerlIOBase_binmode, /* binmode */
3711 PerlIOStdio_clearerr,
3712 PerlIOStdio_setlinebuf,
3714 PerlIOStdio_get_base,
3715 PerlIOStdio_get_bufsiz,
3720 #ifdef USE_STDIO_PTR
3721 PerlIOStdio_get_ptr,
3722 PerlIOStdio_get_cnt,
3723 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3724 PerlIOStdio_set_ptrcnt,
3727 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3732 #endif /* USE_STDIO_PTR */
3735 /* Note that calls to PerlIO_exportFILE() are reversed using
3736 * PerlIO_releaseFILE(), not importFILE. */
3738 PerlIO_exportFILE(PerlIO * f, const char *mode)
3742 if (PerlIOValid(f)) {
3745 if (!mode || !*mode) {
3746 mode = PerlIO_modestr(f, buf);
3748 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3752 /* De-link any lower layers so new :stdio sticks */
3754 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3755 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3757 PerlIOUnix_refcnt_inc(fileno(stdio));
3758 /* Link previous lower layers under new one */
3762 /* restore layers list */
3772 PerlIO_findFILE(PerlIO *f)
3777 if (l->tab == &PerlIO_stdio) {
3778 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3781 l = *PerlIONext(&l);
3783 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3784 /* However, we're not really exporting a FILE * to someone else (who
3785 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3786 So we need to undo its reference count increase on the underlying file
3787 descriptor. We have to do this, because if the loop above returns you
3788 the FILE *, then *it* didn't increase any reference count. So there's
3789 only one way to be consistent. */
3790 stdio = PerlIO_exportFILE(f, NULL);
3792 const int fd = fileno(stdio);
3794 PerlIOUnix_refcnt_dec(fd);
3799 /* Use this to reverse PerlIO_exportFILE calls. */
3801 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3806 if (l->tab == &PerlIO_stdio) {
3807 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3808 if (s->stdio == f) {
3810 const int fd = fileno(f);
3812 PerlIOUnix_refcnt_dec(fd);
3813 PerlIO_pop(aTHX_ p);
3822 /*--------------------------------------------------------------------------------------*/
3824 * perlio buffer layer
3828 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3830 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3831 const int fd = PerlIO_fileno(f);
3832 if (fd >= 0 && PerlLIO_isatty(fd)) {
3833 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3835 if (*PerlIONext(f)) {
3836 const Off_t posn = PerlIO_tell(PerlIONext(f));
3837 if (posn != (Off_t) - 1) {
3841 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3845 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3846 IV n, const char *mode, int fd, int imode, int perm,
3847 PerlIO *f, int narg, SV **args)
3849 if (PerlIOValid(f)) {
3850 PerlIO *next = PerlIONext(f);
3852 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3853 if (tab && tab->Open)
3855 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3857 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3862 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3864 if (*mode == IoTYPE_IMPLICIT) {
3870 if (tab && tab->Open)
3871 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3874 SETERRNO(EINVAL, LIB_INVARG);
3876 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3878 * if push fails during open, open fails. close will pop us.
3883 fd = PerlIO_fileno(f);
3884 if (init && fd == 2) {
3886 * Initial stderr is unbuffered
3888 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3890 #ifdef PERLIO_USING_CRLF
3891 # ifdef PERLIO_IS_BINMODE_FD
3892 if (PERLIO_IS_BINMODE_FD(fd))
3893 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3897 * do something about failing setmode()? --jhi
3899 PerlLIO_setmode(fd, O_BINARY);
3902 /* Enable line buffering with record-oriented regular files
3903 * so we don't introduce an extraneous record boundary when
3904 * the buffer fills up.
3906 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3908 if (PerlLIO_fstat(fd, &st) == 0
3909 && S_ISREG(st.st_mode)
3910 && (st.st_fab_rfm == FAB$C_VAR
3911 || st.st_fab_rfm == FAB$C_VFC)) {
3912 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3923 * This "flush" is akin to sfio's sync in that it handles files in either
3924 * read or write state. For write state, we put the postponed data through
3925 * the next layers. For read state, we seek() the next layers to the
3926 * offset given by current position in the buffer, and discard the buffer
3927 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3928 * in any case?). Then the pass the stick further in chain.
3931 PerlIOBuf_flush(pTHX_ PerlIO *f)
3933 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3935 PerlIO *n = PerlIONext(f);
3936 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3938 * write() the buffer
3940 const STDCHAR *buf = b->buf;
3941 const STDCHAR *p = buf;
3942 while (p < b->ptr) {
3943 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3947 else if (count < 0 || PerlIO_error(n)) {
3948 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3953 b->posn += (p - buf);
3955 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3956 STDCHAR *buf = PerlIO_get_base(f);
3958 * Note position change
3960 b->posn += (b->ptr - buf);
3961 if (b->ptr < b->end) {
3962 /* We did not consume all of it - try and seek downstream to
3963 our logical position
3965 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3966 /* Reload n as some layers may pop themselves on seek */
3967 b->posn = PerlIO_tell(n = PerlIONext(f));
3970 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3971 data is lost for good - so return saying "ok" having undone
3974 b->posn -= (b->ptr - buf);
3979 b->ptr = b->end = b->buf;
3980 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3981 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3982 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3987 /* This discards the content of the buffer after b->ptr, and rereads
3988 * the buffer from the position off in the layer downstream; here off
3989 * is at offset corresponding to b->ptr - b->buf.
3992 PerlIOBuf_fill(pTHX_ PerlIO *f)
3994 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3995 PerlIO *n = PerlIONext(f);
3998 * Down-stream flush is defined not to loose read data so is harmless.
3999 * we would not normally be fill'ing if there was data left in anycase.
4001 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4003 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4004 PerlIOBase_flush_linebuf(aTHX);
4007 PerlIO_get_base(f); /* allocate via vtable */
4009 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4011 b->ptr = b->end = b->buf;
4013 if (!PerlIOValid(n)) {
4014 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4018 if (PerlIO_fast_gets(n)) {
4020 * Layer below is also buffered. We do _NOT_ want to call its
4021 * ->Read() because that will loop till it gets what we asked for
4022 * which may hang on a pipe etc. Instead take anything it has to
4023 * hand, or ask it to fill _once_.
4025 avail = PerlIO_get_cnt(n);
4027 avail = PerlIO_fill(n);
4029 avail = PerlIO_get_cnt(n);
4031 if (!PerlIO_error(n) && PerlIO_eof(n))
4036 STDCHAR *ptr = PerlIO_get_ptr(n);
4037 const SSize_t cnt = avail;
4038 if (avail > (SSize_t)b->bufsiz)
4040 Copy(ptr, b->buf, avail, STDCHAR);
4041 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4045 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4049 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4051 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4054 b->end = b->buf + avail;
4055 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4060 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4062 if (PerlIOValid(f)) {
4063 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4066 return PerlIOBase_read(aTHX_ f, vbuf, count);
4072 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4074 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4075 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4078 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4083 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4085 * Buffer is already a read buffer, we can overwrite any chars
4086 * which have been read back to buffer start
4088 avail = (b->ptr - b->buf);
4092 * Buffer is idle, set it up so whole buffer is available for
4096 b->end = b->buf + avail;
4098 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4100 * Buffer extends _back_ from where we are now
4102 b->posn -= b->bufsiz;
4104 if (avail > (SSize_t) count) {
4106 * If we have space for more than count, just move count
4114 * In simple stdio-like ungetc() case chars will be already
4117 if (buf != b->ptr) {
4118 Copy(buf, b->ptr, avail, STDCHAR);
4122 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4126 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4132 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4134 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4135 const STDCHAR *buf = (const STDCHAR *) vbuf;
4136 const STDCHAR *flushptr = buf;
4140 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4142 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4143 if (PerlIO_flush(f) != 0) {
4147 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4148 flushptr = buf + count;
4149 while (flushptr > buf && *(flushptr - 1) != '\n')
4153 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4154 if ((SSize_t) count < avail)
4156 if (flushptr > buf && flushptr <= buf + avail)
4157 avail = flushptr - buf;
4158 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4160 Copy(buf, b->ptr, avail, STDCHAR);
4165 if (buf == flushptr)
4168 if (b->ptr >= (b->buf + b->bufsiz))
4169 if (PerlIO_flush(f) == -1)
4172 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4178 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4181 if ((code = PerlIO_flush(f)) == 0) {
4182 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4183 code = PerlIO_seek(PerlIONext(f), offset, whence);
4185 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4186 b->posn = PerlIO_tell(PerlIONext(f));
4193 PerlIOBuf_tell(pTHX_ PerlIO *f)
4195 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4197 * b->posn is file position where b->buf was read, or will be written
4199 Off_t posn = b->posn;
4200 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4201 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4203 /* As O_APPEND files are normally shared in some sense it is better
4208 /* when file is NOT shared then this is sufficient */
4209 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4211 posn = b->posn = PerlIO_tell(PerlIONext(f));
4215 * If buffer is valid adjust position by amount in buffer
4217 posn += (b->ptr - b->buf);
4223 PerlIOBuf_popped(pTHX_ PerlIO *f)
4225 const IV code = PerlIOBase_popped(aTHX_ f);
4226 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4227 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4230 b->ptr = b->end = b->buf = NULL;
4231 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4236 PerlIOBuf_close(pTHX_ PerlIO *f)
4238 const IV code = PerlIOBase_close(aTHX_ f);
4239 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4240 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4243 b->ptr = b->end = b->buf = NULL;
4244 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4249 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4251 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4258 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4260 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4263 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4264 return (b->end - b->ptr);
4269 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4271 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4272 PERL_UNUSED_CONTEXT;
4276 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4277 Newxz(b->buf,b->bufsiz, STDCHAR);
4279 b->buf = (STDCHAR *) & b->oneword;
4280 b->bufsiz = sizeof(b->oneword);
4282 b->end = b->ptr = b->buf;
4288 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4290 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4293 return (b->end - b->buf);
4297 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4299 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4301 PERL_UNUSED_ARG(cnt);
4306 assert(PerlIO_get_cnt(f) == cnt);
4307 assert(b->ptr >= b->buf);
4308 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4312 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4314 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4319 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4320 sizeof(PerlIO_funcs),
4323 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4327 PerlIOBase_binmode, /* binmode */
4341 PerlIOBase_clearerr,
4342 PerlIOBase_setlinebuf,
4347 PerlIOBuf_set_ptrcnt,
4350 /*--------------------------------------------------------------------------------------*/
4352 * Temp layer to hold unread chars when cannot do it any other way
4356 PerlIOPending_fill(pTHX_ PerlIO *f)
4359 * Should never happen
4366 PerlIOPending_close(pTHX_ PerlIO *f)
4369 * A tad tricky - flush pops us, then we close new top
4372 return PerlIO_close(f);
4376 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4379 * A tad tricky - flush pops us, then we seek new top
4382 return PerlIO_seek(f, offset, whence);
4387 PerlIOPending_flush(pTHX_ PerlIO *f)
4389 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4390 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4394 PerlIO_pop(aTHX_ f);
4399 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4405 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4410 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4412 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4413 PerlIOl * const l = PerlIOBase(f);
4415 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4416 * etc. get muddled when it changes mid-string when we auto-pop.
4418 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4419 (PerlIOBase(PerlIONext(f))->
4420 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4425 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4427 SSize_t avail = PerlIO_get_cnt(f);
4429 if ((SSize_t)count < avail)
4432 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4433 if (got >= 0 && got < (SSize_t)count) {
4434 const SSize_t more =
4435 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4436 if (more >= 0 || got == 0)
4442 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4443 sizeof(PerlIO_funcs),
4446 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4447 PerlIOPending_pushed,
4450 PerlIOBase_binmode, /* binmode */
4459 PerlIOPending_close,
4460 PerlIOPending_flush,
4464 PerlIOBase_clearerr,
4465 PerlIOBase_setlinebuf,
4470 PerlIOPending_set_ptrcnt,
4475 /*--------------------------------------------------------------------------------------*/
4477 * crlf - translation On read translate CR,LF to "\n" we do this by
4478 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4479 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4481 * c->nl points on the first byte of CR LF pair when it is temporarily
4482 * replaced by LF, or to the last CR of the buffer. In the former case
4483 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4484 * that it ends at c->nl; these two cases can be distinguished by
4485 * *c->nl. c->nl is set during _getcnt() call, and unset during
4486 * _unread() and _flush() calls.
4487 * It only matters for read operations.
4491 PerlIOBuf base; /* PerlIOBuf stuff */
4492 STDCHAR *nl; /* Position of crlf we "lied" about in the
4496 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4497 * Otherwise the :crlf layer would always revert back to
4501 S_inherit_utf8_flag(PerlIO *f)
4503 PerlIO *g = PerlIONext(f);
4504 if (PerlIOValid(g)) {
4505 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4506 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4512 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4515 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4516 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4518 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4519 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4520 PerlIOBase(f)->flags);
4523 /* If the old top layer is a CRLF layer, reactivate it (if
4524 * necessary) and remove this new layer from the stack */
4525 PerlIO *g = PerlIONext(f);
4526 if (PerlIOValid(g)) {
4527 PerlIOl *b = PerlIOBase(g);
4528 if (b && b->tab == &PerlIO_crlf) {
4529 if (!(b->flags & PERLIO_F_CRLF))
4530 b->flags |= PERLIO_F_CRLF;
4531 S_inherit_utf8_flag(g);
4532 PerlIO_pop(aTHX_ f);
4537 S_inherit_utf8_flag(f);
4543 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4545 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4546 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4550 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4551 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4553 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4554 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4556 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4561 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4562 b->end = b->ptr = b->buf + b->bufsiz;
4563 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4564 b->posn -= b->bufsiz;
4566 while (count > 0 && b->ptr > b->buf) {
4567 const int ch = *--buf;
4569 if (b->ptr - 2 >= b->buf) {
4576 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4577 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4593 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4595 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4597 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4600 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4601 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4602 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4603 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4605 while (nl < b->end && *nl != 0xd)
4607 if (nl < b->end && *nl == 0xd) {
4609 if (nl + 1 < b->end) {
4616 * Not CR,LF but just CR
4624 * Blast - found CR as last char in buffer
4629 * They may not care, defer work as long as
4633 return (nl - b->ptr);
4637 b->ptr++; /* say we have read it as far as
4638 * flush() is concerned */
4639 b->buf++; /* Leave space in front of buffer */
4640 /* Note as we have moved buf up flush's
4642 will naturally make posn point at CR
4644 b->bufsiz--; /* Buffer is thus smaller */
4645 code = PerlIO_fill(f); /* Fetch some more */
4646 b->bufsiz++; /* Restore size for next time */
4647 b->buf--; /* Point at space */
4648 b->ptr = nl = b->buf; /* Which is what we hand
4650 *nl = 0xd; /* Fill in the CR */
4652 goto test; /* fill() call worked */
4654 * CR at EOF - just fall through
4656 /* Should we clear EOF though ??? */
4661 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4667 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4669 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4670 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4676 if (ptr == b->end && *c->nl == 0xd) {
4677 /* Deferred CR at end of buffer case - we lied about count */
4690 * Test code - delete when it works ...
4692 IV flags = PerlIOBase(f)->flags;
4693 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4694 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4695 /* Deferred CR at end of buffer case - we lied about count */
4701 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4702 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4703 flags, c->nl, b->end, cnt);
4710 * They have taken what we lied about
4718 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4722 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4724 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4725 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4727 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4728 const STDCHAR *buf = (const STDCHAR *) vbuf;
4729 const STDCHAR * const ebuf = buf + count;
4732 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4734 while (buf < ebuf) {
4735 const STDCHAR * const eptr = b->buf + b->bufsiz;
4736 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4737 while (buf < ebuf && b->ptr < eptr) {
4739 if ((b->ptr + 2) > eptr) {
4747 *(b->ptr)++ = 0xd; /* CR */
4748 *(b->ptr)++ = 0xa; /* LF */
4750 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4757 *(b->ptr)++ = *buf++;
4759 if (b->ptr >= eptr) {
4765 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4767 return (buf - (STDCHAR *) vbuf);
4772 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4774 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4779 return PerlIOBuf_flush(aTHX_ f);
4783 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4785 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4786 /* In text mode - flush any pending stuff and flip it */
4787 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4788 #ifndef PERLIO_USING_CRLF
4789 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4790 PerlIO_pop(aTHX_ f);
4796 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4797 sizeof(PerlIO_funcs),
4800 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4802 PerlIOBuf_popped, /* popped */
4804 PerlIOCrlf_binmode, /* binmode */
4808 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4809 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4810 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4818 PerlIOBase_clearerr,
4819 PerlIOBase_setlinebuf,
4824 PerlIOCrlf_set_ptrcnt,
4828 Perl_PerlIO_stdin(pTHX)
4832 PerlIO_stdstreams(aTHX);
4834 return (PerlIO*)&PL_perlio[1];
4838 Perl_PerlIO_stdout(pTHX)
4842 PerlIO_stdstreams(aTHX);
4844 return (PerlIO*)&PL_perlio[2];
4848 Perl_PerlIO_stderr(pTHX)
4852 PerlIO_stdstreams(aTHX);
4854 return (PerlIO*)&PL_perlio[3];
4857 /*--------------------------------------------------------------------------------------*/
4860 PerlIO_getname(PerlIO *f, char *buf)
4865 bool exported = FALSE;
4866 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4868 stdio = PerlIO_exportFILE(f,0);
4872 name = fgetname(stdio, buf);
4873 if (exported) PerlIO_releaseFILE(f,stdio);
4878 PERL_UNUSED_ARG(buf);
4879 Perl_croak(aTHX_ "Don't know how to get file name");
4885 /*--------------------------------------------------------------------------------------*/
4887 * Functions which can be called on any kind of PerlIO implemented in
4891 #undef PerlIO_fdopen
4893 PerlIO_fdopen(int fd, const char *mode)
4896 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4901 PerlIO_open(const char *path, const char *mode)
4904 SV *name = sv_2mortal(newSVpv(path, 0));
4905 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4908 #undef Perlio_reopen
4910 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4913 SV *name = sv_2mortal(newSVpv(path,0));
4914 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4919 PerlIO_getc(PerlIO *f)
4923 if ( 1 == PerlIO_read(f, buf, 1) ) {
4924 return (unsigned char) buf[0];
4929 #undef PerlIO_ungetc
4931 PerlIO_ungetc(PerlIO *f, int ch)
4936 if (PerlIO_unread(f, &buf, 1) == 1)
4944 PerlIO_putc(PerlIO *f, int ch)
4948 return PerlIO_write(f, &buf, 1);
4953 PerlIO_puts(PerlIO *f, const char *s)
4956 return PerlIO_write(f, s, strlen(s));
4959 #undef PerlIO_rewind
4961 PerlIO_rewind(PerlIO *f)
4964 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4968 #undef PerlIO_vprintf
4970 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4979 Perl_va_copy(ap, apc);
4980 sv = vnewSVpvf(fmt, &apc);
4982 sv = vnewSVpvf(fmt, &ap);
4984 s = SvPV_const(sv, len);
4985 wrote = PerlIO_write(f, s, len);
4990 #undef PerlIO_printf
4992 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4997 result = PerlIO_vprintf(f, fmt, ap);
5002 #undef PerlIO_stdoutf
5004 PerlIO_stdoutf(const char *fmt, ...)
5010 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5015 #undef PerlIO_tmpfile
5017 PerlIO_tmpfile(void)
5022 const int fd = win32_tmpfd();
5024 f = PerlIO_fdopen(fd, "w+b");
5026 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5028 char tempname[] = "/tmp/PerlIO_XXXXXX";
5029 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5032 * I have no idea how portable mkstemp() is ... NI-S
5034 if (tmpdir && *tmpdir) {
5035 /* if TMPDIR is set and not empty, we try that first */
5036 sv = newSVpv(tmpdir, 0);
5037 sv_catpv(sv, tempname + 4);
5038 fd = mkstemp(SvPVX(sv));
5042 /* else we try /tmp */
5043 fd = mkstemp(tempname);
5046 f = PerlIO_fdopen(fd, "w+");
5048 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5049 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5052 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5053 FILE * const stdio = PerlSIO_tmpfile();
5056 f = PerlIO_fdopen(fileno(stdio), "w+");
5058 # endif /* else HAS_MKSTEMP */
5059 #endif /* else WIN32 */
5066 #endif /* USE_SFIO */
5067 #endif /* PERLIO_IS_STDIO */
5069 /*======================================================================================*/
5071 * Now some functions in terms of above which may be needed even if we are
5072 * not in true PerlIO mode
5075 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5078 const char *direction = NULL;
5081 * Need to supply default layer info from open.pm
5087 if (mode && mode[0] != 'r') {
5088 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5089 direction = "open>";
5091 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5092 direction = "open<";
5097 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5100 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5105 #undef PerlIO_setpos
5107 PerlIO_setpos(PerlIO *f, SV *pos)
5112 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5113 if (f && len == sizeof(Off_t))
5114 return PerlIO_seek(f, *posn, SEEK_SET);
5116 SETERRNO(EINVAL, SS_IVCHAN);
5120 #undef PerlIO_setpos
5122 PerlIO_setpos(PerlIO *f, SV *pos)
5127 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5128 if (f && len == sizeof(Fpos_t)) {
5129 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5130 return fsetpos64(f, fpos);
5132 return fsetpos(f, fpos);
5136 SETERRNO(EINVAL, SS_IVCHAN);
5142 #undef PerlIO_getpos
5144 PerlIO_getpos(PerlIO *f, SV *pos)
5147 Off_t posn = PerlIO_tell(f);
5148 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5149 return (posn == (Off_t) - 1) ? -1 : 0;
5152 #undef PerlIO_getpos
5154 PerlIO_getpos(PerlIO *f, SV *pos)
5159 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5160 code = fgetpos64(f, &fpos);
5162 code = fgetpos(f, &fpos);
5164 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5169 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5172 vprintf(char *pat, char *args)
5174 _doprnt(pat, args, stdout);
5175 return 0; /* wrong, but perl doesn't use the return
5180 vfprintf(FILE *fd, char *pat, char *args)
5182 _doprnt(pat, args, fd);
5183 return 0; /* wrong, but perl doesn't use the return
5189 #ifndef PerlIO_vsprintf
5191 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5194 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5195 PERL_UNUSED_CONTEXT;
5197 #ifndef PERL_MY_VSNPRINTF_GUARDED
5198 if (val < 0 || (n > 0 ? val >= n : 0)) {
5199 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5206 #ifndef PerlIO_sprintf
5208 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5213 result = PerlIO_vsprintf(s, n, fmt, ap);
5221 * c-indentation-style: bsd
5223 * indent-tabs-mode: nil
5226 * ex: set ts=8 sts=4 sw=4 et: