3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008 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 */
73 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
75 /* Call the callback or PerlIOBase, and return failure. */
76 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
77 if (PerlIOValid(f)) { \
78 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
79 if (tab && tab->callback) \
80 return (*tab->callback) args; \
82 return PerlIOBase_ ## base args; \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or fail, and return failure. */
89 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 return (*tab->callback) args; \
94 SETERRNO(EINVAL, LIB_INVARG); \
97 SETERRNO(EBADF, SS_IVCHAN); \
100 /* Call the callback or PerlIOBase, and be void. */
101 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 PerlIOBase_ ## base args; \
110 SETERRNO(EBADF, SS_IVCHAN)
112 /* Call the callback or fail, and be void. */
113 #define Perl_PerlIO_or_fail_void(f, callback, args) \
114 if (PerlIOValid(f)) { \
115 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
116 if (tab && tab->callback) \
117 (*tab->callback) args; \
119 SETERRNO(EINVAL, LIB_INVARG); \
122 SETERRNO(EBADF, SS_IVCHAN)
124 #if defined(__osf__) && _XOPEN_SOURCE < 500
125 extern int fseeko(FILE *, off_t, int);
126 extern off_t ftello(FILE *);
131 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
134 perlsio_binmode(FILE *fp, int iotype, int mode)
137 * This used to be contents of do_binmode in doio.c
140 # if defined(atarist)
141 PERL_UNUSED_ARG(iotype);
144 ((FILE *) fp)->_flag |= _IOBIN;
146 ((FILE *) fp)->_flag &= ~_IOBIN;
152 PERL_UNUSED_ARG(iotype);
154 if (PerlLIO_setmode(fp, mode) != -1) {
156 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
164 # if defined(USEMYBINMODE)
166 # if defined(__CYGWIN__)
167 PERL_UNUSED_ARG(iotype);
169 if (my_binmode(fp, iotype, mode) != FALSE)
175 PERL_UNUSED_ARG(iotype);
176 PERL_UNUSED_ARG(mode);
184 #define O_ACCMODE 3 /* Assume traditional implementation */
188 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
190 const int result = rawmode & O_ACCMODE;
195 ptype = IoTYPE_RDONLY;
198 ptype = IoTYPE_WRONLY;
206 *writing = (result != O_RDONLY);
208 if (result == O_RDONLY) {
212 else if (rawmode & O_APPEND) {
214 if (result != O_WRONLY)
219 if (result == O_WRONLY)
226 if (rawmode & O_BINARY)
232 #ifndef PERLIO_LAYERS
234 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
236 if (!names || !*names
237 || strEQ(names, ":crlf")
238 || strEQ(names, ":raw")
239 || strEQ(names, ":bytes")
243 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
251 PerlIO_destruct(pTHX)
256 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
259 PERL_UNUSED_ARG(iotype);
260 PERL_UNUSED_ARG(mode);
261 PERL_UNUSED_ARG(names);
264 return perlsio_binmode(fp, iotype, mode);
269 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
271 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
274 #ifdef PERL_IMPLICIT_SYS
275 return PerlSIO_fdupopen(f);
278 return win32_fdupopen(f);
281 const int fd = PerlLIO_dup(PerlIO_fileno(f));
285 const int omode = djgpp_get_stream_mode(f);
287 const int omode = fcntl(fd, F_GETFL);
289 PerlIO_intmode2str(omode,mode,NULL);
290 /* the r+ is a hack */
291 return PerlIO_fdopen(fd, mode);
296 SETERRNO(EBADF, SS_IVCHAN);
306 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
310 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
311 int imode, int perm, PerlIO *old, int narg, SV **args)
315 Perl_croak(aTHX_ "More than one argument to open");
317 if (*args == &PL_sv_undef)
318 return PerlIO_tmpfile();
320 const char *name = SvPV_nolen_const(*args);
321 if (*mode == IoTYPE_NUMERIC) {
322 fd = PerlLIO_open3(name, imode, perm);
324 return PerlIO_fdopen(fd, mode + 1);
327 return PerlIO_reopen(name, mode, old);
330 return PerlIO_open(name, mode);
335 return PerlIO_fdopen(fd, (char *) mode);
340 XS(XS_PerlIO__Layer__find)
344 Perl_croak(aTHX_ "Usage class->find(name[,load])");
346 const char * const name = SvPV_nolen_const(ST(1));
347 ST(0) = (strEQ(name, "crlf")
348 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
355 Perl_boot_core_PerlIO(pTHX)
357 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
363 #ifdef PERLIO_IS_STDIO
370 * Does nothing (yet) except force this file to be included in perl
371 * binary. That allows this file to force inclusion of other functions
372 * that may be required by loadable extensions e.g. for
373 * FileHandle::tmpfile
377 #undef PerlIO_tmpfile
384 #else /* PERLIO_IS_STDIO */
392 * This section is just to make sure these functions get pulled in from
396 #undef PerlIO_tmpfile
408 * Force this file to be included in perl binary. Which allows this
409 * file to force inclusion of other functions that may be required by
410 * loadable extensions e.g. for FileHandle::tmpfile
414 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
415 * results in a lot of lseek()s to regular files and lot of small
418 sfset(sfstdout, SF_SHARE, 0);
421 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
423 PerlIO_importFILE(FILE *stdio, const char *mode)
425 const int fd = fileno(stdio);
426 if (!mode || !*mode) {
429 return PerlIO_fdopen(fd, mode);
433 PerlIO_findFILE(PerlIO *pio)
435 const int fd = PerlIO_fileno(pio);
436 FILE * const f = fdopen(fd, "r+");
438 if (!f && errno == EINVAL)
440 if (!f && errno == EINVAL)
447 /*======================================================================================*/
449 * Implement all the PerlIO interface ourselves.
455 #include <sys/mman.h>
459 PerlIO_debug(const char *fmt, ...)
464 if (!PL_perlio_debug_fd) {
465 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
466 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
469 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
471 PL_perlio_debug_fd = -1;
473 /* tainting or set*id, so ignore the environment, and ensure we
474 skip these tests next time through. */
475 PL_perlio_debug_fd = -1;
478 if (PL_perlio_debug_fd > 0) {
481 const char * const s = CopFILE(PL_curcop);
482 /* Use fixed buffer as sv_catpvf etc. needs SVs */
484 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
485 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
486 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
488 const char *s = CopFILE(PL_curcop);
490 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
491 (IV) CopLINE(PL_curcop));
492 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
494 s = SvPV_const(sv, len);
495 PerlLIO_write(PL_perlio_debug_fd, s, len);
502 /*--------------------------------------------------------------------------------------*/
505 * Inner level routines
508 /* check that the head field of each layer points back to the head */
511 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
513 PerlIO_verify_head(pTHX_ PerlIO *f)
519 p = head = PerlIOBase(f)->head;
522 assert(p->head == head);
523 if (p == (PerlIOl*)f)
530 # define VERIFY_HEAD(f)
535 * Table of pointers to the PerlIO structs (malloc'ed)
537 #define PERLIO_TABLE_SIZE 64
540 PerlIO_init_table(pTHX)
544 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
550 PerlIO_allocate(pTHX)
554 * Find a free slot in the table, allocating new table as necessary
559 while ((f = *last)) {
561 last = (PerlIOl **) (f);
562 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
563 if (!((++f)->next)) {
564 f->flags = 0; /* lockcnt */
571 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
575 *last = (PerlIOl*) f++;
576 f->flags = 0; /* lockcnt */
582 #undef PerlIO_fdupopen
584 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
586 if (PerlIOValid(f)) {
587 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
588 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
590 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
592 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
596 SETERRNO(EBADF, SS_IVCHAN);
602 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
604 PerlIOl * const table = *tablep;
607 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
608 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
609 PerlIOl * const f = table + i;
611 PerlIO_close(&(f->next));
621 PerlIO_list_alloc(pTHX)
625 Newxz(list, 1, PerlIO_list_t);
631 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
634 if (--list->refcnt == 0) {
637 for (i = 0; i < list->cur; i++)
638 SvREFCNT_dec(list->array[i].arg);
639 Safefree(list->array);
647 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
653 if (list->cur >= list->len) {
656 Renew(list->array, list->len, PerlIO_pair_t);
658 Newx(list->array, list->len, PerlIO_pair_t);
660 p = &(list->array[list->cur++]);
662 if ((p->arg = arg)) {
663 SvREFCNT_inc_simple_void_NN(arg);
668 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
670 PerlIO_list_t *list = NULL;
673 list = PerlIO_list_alloc(aTHX);
674 for (i=0; i < proto->cur; i++) {
675 SV *arg = proto->array[i].arg;
678 arg = sv_dup(arg, param);
680 PERL_UNUSED_ARG(param);
682 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
689 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
692 PerlIOl **table = &proto->Iperlio;
695 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
696 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
697 PerlIO_init_table(aTHX);
698 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
699 while ((f = *table)) {
701 table = (PerlIOl **) (f++);
702 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
704 (void) fp_dup(&(f->next), 0, param);
711 PERL_UNUSED_ARG(proto);
712 PERL_UNUSED_ARG(param);
717 PerlIO_destruct(pTHX)
720 PerlIOl **table = &PL_perlio;
723 PerlIO_debug("Destruct %p\n",(void*)aTHX);
725 while ((f = *table)) {
727 table = (PerlIOl **) (f++);
728 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
729 PerlIO *x = &(f->next);
732 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
733 PerlIO_debug("Destruct popping %s\n", l->tab->name);
747 PerlIO_pop(pTHX_ PerlIO *f)
749 const PerlIOl *l = *f;
752 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
753 l->tab ? l->tab->name : "(Null)");
754 if (l->tab && l->tab->Popped) {
756 * If popped returns non-zero do not free its layer structure
757 * it has either done so itself, or it is shared and still in
760 if ((*l->tab->Popped) (aTHX_ f) != 0)
763 if (PerlIO_lockcnt(f)) {
764 /* we're in use; defer freeing the structure */
765 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
766 PerlIOBase(f)->tab = NULL;
776 /* Return as an array the stack of layers on a filehandle. Note that
777 * the stack is returned top-first in the array, and there are three
778 * times as many array elements as there are layers in the stack: the
779 * first element of a layer triplet is the name, the second one is the
780 * arguments, and the third one is the flags. */
783 PerlIO_get_layers(pTHX_ PerlIO *f)
786 AV * const av = newAV();
788 if (PerlIOValid(f)) {
789 PerlIOl *l = PerlIOBase(f);
792 /* There is some collusion in the implementation of
793 XS_PerlIO_get_layers - it knows that name and flags are
794 generated as fresh SVs here, and takes advantage of that to
795 "copy" them by taking a reference. If it changes here, it needs
796 to change there too. */
797 SV * const name = l->tab && l->tab->name ?
798 newSVpv(l->tab->name, 0) : &PL_sv_undef;
799 SV * const arg = l->tab && l->tab->Getarg ?
800 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
803 av_push(av, newSViv((IV)l->flags));
811 /*--------------------------------------------------------------------------------------*/
813 * XS Interface for perl code
817 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
821 if ((SSize_t) len <= 0)
823 for (i = 0; i < PL_known_layers->cur; i++) {
824 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
825 if (memEQ(f->name, name, len) && f->name[len] == 0) {
826 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
830 if (load && PL_subname && PL_def_layerlist
831 && PL_def_layerlist->cur >= 2) {
832 if (PL_in_load_module) {
833 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
836 SV * const pkgsv = newSVpvs("PerlIO");
837 SV * const layer = newSVpvn(name, len);
838 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
840 SAVEBOOL(PL_in_load_module);
842 SAVEGENERICSV(PL_warnhook);
843 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
845 PL_in_load_module = TRUE;
847 * The two SVs are magically freed by load_module
849 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
851 return PerlIO_find_layer(aTHX_ name, len, 0);
854 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
858 #ifdef USE_ATTRIBUTES_FOR_PERLIO
861 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
864 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
865 PerlIO * const ifp = IoIFP(io);
866 PerlIO * const ofp = IoOFP(io);
867 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
868 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
874 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
877 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
878 PerlIO * const ifp = IoIFP(io);
879 PerlIO * const ofp = IoOFP(io);
880 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
881 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
887 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
889 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
894 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
896 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
900 MGVTBL perlio_vtab = {
908 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
911 SV * const sv = SvRV(ST(1));
912 AV * const av = newAV();
916 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
918 mg = mg_find(sv, PERL_MAGIC_ext);
919 mg->mg_virtual = &perlio_vtab;
921 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
922 for (i = 2; i < items; i++) {
924 const char * const name = SvPV_const(ST(i), len);
925 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
927 av_push(av, SvREFCNT_inc_simple_NN(layer));
938 #endif /* USE_ATTIBUTES_FOR_PERLIO */
941 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
943 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
944 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
948 XS(XS_PerlIO__Layer__NoWarnings)
950 /* This is used as a %SIG{__WARN__} handler to suppress warnings
951 during loading of layers.
957 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
961 XS(XS_PerlIO__Layer__find)
967 Perl_croak(aTHX_ "Usage class->find(name[,load])");
970 const char * const name = SvPV_const(ST(1), len);
971 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
972 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
974 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
981 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
984 if (!PL_known_layers)
985 PL_known_layers = PerlIO_list_alloc(aTHX);
986 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
987 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
991 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
995 const char *s = names;
997 while (isSPACE(*s) || *s == ':')
1002 const char *as = NULL;
1004 if (!isIDFIRST(*s)) {
1006 * Message is consistent with how attribute lists are
1007 * passed. Even though this means "foo : : bar" is
1008 * seen as an invalid separator character.
1010 const char q = ((*s == '\'') ? '"' : '\'');
1011 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1012 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1014 SETERRNO(EINVAL, LIB_INVARG);
1019 } while (isALNUM(*e));
1028 alen = (e - 1) - as;
1035 * It's a nul terminated string, not allowed
1036 * to \ the terminating null. Anything other
1037 * character is passed over.
1047 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
1048 "Argument list not closed for PerlIO layer \"%.*s\"",
1060 PerlIO_funcs * const layer =
1061 PerlIO_find_layer(aTHX_ s, llen, 1);
1065 arg = newSVpvn(as, alen);
1066 PerlIO_list_push(aTHX_ av, layer,
1067 (arg) ? arg : &PL_sv_undef);
1071 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1084 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1087 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1088 #ifdef PERLIO_USING_CRLF
1091 if (PerlIO_stdio.Set_ptrcnt)
1092 tab = &PerlIO_stdio;
1094 PerlIO_debug("Pushing %s\n", tab->name);
1095 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1100 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1102 return av->array[n].arg;
1106 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1108 if (n >= 0 && n < av->cur) {
1109 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1110 av->array[n].funcs->name);
1111 return av->array[n].funcs;
1114 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1119 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1121 PERL_UNUSED_ARG(mode);
1122 PERL_UNUSED_ARG(arg);
1123 PERL_UNUSED_ARG(tab);
1124 if (PerlIOValid(f)) {
1126 PerlIO_pop(aTHX_ f);
1132 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1133 sizeof(PerlIO_funcs),
1136 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1156 NULL, /* get_base */
1157 NULL, /* get_bufsiz */
1160 NULL, /* set_ptrcnt */
1164 PerlIO_default_layers(pTHX)
1167 if (!PL_def_layerlist) {
1168 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1169 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1170 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1171 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1173 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1175 osLayer = &PerlIO_win32;
1178 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1179 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1180 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1181 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1183 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1185 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1186 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1187 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1188 PerlIO_list_push(aTHX_ PL_def_layerlist,
1189 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1192 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1195 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1198 if (PL_def_layerlist->cur < 2) {
1199 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1201 return PL_def_layerlist;
1205 Perl_boot_core_PerlIO(pTHX)
1207 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1208 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1211 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1212 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1216 PerlIO_default_layer(pTHX_ I32 n)
1219 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1222 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1225 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1226 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1229 PerlIO_stdstreams(pTHX)
1233 PerlIO_init_table(aTHX);
1234 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1235 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1236 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1241 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1244 if (tab->fsize != sizeof(PerlIO_funcs)) {
1246 "%s (%"UVuf") does not match %s (%"UVuf")",
1247 "PerlIO layer function table size", (UV)tab->fsize,
1248 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1252 if (tab->size < sizeof(PerlIOl)) {
1254 "%s (%"UVuf") smaller than %s (%"UVuf")",
1255 "PerlIO layer instance size", (UV)tab->size,
1256 "size expected by this perl", (UV)sizeof(PerlIOl) );
1258 /* Real layer with a data area */
1261 Newxz(temp, tab->size, char);
1265 l->tab = (PerlIO_funcs*) tab;
1266 l->head = ((PerlIOl*)f)->head;
1268 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1269 (void*)f, tab->name,
1270 (mode) ? mode : "(Null)", (void*)arg);
1271 if (*l->tab->Pushed &&
1273 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1274 PerlIO_pop(aTHX_ f);
1283 /* Pseudo-layer where push does its own stack adjust */
1284 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1285 (mode) ? mode : "(Null)", (void*)arg);
1287 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1295 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1296 IV n, const char *mode, int fd, int imode, int perm,
1297 PerlIO *old, int narg, SV **args)
1299 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1300 if (tab && tab->Open) {
1301 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1302 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1308 SETERRNO(EINVAL, LIB_INVARG);
1313 PerlIOBase_binmode(pTHX_ PerlIO *f)
1315 if (PerlIOValid(f)) {
1316 /* Is layer suitable for raw stream ? */
1317 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1318 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1319 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1322 /* Not suitable - pop it */
1323 PerlIO_pop(aTHX_ f);
1331 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1333 PERL_UNUSED_ARG(mode);
1334 PERL_UNUSED_ARG(arg);
1335 PERL_UNUSED_ARG(tab);
1337 if (PerlIOValid(f)) {
1342 * Strip all layers that are not suitable for a raw stream
1345 while (t && (l = *t)) {
1346 if (l->tab && l->tab->Binmode) {
1347 /* Has a handler - normal case */
1348 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1350 /* Layer still there - move down a layer */
1359 /* No handler - pop it */
1360 PerlIO_pop(aTHX_ t);
1363 if (PerlIOValid(f)) {
1364 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1365 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1373 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1374 PerlIO_list_t *layers, IV n, IV max)
1378 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1380 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1391 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1395 save_scalar(PL_errgv);
1397 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1398 code = PerlIO_parse_layers(aTHX_ layers, names);
1400 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1402 PerlIO_list_free(aTHX_ layers);
1409 /*--------------------------------------------------------------------------------------*/
1411 * Given the abstraction above the public API functions
1415 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1417 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1418 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1419 PerlIOBase(f)->tab->name : "(Null)",
1420 iotype, mode, (names) ? names : "(Null)");
1423 /* Do not flush etc. if (e.g.) switching encodings.
1424 if a pushed layer knows it needs to flush lower layers
1425 (for example :unix which is never going to call them)
1426 it can do the flush when it is pushed.
1428 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1431 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1432 #ifdef PERLIO_USING_CRLF
1433 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1434 O_BINARY so we can look for it in mode.
1436 if (!(mode & O_BINARY)) {
1438 /* FIXME?: Looking down the layer stack seems wrong,
1439 but is a way of reaching past (say) an encoding layer
1440 to flip CRLF-ness of the layer(s) below
1443 /* Perhaps we should turn on bottom-most aware layer
1444 e.g. Ilya's idea that UNIX TTY could serve
1446 if (PerlIOBase(f)->tab &&
1447 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1449 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1450 /* Not in text mode - flush any pending stuff and flip it */
1452 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1454 /* Only need to turn it on in one layer so we are done */
1459 /* Not finding a CRLF aware layer presumably means we are binary
1460 which is not what was requested - so we failed
1461 We _could_ push :crlf layer but so could caller
1466 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1467 So code that used to be here is now in PerlIORaw_pushed().
1469 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1474 PerlIO__close(pTHX_ PerlIO *f)
1476 if (PerlIOValid(f)) {
1477 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1478 if (tab && tab->Close)
1479 return (*tab->Close)(aTHX_ f);
1481 return PerlIOBase_close(aTHX_ f);
1484 SETERRNO(EBADF, SS_IVCHAN);
1490 Perl_PerlIO_close(pTHX_ PerlIO *f)
1492 const int code = PerlIO__close(aTHX_ f);
1493 while (PerlIOValid(f)) {
1494 PerlIO_pop(aTHX_ f);
1495 if (PerlIO_lockcnt(f))
1496 /* we're in use; the 'pop' deferred freeing the structure */
1503 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1506 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1510 static PerlIO_funcs *
1511 PerlIO_layer_from_ref(pTHX_ SV *sv)
1515 * For any scalar type load the handler which is bundled with perl
1517 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1518 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1519 /* This isn't supposed to happen, since PerlIO::scalar is core,
1520 * but could happen anyway in smaller installs or with PAR */
1522 /* diag_listed_as: Unknown PerlIO layer "%s" */
1523 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1528 * For other types allow if layer is known but don't try and load it
1530 switch (SvTYPE(sv)) {
1532 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1534 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1536 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1538 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1545 PerlIO_resolve_layers(pTHX_ const char *layers,
1546 const char *mode, int narg, SV **args)
1549 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1552 PerlIO_stdstreams(aTHX);
1554 SV * const arg = *args;
1556 * If it is a reference but not an object see if we have a handler
1559 if (SvROK(arg) && !sv_isobject(arg)) {
1560 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1562 def = PerlIO_list_alloc(aTHX);
1563 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1567 * Don't fail if handler cannot be found :via(...) etc. may do
1568 * something sensible else we will just stringfy and open
1573 if (!layers || !*layers)
1574 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1575 if (layers && *layers) {
1578 av = PerlIO_clone_list(aTHX_ def, NULL);
1583 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1587 PerlIO_list_free(aTHX_ av);
1599 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1600 int imode, int perm, PerlIO *f, int narg, SV **args)
1603 if (!f && narg == 1 && *args == &PL_sv_undef) {
1604 if ((f = PerlIO_tmpfile())) {
1605 if (!layers || !*layers)
1606 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1607 if (layers && *layers)
1608 PerlIO_apply_layers(aTHX_ f, mode, layers);
1612 PerlIO_list_t *layera;
1614 PerlIO_funcs *tab = NULL;
1615 if (PerlIOValid(f)) {
1617 * This is "reopen" - it is not tested as perl does not use it
1621 layera = PerlIO_list_alloc(aTHX);
1624 if (l->tab && l->tab->Getarg)
1625 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1626 PerlIO_list_push(aTHX_ layera, l->tab,
1627 (arg) ? arg : &PL_sv_undef);
1629 l = *PerlIONext(&l);
1633 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1639 * Start at "top" of layer stack
1641 n = layera->cur - 1;
1643 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1652 * Found that layer 'n' can do opens - call it
1654 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1655 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1657 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1658 tab->name, layers ? layers : "(Null)", mode, fd,
1659 imode, perm, (void*)f, narg, (void*)args);
1661 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1664 SETERRNO(EINVAL, LIB_INVARG);
1668 if (n + 1 < layera->cur) {
1670 * More layers above the one that we used to open -
1673 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1674 /* If pushing layers fails close the file */
1681 PerlIO_list_free(aTHX_ layera);
1688 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1690 PERL_ARGS_ASSERT_PERLIO_READ;
1692 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1696 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1698 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1700 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1704 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1706 PERL_ARGS_ASSERT_PERLIO_WRITE;
1708 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1712 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1714 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1718 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1720 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1724 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1729 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1731 if (tab && tab->Flush)
1732 return (*tab->Flush) (aTHX_ f);
1734 return 0; /* If no Flush defined, silently succeed. */
1737 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1738 SETERRNO(EBADF, SS_IVCHAN);
1744 * Is it good API design to do flush-all on NULL, a potentially
1745 * erroneous input? Maybe some magical value (PerlIO*
1746 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1747 * things on fflush(NULL), but should we be bound by their design
1750 PerlIOl **table = &PL_perlio;
1753 while ((ff = *table)) {
1755 table = (PerlIOl **) (ff++);
1756 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1757 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1767 PerlIOBase_flush_linebuf(pTHX)
1770 PerlIOl **table = &PL_perlio;
1772 while ((f = *table)) {
1774 table = (PerlIOl **) (f++);
1775 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1777 && (PerlIOBase(&(f->next))->
1778 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1779 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1780 PerlIO_flush(&(f->next));
1787 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1789 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1793 PerlIO_isutf8(PerlIO *f)
1796 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1798 SETERRNO(EBADF, SS_IVCHAN);
1804 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1806 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1810 Perl_PerlIO_error(pTHX_ PerlIO *f)
1812 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1816 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1818 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1822 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1824 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1828 PerlIO_has_base(PerlIO *f)
1830 if (PerlIOValid(f)) {
1831 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1834 return (tab->Get_base != NULL);
1841 PerlIO_fast_gets(PerlIO *f)
1843 if (PerlIOValid(f)) {
1844 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1845 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1848 return (tab->Set_ptrcnt != NULL);
1856 PerlIO_has_cntptr(PerlIO *f)
1858 if (PerlIOValid(f)) {
1859 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1862 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1869 PerlIO_canset_cnt(PerlIO *f)
1871 if (PerlIOValid(f)) {
1872 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1875 return (tab->Set_ptrcnt != NULL);
1882 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1884 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1888 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1890 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1894 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1896 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1900 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1902 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1906 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1908 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1912 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1914 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1918 /*--------------------------------------------------------------------------------------*/
1920 * utf8 and raw dummy layers
1924 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1926 PERL_UNUSED_CONTEXT;
1927 PERL_UNUSED_ARG(mode);
1928 PERL_UNUSED_ARG(arg);
1929 if (PerlIOValid(f)) {
1930 if (tab && tab->kind & PERLIO_K_UTF8)
1931 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1933 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1939 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1940 sizeof(PerlIO_funcs),
1943 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1963 NULL, /* get_base */
1964 NULL, /* get_bufsiz */
1967 NULL, /* set_ptrcnt */
1970 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1971 sizeof(PerlIO_funcs),
1974 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1994 NULL, /* get_base */
1995 NULL, /* get_bufsiz */
1998 NULL, /* set_ptrcnt */
2001 PERLIO_FUNCS_DECL(PerlIO_raw) = {
2002 sizeof(PerlIO_funcs),
2025 NULL, /* get_base */
2026 NULL, /* get_bufsiz */
2029 NULL, /* set_ptrcnt */
2031 /*--------------------------------------------------------------------------------------*/
2032 /*--------------------------------------------------------------------------------------*/
2034 * "Methods" of the "base class"
2038 PerlIOBase_fileno(pTHX_ PerlIO *f)
2040 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2044 PerlIO_modestr(PerlIO * f, char *buf)
2047 if (PerlIOValid(f)) {
2048 const IV flags = PerlIOBase(f)->flags;
2049 if (flags & PERLIO_F_APPEND) {
2051 if (flags & PERLIO_F_CANREAD) {
2055 else if (flags & PERLIO_F_CANREAD) {
2057 if (flags & PERLIO_F_CANWRITE)
2060 else if (flags & PERLIO_F_CANWRITE) {
2062 if (flags & PERLIO_F_CANREAD) {
2066 #ifdef PERLIO_USING_CRLF
2067 if (!(flags & PERLIO_F_CRLF))
2077 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2079 PerlIOl * const l = PerlIOBase(f);
2080 PERL_UNUSED_CONTEXT;
2081 PERL_UNUSED_ARG(arg);
2083 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2084 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2085 if (tab && tab->Set_ptrcnt != NULL)
2086 l->flags |= PERLIO_F_FASTGETS;
2088 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2092 l->flags |= PERLIO_F_CANREAD;
2095 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2098 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2101 SETERRNO(EINVAL, LIB_INVARG);
2107 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2110 l->flags &= ~PERLIO_F_CRLF;
2113 l->flags |= PERLIO_F_CRLF;
2116 SETERRNO(EINVAL, LIB_INVARG);
2123 l->flags |= l->next->flags &
2124 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2129 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2130 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2131 l->flags, PerlIO_modestr(f, temp));
2137 PerlIOBase_popped(pTHX_ PerlIO *f)
2139 PERL_UNUSED_CONTEXT;
2145 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2148 * Save the position as current head considers it
2150 const Off_t old = PerlIO_tell(f);
2151 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2152 PerlIOSelf(f, PerlIOBuf)->posn = old;
2153 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2157 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2159 STDCHAR *buf = (STDCHAR *) vbuf;
2161 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2162 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2163 SETERRNO(EBADF, SS_IVCHAN);
2169 SSize_t avail = PerlIO_get_cnt(f);
2172 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2174 STDCHAR *ptr = PerlIO_get_ptr(f);
2175 Copy(ptr, buf, take, STDCHAR);
2176 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2179 if (avail == 0) /* set_ptrcnt could have reset avail */
2182 if (count > 0 && avail <= 0) {
2183 if (PerlIO_fill(f) != 0)
2188 return (buf - (STDCHAR *) vbuf);
2194 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2196 PERL_UNUSED_CONTEXT;
2202 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2204 PERL_UNUSED_CONTEXT;
2210 PerlIOBase_close(pTHX_ PerlIO *f)
2213 if (PerlIOValid(f)) {
2214 PerlIO *n = PerlIONext(f);
2215 code = PerlIO_flush(f);
2216 PerlIOBase(f)->flags &=
2217 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2218 while (PerlIOValid(n)) {
2219 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2220 if (tab && tab->Close) {
2221 if ((*tab->Close)(aTHX_ n) != 0)
2226 PerlIOBase(n)->flags &=
2227 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2233 SETERRNO(EBADF, SS_IVCHAN);
2239 PerlIOBase_eof(pTHX_ PerlIO *f)
2241 PERL_UNUSED_CONTEXT;
2242 if (PerlIOValid(f)) {
2243 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2249 PerlIOBase_error(pTHX_ PerlIO *f)
2251 PERL_UNUSED_CONTEXT;
2252 if (PerlIOValid(f)) {
2253 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2259 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2261 if (PerlIOValid(f)) {
2262 PerlIO * const n = PerlIONext(f);
2263 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2270 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2272 PERL_UNUSED_CONTEXT;
2273 if (PerlIOValid(f)) {
2274 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2279 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2285 arg = sv_dup(arg, param);
2286 SvREFCNT_inc_simple_void_NN(arg);
2290 return newSVsv(arg);
2293 PERL_UNUSED_ARG(param);
2294 return newSVsv(arg);
2299 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2301 PerlIO * const nexto = PerlIONext(o);
2302 if (PerlIOValid(nexto)) {
2303 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2304 if (tab && tab->Dup)
2305 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2307 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2310 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2313 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2314 self ? self->name : "(Null)",
2315 (void*)f, (void*)o, (void*)param);
2316 if (self && self->Getarg)
2317 arg = (*self->Getarg)(aTHX_ o, param, flags);
2318 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2319 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2320 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2326 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2328 /* Must be called with PL_perlio_mutex locked. */
2330 S_more_refcounted_fds(pTHX_ const int new_fd) {
2332 const int old_max = PL_perlio_fd_refcnt_size;
2333 const int new_max = 16 + (new_fd & ~15);
2336 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2337 old_max, new_fd, new_max);
2339 if (new_fd < old_max) {
2343 assert (new_max > new_fd);
2345 /* Use plain realloc() since we need this memory to be really
2346 * global and visible to all the interpreters and/or threads. */
2347 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2351 MUTEX_UNLOCK(&PL_perlio_mutex);
2353 /* Can't use PerlIO to write as it allocates memory */
2354 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2355 PL_no_mem, strlen(PL_no_mem));
2359 PL_perlio_fd_refcnt_size = new_max;
2360 PL_perlio_fd_refcnt = new_array;
2362 PerlIO_debug("Zeroing %p, %d\n",
2363 (void*)(new_array + old_max),
2366 Zero(new_array + old_max, new_max - old_max, int);
2373 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2374 PERL_UNUSED_CONTEXT;
2378 PerlIOUnix_refcnt_inc(int fd)
2385 MUTEX_LOCK(&PL_perlio_mutex);
2387 if (fd >= PL_perlio_fd_refcnt_size)
2388 S_more_refcounted_fds(aTHX_ fd);
2390 PL_perlio_fd_refcnt[fd]++;
2391 if (PL_perlio_fd_refcnt[fd] <= 0) {
2392 /* diag_listed_as: refcnt_inc: fd %d%s */
2393 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2394 fd, PL_perlio_fd_refcnt[fd]);
2396 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2397 fd, PL_perlio_fd_refcnt[fd]);
2400 MUTEX_UNLOCK(&PL_perlio_mutex);
2403 /* diag_listed_as: refcnt_inc: fd %d%s */
2404 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2409 PerlIOUnix_refcnt_dec(int fd)
2416 MUTEX_LOCK(&PL_perlio_mutex);
2418 if (fd >= PL_perlio_fd_refcnt_size) {
2419 /* diag_listed_as: refcnt_dec: fd %d%s */
2420 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2421 fd, PL_perlio_fd_refcnt_size);
2423 if (PL_perlio_fd_refcnt[fd] <= 0) {
2424 /* diag_listed_as: refcnt_dec: fd %d%s */
2425 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2426 fd, PL_perlio_fd_refcnt[fd]);
2428 cnt = --PL_perlio_fd_refcnt[fd];
2429 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2431 MUTEX_UNLOCK(&PL_perlio_mutex);
2434 /* diag_listed_as: refcnt_dec: fd %d%s */
2435 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2441 PerlIOUnix_refcnt(int fd)
2448 MUTEX_LOCK(&PL_perlio_mutex);
2450 if (fd >= PL_perlio_fd_refcnt_size) {
2451 /* diag_listed_as: refcnt: fd %d%s */
2452 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2453 fd, PL_perlio_fd_refcnt_size);
2455 if (PL_perlio_fd_refcnt[fd] <= 0) {
2456 /* diag_listed_as: refcnt: fd %d%s */
2457 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2458 fd, PL_perlio_fd_refcnt[fd]);
2460 cnt = PL_perlio_fd_refcnt[fd];
2462 MUTEX_UNLOCK(&PL_perlio_mutex);
2465 /* diag_listed_as: refcnt: fd %d%s */
2466 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2472 PerlIO_cleanup(pTHX)
2477 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2479 PerlIO_debug("Cleanup layers\n");
2482 /* Raise STDIN..STDERR refcount so we don't close them */
2483 for (i=0; i < 3; i++)
2484 PerlIOUnix_refcnt_inc(i);
2485 PerlIO_cleantable(aTHX_ &PL_perlio);
2486 /* Restore STDIN..STDERR refcount */
2487 for (i=0; i < 3; i++)
2488 PerlIOUnix_refcnt_dec(i);
2490 if (PL_known_layers) {
2491 PerlIO_list_free(aTHX_ PL_known_layers);
2492 PL_known_layers = NULL;
2494 if (PL_def_layerlist) {
2495 PerlIO_list_free(aTHX_ PL_def_layerlist);
2496 PL_def_layerlist = NULL;
2500 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2504 /* XXX we can't rely on an interpreter being present at this late stage,
2505 XXX so we can't use a function like PerlLIO_write that relies on one
2506 being present (at least in win32) :-(.
2511 /* By now all filehandles should have been closed, so any
2512 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2514 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2515 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2516 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2518 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2519 if (PL_perlio_fd_refcnt[i]) {
2521 my_snprintf(buf, sizeof(buf),
2522 "PerlIO_teardown: fd %d refcnt=%d\n",
2523 i, PL_perlio_fd_refcnt[i]);
2524 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2530 /* Not bothering with PL_perlio_mutex since by now
2531 * all the interpreters are gone. */
2532 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2533 && PL_perlio_fd_refcnt) {
2534 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2535 PL_perlio_fd_refcnt = NULL;
2536 PL_perlio_fd_refcnt_size = 0;
2540 /*--------------------------------------------------------------------------------------*/
2542 * Bottom-most level for UNIX-like case
2546 struct _PerlIO base; /* The generic part */
2547 int fd; /* UNIX like file descriptor */
2548 int oflags; /* open/fcntl flags */
2552 S_lockcnt_dec(pTHX_ const void* f)
2554 PerlIO_lockcnt((PerlIO*)f)--;
2558 /* call the signal handler, and if that handler happens to clear
2559 * this handle, free what we can and return true */
2562 S_perlio_async_run(pTHX_ PerlIO* f) {
2564 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2565 PerlIO_lockcnt(f)++;
2567 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2571 /* we've just run some perl-level code that could have done
2572 * anything, including closing the file or clearing this layer.
2573 * If so, free any lower layers that have already been
2574 * cleared, then return an error. */
2575 while (PerlIOValid(f) &&
2576 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2578 const PerlIOl *l = *f;
2587 PerlIOUnix_oflags(const char *mode)
2590 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2595 if (*++mode == '+') {
2602 oflags = O_CREAT | O_TRUNC;
2603 if (*++mode == '+') {
2612 oflags = O_CREAT | O_APPEND;
2613 if (*++mode == '+') {
2626 else if (*mode == 't') {
2628 oflags &= ~O_BINARY;
2632 * Always open in binary mode
2635 if (*mode || oflags == -1) {
2636 SETERRNO(EINVAL, LIB_INVARG);
2643 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2645 PERL_UNUSED_CONTEXT;
2646 return PerlIOSelf(f, PerlIOUnix)->fd;
2650 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2652 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2655 if (PerlLIO_fstat(fd, &st) == 0) {
2656 if (!S_ISREG(st.st_mode)) {
2657 PerlIO_debug("%d is not regular file\n",fd);
2658 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2661 PerlIO_debug("%d _is_ a regular file\n",fd);
2667 PerlIOUnix_refcnt_inc(fd);
2668 PERL_UNUSED_CONTEXT;
2672 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2674 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2675 if (*PerlIONext(f)) {
2676 /* We never call down so do any pending stuff now */
2677 PerlIO_flush(PerlIONext(f));
2679 * XXX could (or should) we retrieve the oflags from the open file
2680 * handle rather than believing the "mode" we are passed in? XXX
2681 * Should the value on NULL mode be 0 or -1?
2683 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2684 mode ? PerlIOUnix_oflags(mode) : -1);
2686 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2692 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2694 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2696 PERL_UNUSED_CONTEXT;
2697 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2699 SETERRNO(ESPIPE, LIB_INVARG);
2701 SETERRNO(EINVAL, LIB_INVARG);
2705 new_loc = PerlLIO_lseek(fd, offset, whence);
2706 if (new_loc == (Off_t) - 1)
2708 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2713 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2714 IV n, const char *mode, int fd, int imode,
2715 int perm, PerlIO *f, int narg, SV **args)
2717 if (PerlIOValid(f)) {
2718 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2719 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2722 if (*mode == IoTYPE_NUMERIC)
2725 imode = PerlIOUnix_oflags(mode);
2727 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2733 const char *path = SvPV_nolen_const(*args);
2734 fd = PerlLIO_open3(path, imode, perm);
2738 if (*mode == IoTYPE_IMPLICIT)
2741 f = PerlIO_allocate(aTHX);
2743 if (!PerlIOValid(f)) {
2744 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2748 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2749 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2750 if (*mode == IoTYPE_APPEND)
2751 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2758 * FIXME: pop layers ???
2766 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2768 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2770 if (flags & PERLIO_DUP_FD) {
2771 fd = PerlLIO_dup(fd);
2774 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2776 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2777 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2786 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2790 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2792 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2793 #ifdef PERLIO_STD_SPECIAL
2795 return PERLIO_STD_IN(fd, vbuf, count);
2797 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2798 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2802 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2803 if (len >= 0 || errno != EINTR) {
2805 if (errno != EAGAIN) {
2806 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2809 else if (len == 0 && count != 0) {
2810 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2816 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2823 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2827 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2829 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2830 #ifdef PERLIO_STD_SPECIAL
2831 if (fd == 1 || fd == 2)
2832 return PERLIO_STD_OUT(fd, vbuf, count);
2835 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2836 if (len >= 0 || errno != EINTR) {
2838 if (errno != EAGAIN) {
2839 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2845 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2852 PerlIOUnix_tell(pTHX_ PerlIO *f)
2854 PERL_UNUSED_CONTEXT;
2856 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2861 PerlIOUnix_close(pTHX_ PerlIO *f)
2864 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2866 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2867 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2868 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2873 SETERRNO(EBADF,SS_IVCHAN);
2876 while (PerlLIO_close(fd) != 0) {
2877 if (errno != EINTR) {
2882 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2886 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2891 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2892 sizeof(PerlIO_funcs),
2899 PerlIOBase_binmode, /* binmode */
2909 PerlIOBase_noop_ok, /* flush */
2910 PerlIOBase_noop_fail, /* fill */
2913 PerlIOBase_clearerr,
2914 PerlIOBase_setlinebuf,
2915 NULL, /* get_base */
2916 NULL, /* get_bufsiz */
2919 NULL, /* set_ptrcnt */
2922 /*--------------------------------------------------------------------------------------*/
2927 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2928 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2929 broken by the last second glibc 2.3 fix
2931 #define STDIO_BUFFER_WRITABLE
2936 struct _PerlIO base;
2937 FILE *stdio; /* The stream */
2941 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2943 PERL_UNUSED_CONTEXT;
2945 if (PerlIOValid(f)) {
2946 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2948 return PerlSIO_fileno(s);
2955 PerlIOStdio_mode(const char *mode, char *tmode)
2957 char * const ret = tmode;
2963 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2971 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2974 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2975 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2976 if (toptab == tab) {
2977 /* Top is already stdio - pop self (duplicate) and use original */
2978 PerlIO_pop(aTHX_ f);
2981 const int fd = PerlIO_fileno(n);
2984 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2985 mode = PerlIOStdio_mode(mode, tmode)))) {
2986 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2987 /* We never call down so do any pending stuff now */
2988 PerlIO_flush(PerlIONext(f));
2995 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3000 PerlIO_importFILE(FILE *stdio, const char *mode)
3006 if (!mode || !*mode) {
3007 /* We need to probe to see how we can open the stream
3008 so start with read/write and then try write and read
3009 we dup() so that we can fclose without loosing the fd.
3011 Note that the errno value set by a failing fdopen
3012 varies between stdio implementations.
3014 const int fd = PerlLIO_dup(fileno(stdio));
3015 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
3017 f2 = PerlSIO_fdopen(fd, (mode = "w"));
3020 f2 = PerlSIO_fdopen(fd, (mode = "r"));
3023 /* Don't seem to be able to open */
3029 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3030 s = PerlIOSelf(f, PerlIOStdio);
3032 PerlIOUnix_refcnt_inc(fileno(stdio));
3039 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3040 IV n, const char *mode, int fd, int imode,
3041 int perm, PerlIO *f, int narg, SV **args)
3044 if (PerlIOValid(f)) {
3045 const char * const path = SvPV_nolen_const(*args);
3046 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3048 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3049 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
3054 PerlIOUnix_refcnt_inc(fileno(s->stdio));
3059 const char * const path = SvPV_nolen_const(*args);
3060 if (*mode == IoTYPE_NUMERIC) {
3062 fd = PerlLIO_open3(path, imode, perm);
3066 bool appended = FALSE;
3068 /* Cygwin wants its 'b' early. */
3070 mode = PerlIOStdio_mode(mode, tmode);
3072 stdio = PerlSIO_fopen(path, mode);
3075 f = PerlIO_allocate(aTHX);
3078 mode = PerlIOStdio_mode(mode, tmode);
3079 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3081 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3082 PerlIOUnix_refcnt_inc(fileno(stdio));
3084 PerlSIO_fclose(stdio);
3096 if (*mode == IoTYPE_IMPLICIT) {
3103 stdio = PerlSIO_stdin;
3106 stdio = PerlSIO_stdout;
3109 stdio = PerlSIO_stderr;
3114 stdio = PerlSIO_fdopen(fd, mode =
3115 PerlIOStdio_mode(mode, tmode));
3119 f = PerlIO_allocate(aTHX);
3121 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3122 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3123 PerlIOUnix_refcnt_inc(fileno(stdio));
3133 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3135 /* This assumes no layers underneath - which is what
3136 happens, but is not how I remember it. NI-S 2001/10/16
3138 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3139 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3140 const int fd = fileno(stdio);
3142 if (flags & PERLIO_DUP_FD) {
3143 const int dfd = PerlLIO_dup(fileno(stdio));
3145 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3150 /* FIXME: To avoid messy error recovery if dup fails
3151 re-use the existing stdio as though flag was not set
3155 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3157 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3159 PerlIOUnix_refcnt_inc(fileno(stdio));
3166 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3168 PERL_UNUSED_CONTEXT;
3170 /* XXX this could use PerlIO_canset_fileno() and
3171 * PerlIO_set_fileno() support from Configure
3173 # if defined(__UCLIBC__)
3174 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3177 # elif defined(__GLIBC__)
3178 /* There may be a better way for GLIBC:
3179 - libio.h defines a flag to not close() on cleanup
3183 # elif defined(__sun__)
3186 # elif defined(__hpux)
3190 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3191 your platform does not have special entry try this one.
3192 [For OSF only have confirmation for Tru64 (alpha)
3193 but assume other OSFs will be similar.]
3195 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3198 # elif defined(__FreeBSD__)
3199 /* There may be a better way on FreeBSD:
3200 - we could insert a dummy func in the _close function entry
3201 f->_close = (int (*)(void *)) dummy_close;
3205 # elif defined(__OpenBSD__)
3206 /* There may be a better way on OpenBSD:
3207 - we could insert a dummy func in the _close function entry
3208 f->_close = (int (*)(void *)) dummy_close;
3212 # elif defined(__EMX__)
3213 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3216 # elif defined(__CYGWIN__)
3217 /* There may be a better way on CYGWIN:
3218 - we could insert a dummy func in the _close function entry
3219 f->_close = (int (*)(void *)) dummy_close;
3223 # elif defined(WIN32)
3224 # if defined(UNDER_CE)
3225 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3234 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3235 (which isn't thread safe) instead
3237 # error "Don't know how to set FILE.fileno on your platform"
3245 PerlIOStdio_close(pTHX_ PerlIO *f)
3247 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3253 const int fd = fileno(stdio);
3261 #ifdef SOCKS5_VERSION_NAME
3262 /* Socks lib overrides close() but stdio isn't linked to
3263 that library (though we are) - so we must call close()
3264 on sockets on stdio's behalf.
3267 Sock_size_t optlen = sizeof(int);
3268 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3271 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3272 that a subsequent fileno() on it returns -1. Don't want to croak()
3273 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3274 trying to close an already closed handle which somehow it still has
3275 a reference to. (via.xs, I'm looking at you). */
3276 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3277 /* File descriptor still in use */
3281 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3282 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3284 if (stdio == stdout || stdio == stderr)
3285 return PerlIO_flush(f);
3286 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3287 Use Sarathy's trick from maint-5.6 to invalidate the
3288 fileno slot of the FILE *
3290 result = PerlIO_flush(f);
3292 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3295 MUTEX_LOCK(&PL_perlio_mutex);
3296 /* Right. We need a mutex here because for a brief while we
3297 will have the situation that fd is actually closed. Hence if
3298 a second thread were to get into this block, its dup() would
3299 likely return our fd as its dupfd. (after all, it is closed)
3300 Then if we get to the dup2() first, we blat the fd back
3301 (messing up its temporary as a side effect) only for it to
3302 then close its dupfd (== our fd) in its close(dupfd) */
3304 /* There is, of course, a race condition, that any other thread
3305 trying to input/output/whatever on this fd will be stuffed
3306 for the duration of this little manoeuvrer. Perhaps we
3307 should hold an IO mutex for the duration of every IO
3308 operation if we know that invalidate doesn't work on this
3309 platform, but that would suck, and could kill performance.
3311 Except that correctness trumps speed.
3312 Advice from klortho #11912. */
3314 dupfd = PerlLIO_dup(fd);
3317 MUTEX_UNLOCK(&PL_perlio_mutex);
3318 /* Oh cXap. This isn't going to go well. Not sure if we can
3319 recover from here, or if closing this particular FILE *
3320 is a good idea now. */
3325 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3327 result = PerlSIO_fclose(stdio);
3328 /* We treat error from stdio as success if we invalidated
3329 errno may NOT be expected EBADF
3331 if (invalidate && result != 0) {
3335 #ifdef SOCKS5_VERSION_NAME
3336 /* in SOCKS' case, let close() determine return value */
3340 PerlLIO_dup2(dupfd,fd);
3341 PerlLIO_close(dupfd);
3343 MUTEX_UNLOCK(&PL_perlio_mutex);
3351 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3356 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3358 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3361 STDCHAR *buf = (STDCHAR *) vbuf;
3363 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3364 * stdio does not do that for fread()
3366 const int ch = PerlSIO_fgetc(s);
3373 got = PerlSIO_fread(vbuf, 1, count, s);
3374 if (got == 0 && PerlSIO_ferror(s))
3376 if (got >= 0 || errno != EINTR)
3378 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3380 SETERRNO(0,0); /* just in case */
3386 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3389 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3391 #ifdef STDIO_BUFFER_WRITABLE
3392 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3393 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3394 STDCHAR *base = PerlIO_get_base(f);
3395 SSize_t cnt = PerlIO_get_cnt(f);
3396 STDCHAR *ptr = PerlIO_get_ptr(f);
3397 SSize_t avail = ptr - base;
3399 if (avail > count) {
3403 Move(buf-avail,ptr,avail,STDCHAR);
3406 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3407 if (PerlSIO_feof(s) && unread >= 0)
3408 PerlSIO_clearerr(s);
3413 if (PerlIO_has_cntptr(f)) {
3414 /* We can get pointer to buffer but not its base
3415 Do ungetc() but check chars are ending up in the
3418 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3419 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3421 const int ch = *--buf & 0xFF;
3422 if (ungetc(ch,s) != ch) {
3423 /* ungetc did not work */
3426 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3427 /* Did not change pointer as expected */
3428 fgetc(s); /* get char back again */
3438 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3444 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3448 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3451 got = PerlSIO_fwrite(vbuf, 1, count,
3452 PerlIOSelf(f, PerlIOStdio)->stdio);
3453 if (got >= 0 || errno != EINTR)
3455 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3457 SETERRNO(0,0); /* just in case */
3463 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3465 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3466 PERL_UNUSED_CONTEXT;
3468 return PerlSIO_fseek(stdio, offset, whence);
3472 PerlIOStdio_tell(pTHX_ PerlIO *f)
3474 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3475 PERL_UNUSED_CONTEXT;
3477 return PerlSIO_ftell(stdio);
3481 PerlIOStdio_flush(pTHX_ PerlIO *f)
3483 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3484 PERL_UNUSED_CONTEXT;
3486 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3487 return PerlSIO_fflush(stdio);
3493 * FIXME: This discards ungetc() and pre-read stuff which is not
3494 * right if this is just a "sync" from a layer above Suspect right
3495 * design is to do _this_ but not have layer above flush this
3496 * layer read-to-read
3499 * Not writeable - sync by attempting a seek
3502 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3510 PerlIOStdio_eof(pTHX_ PerlIO *f)
3512 PERL_UNUSED_CONTEXT;
3514 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3518 PerlIOStdio_error(pTHX_ PerlIO *f)
3520 PERL_UNUSED_CONTEXT;
3522 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3526 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3528 PERL_UNUSED_CONTEXT;
3530 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3534 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3536 PERL_UNUSED_CONTEXT;
3538 #ifdef HAS_SETLINEBUF
3539 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3541 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3547 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3549 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3550 return (STDCHAR*)PerlSIO_get_base(stdio);
3554 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3556 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3557 return PerlSIO_get_bufsiz(stdio);
3561 #ifdef USE_STDIO_PTR
3563 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3565 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3566 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3570 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3572 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3573 return PerlSIO_get_cnt(stdio);
3577 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3579 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3581 #ifdef STDIO_PTR_LVALUE
3582 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3583 #ifdef STDIO_PTR_LVAL_SETS_CNT
3584 assert(PerlSIO_get_cnt(stdio) == (cnt));
3586 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3588 * Setting ptr _does_ change cnt - we are done
3592 #else /* STDIO_PTR_LVALUE */
3594 #endif /* STDIO_PTR_LVALUE */
3597 * Now (or only) set cnt
3599 #ifdef STDIO_CNT_LVALUE
3600 PerlSIO_set_cnt(stdio, cnt);
3601 #else /* STDIO_CNT_LVALUE */
3602 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3603 PerlSIO_set_ptr(stdio,
3604 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3606 #else /* STDIO_PTR_LVAL_SETS_CNT */
3608 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3609 #endif /* STDIO_CNT_LVALUE */
3616 PerlIOStdio_fill(pTHX_ PerlIO *f)
3620 PERL_UNUSED_CONTEXT;
3621 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3623 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3626 * fflush()ing read-only streams can cause trouble on some stdio-s
3628 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3629 if (PerlSIO_fflush(stdio) != 0)
3633 c = PerlSIO_fgetc(stdio);
3636 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3638 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3643 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3645 #ifdef STDIO_BUFFER_WRITABLE
3646 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3647 /* Fake ungetc() to the real buffer in case system's ungetc
3650 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3651 SSize_t cnt = PerlSIO_get_cnt(stdio);
3652 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3653 if (ptr == base+1) {
3654 *--ptr = (STDCHAR) c;
3655 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3656 if (PerlSIO_feof(stdio))
3657 PerlSIO_clearerr(stdio);
3663 if (PerlIO_has_cntptr(f)) {
3665 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3672 /* An ungetc()d char is handled separately from the regular
3673 * buffer, so we stuff it in the buffer ourselves.
3674 * Should never get called as should hit code above
3676 *(--((*stdio)->_ptr)) = (unsigned char) c;
3679 /* If buffer snoop scheme above fails fall back to
3682 if (PerlSIO_ungetc(c, stdio) != c)
3690 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3691 sizeof(PerlIO_funcs),
3693 sizeof(PerlIOStdio),
3694 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3698 PerlIOBase_binmode, /* binmode */
3712 PerlIOStdio_clearerr,
3713 PerlIOStdio_setlinebuf,
3715 PerlIOStdio_get_base,
3716 PerlIOStdio_get_bufsiz,
3721 #ifdef USE_STDIO_PTR
3722 PerlIOStdio_get_ptr,
3723 PerlIOStdio_get_cnt,
3724 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3725 PerlIOStdio_set_ptrcnt,
3728 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3733 #endif /* USE_STDIO_PTR */
3736 /* Note that calls to PerlIO_exportFILE() are reversed using
3737 * PerlIO_releaseFILE(), not importFILE. */
3739 PerlIO_exportFILE(PerlIO * f, const char *mode)
3743 if (PerlIOValid(f)) {
3746 if (!mode || !*mode) {
3747 mode = PerlIO_modestr(f, buf);
3749 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3753 /* De-link any lower layers so new :stdio sticks */
3755 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3756 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3758 PerlIOUnix_refcnt_inc(fileno(stdio));
3759 /* Link previous lower layers under new one */
3763 /* restore layers list */
3773 PerlIO_findFILE(PerlIO *f)
3778 if (l->tab == &PerlIO_stdio) {
3779 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3782 l = *PerlIONext(&l);
3784 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3785 /* However, we're not really exporting a FILE * to someone else (who
3786 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3787 So we need to undo its reference count increase on the underlying file
3788 descriptor. We have to do this, because if the loop above returns you
3789 the FILE *, then *it* didn't increase any reference count. So there's
3790 only one way to be consistent. */
3791 stdio = PerlIO_exportFILE(f, NULL);
3793 const int fd = fileno(stdio);
3795 PerlIOUnix_refcnt_dec(fd);
3800 /* Use this to reverse PerlIO_exportFILE calls. */
3802 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3807 if (l->tab == &PerlIO_stdio) {
3808 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3809 if (s->stdio == f) {
3811 const int fd = fileno(f);
3813 PerlIOUnix_refcnt_dec(fd);
3814 PerlIO_pop(aTHX_ p);
3823 /*--------------------------------------------------------------------------------------*/
3825 * perlio buffer layer
3829 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3831 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3832 const int fd = PerlIO_fileno(f);
3833 if (fd >= 0 && PerlLIO_isatty(fd)) {
3834 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3836 if (*PerlIONext(f)) {
3837 const Off_t posn = PerlIO_tell(PerlIONext(f));
3838 if (posn != (Off_t) - 1) {
3842 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3846 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3847 IV n, const char *mode, int fd, int imode, int perm,
3848 PerlIO *f, int narg, SV **args)
3850 if (PerlIOValid(f)) {
3851 PerlIO *next = PerlIONext(f);
3853 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3854 if (tab && tab->Open)
3856 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3858 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3863 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3865 if (*mode == IoTYPE_IMPLICIT) {
3871 if (tab && tab->Open)
3872 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3875 SETERRNO(EINVAL, LIB_INVARG);
3877 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3879 * if push fails during open, open fails. close will pop us.
3884 fd = PerlIO_fileno(f);
3885 if (init && fd == 2) {
3887 * Initial stderr is unbuffered
3889 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3891 #ifdef PERLIO_USING_CRLF
3892 # ifdef PERLIO_IS_BINMODE_FD
3893 if (PERLIO_IS_BINMODE_FD(fd))
3894 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3898 * do something about failing setmode()? --jhi
3900 PerlLIO_setmode(fd, O_BINARY);
3904 /* Enable line buffering with record-oriented regular files
3905 * so we don't introduce an extraneous record boundary when
3906 * the buffer fills up.
3908 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3910 if (PerlLIO_fstat(fd, &st) == 0
3911 && S_ISREG(st.st_mode)
3912 && (st.st_fab_rfm == FAB$C_VAR
3913 || st.st_fab_rfm == FAB$C_VFC)) {
3914 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3925 * This "flush" is akin to sfio's sync in that it handles files in either
3926 * read or write state. For write state, we put the postponed data through
3927 * the next layers. For read state, we seek() the next layers to the
3928 * offset given by current position in the buffer, and discard the buffer
3929 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3930 * in any case?). Then the pass the stick further in chain.
3933 PerlIOBuf_flush(pTHX_ PerlIO *f)
3935 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3937 PerlIO *n = PerlIONext(f);
3938 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3940 * write() the buffer
3942 const STDCHAR *buf = b->buf;
3943 const STDCHAR *p = buf;
3944 while (p < b->ptr) {
3945 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3949 else if (count < 0 || PerlIO_error(n)) {
3950 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3955 b->posn += (p - buf);
3957 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3958 STDCHAR *buf = PerlIO_get_base(f);
3960 * Note position change
3962 b->posn += (b->ptr - buf);
3963 if (b->ptr < b->end) {
3964 /* We did not consume all of it - try and seek downstream to
3965 our logical position
3967 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3968 /* Reload n as some layers may pop themselves on seek */
3969 b->posn = PerlIO_tell(n = PerlIONext(f));
3972 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3973 data is lost for good - so return saying "ok" having undone
3976 b->posn -= (b->ptr - buf);
3981 b->ptr = b->end = b->buf;
3982 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3983 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3984 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3989 /* This discards the content of the buffer after b->ptr, and rereads
3990 * the buffer from the position off in the layer downstream; here off
3991 * is at offset corresponding to b->ptr - b->buf.
3994 PerlIOBuf_fill(pTHX_ PerlIO *f)
3996 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3997 PerlIO *n = PerlIONext(f);
4000 * Down-stream flush is defined not to loose read data so is harmless.
4001 * we would not normally be fill'ing if there was data left in anycase.
4003 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4005 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4006 PerlIOBase_flush_linebuf(aTHX);
4009 PerlIO_get_base(f); /* allocate via vtable */
4011 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4013 b->ptr = b->end = b->buf;
4015 if (!PerlIOValid(n)) {
4016 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4020 if (PerlIO_fast_gets(n)) {
4022 * Layer below is also buffered. We do _NOT_ want to call its
4023 * ->Read() because that will loop till it gets what we asked for
4024 * which may hang on a pipe etc. Instead take anything it has to
4025 * hand, or ask it to fill _once_.
4027 avail = PerlIO_get_cnt(n);
4029 avail = PerlIO_fill(n);
4031 avail = PerlIO_get_cnt(n);
4033 if (!PerlIO_error(n) && PerlIO_eof(n))
4038 STDCHAR *ptr = PerlIO_get_ptr(n);
4039 const SSize_t cnt = avail;
4040 if (avail > (SSize_t)b->bufsiz)
4042 Copy(ptr, b->buf, avail, STDCHAR);
4043 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4047 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4051 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4053 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4056 b->end = b->buf + avail;
4057 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4062 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4064 if (PerlIOValid(f)) {
4065 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4068 return PerlIOBase_read(aTHX_ f, vbuf, count);
4074 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4076 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4077 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4080 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4085 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4087 * Buffer is already a read buffer, we can overwrite any chars
4088 * which have been read back to buffer start
4090 avail = (b->ptr - b->buf);
4094 * Buffer is idle, set it up so whole buffer is available for
4098 b->end = b->buf + avail;
4100 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4102 * Buffer extends _back_ from where we are now
4104 b->posn -= b->bufsiz;
4106 if (avail > (SSize_t) count) {
4108 * If we have space for more than count, just move count
4116 * In simple stdio-like ungetc() case chars will be already
4119 if (buf != b->ptr) {
4120 Copy(buf, b->ptr, avail, STDCHAR);
4124 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4128 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4134 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4136 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4137 const STDCHAR *buf = (const STDCHAR *) vbuf;
4138 const STDCHAR *flushptr = buf;
4142 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4144 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4145 if (PerlIO_flush(f) != 0) {
4149 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4150 flushptr = buf + count;
4151 while (flushptr > buf && *(flushptr - 1) != '\n')
4155 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4156 if ((SSize_t) count < avail)
4158 if (flushptr > buf && flushptr <= buf + avail)
4159 avail = flushptr - buf;
4160 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4162 Copy(buf, b->ptr, avail, STDCHAR);
4167 if (buf == flushptr)
4170 if (b->ptr >= (b->buf + b->bufsiz))
4171 if (PerlIO_flush(f) == -1)
4174 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4180 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4183 if ((code = PerlIO_flush(f)) == 0) {
4184 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4185 code = PerlIO_seek(PerlIONext(f), offset, whence);
4187 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4188 b->posn = PerlIO_tell(PerlIONext(f));
4195 PerlIOBuf_tell(pTHX_ PerlIO *f)
4197 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4199 * b->posn is file position where b->buf was read, or will be written
4201 Off_t posn = b->posn;
4202 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4203 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4205 /* As O_APPEND files are normally shared in some sense it is better
4210 /* when file is NOT shared then this is sufficient */
4211 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4213 posn = b->posn = PerlIO_tell(PerlIONext(f));
4217 * If buffer is valid adjust position by amount in buffer
4219 posn += (b->ptr - b->buf);
4225 PerlIOBuf_popped(pTHX_ PerlIO *f)
4227 const IV code = PerlIOBase_popped(aTHX_ f);
4228 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4229 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4232 b->ptr = b->end = b->buf = NULL;
4233 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4238 PerlIOBuf_close(pTHX_ PerlIO *f)
4240 const IV code = PerlIOBase_close(aTHX_ f);
4241 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4242 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4245 b->ptr = b->end = b->buf = NULL;
4246 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4251 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4253 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4260 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4262 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4265 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4266 return (b->end - b->ptr);
4271 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4273 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4274 PERL_UNUSED_CONTEXT;
4278 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4279 Newxz(b->buf,b->bufsiz, STDCHAR);
4281 b->buf = (STDCHAR *) & b->oneword;
4282 b->bufsiz = sizeof(b->oneword);
4284 b->end = b->ptr = b->buf;
4290 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4292 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4295 return (b->end - b->buf);
4299 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4301 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4303 PERL_UNUSED_ARG(cnt);
4308 assert(PerlIO_get_cnt(f) == cnt);
4309 assert(b->ptr >= b->buf);
4310 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4314 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4316 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4321 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4322 sizeof(PerlIO_funcs),
4325 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4329 PerlIOBase_binmode, /* binmode */
4343 PerlIOBase_clearerr,
4344 PerlIOBase_setlinebuf,
4349 PerlIOBuf_set_ptrcnt,
4352 /*--------------------------------------------------------------------------------------*/
4354 * Temp layer to hold unread chars when cannot do it any other way
4358 PerlIOPending_fill(pTHX_ PerlIO *f)
4361 * Should never happen
4368 PerlIOPending_close(pTHX_ PerlIO *f)
4371 * A tad tricky - flush pops us, then we close new top
4374 return PerlIO_close(f);
4378 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4381 * A tad tricky - flush pops us, then we seek new top
4384 return PerlIO_seek(f, offset, whence);
4389 PerlIOPending_flush(pTHX_ PerlIO *f)
4391 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4392 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4396 PerlIO_pop(aTHX_ f);
4401 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4407 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4412 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4414 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4415 PerlIOl * const l = PerlIOBase(f);
4417 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4418 * etc. get muddled when it changes mid-string when we auto-pop.
4420 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4421 (PerlIOBase(PerlIONext(f))->
4422 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4427 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4429 SSize_t avail = PerlIO_get_cnt(f);
4431 if ((SSize_t)count < avail)
4434 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4435 if (got >= 0 && got < (SSize_t)count) {
4436 const SSize_t more =
4437 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4438 if (more >= 0 || got == 0)
4444 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4445 sizeof(PerlIO_funcs),
4448 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4449 PerlIOPending_pushed,
4452 PerlIOBase_binmode, /* binmode */
4461 PerlIOPending_close,
4462 PerlIOPending_flush,
4466 PerlIOBase_clearerr,
4467 PerlIOBase_setlinebuf,
4472 PerlIOPending_set_ptrcnt,
4477 /*--------------------------------------------------------------------------------------*/
4479 * crlf - translation On read translate CR,LF to "\n" we do this by
4480 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4481 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4483 * c->nl points on the first byte of CR LF pair when it is temporarily
4484 * replaced by LF, or to the last CR of the buffer. In the former case
4485 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4486 * that it ends at c->nl; these two cases can be distinguished by
4487 * *c->nl. c->nl is set during _getcnt() call, and unset during
4488 * _unread() and _flush() calls.
4489 * It only matters for read operations.
4493 PerlIOBuf base; /* PerlIOBuf stuff */
4494 STDCHAR *nl; /* Position of crlf we "lied" about in the
4498 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4499 * Otherwise the :crlf layer would always revert back to
4503 S_inherit_utf8_flag(PerlIO *f)
4505 PerlIO *g = PerlIONext(f);
4506 if (PerlIOValid(g)) {
4507 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4508 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4514 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4517 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4518 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4520 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4521 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4522 PerlIOBase(f)->flags);
4525 /* If the old top layer is a CRLF layer, reactivate it (if
4526 * necessary) and remove this new layer from the stack */
4527 PerlIO *g = PerlIONext(f);
4528 if (PerlIOValid(g)) {
4529 PerlIOl *b = PerlIOBase(g);
4530 if (b && b->tab == &PerlIO_crlf) {
4531 if (!(b->flags & PERLIO_F_CRLF))
4532 b->flags |= PERLIO_F_CRLF;
4533 S_inherit_utf8_flag(g);
4534 PerlIO_pop(aTHX_ f);
4539 S_inherit_utf8_flag(f);
4545 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4547 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4548 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4552 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4553 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4555 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4556 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4558 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4563 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4564 b->end = b->ptr = b->buf + b->bufsiz;
4565 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4566 b->posn -= b->bufsiz;
4568 while (count > 0 && b->ptr > b->buf) {
4569 const int ch = *--buf;
4571 if (b->ptr - 2 >= b->buf) {
4578 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4579 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4595 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4597 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4599 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4602 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4603 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4604 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4605 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4607 while (nl < b->end && *nl != 0xd)
4609 if (nl < b->end && *nl == 0xd) {
4611 if (nl + 1 < b->end) {
4618 * Not CR,LF but just CR
4626 * Blast - found CR as last char in buffer
4631 * They may not care, defer work as long as
4635 return (nl - b->ptr);
4639 b->ptr++; /* say we have read it as far as
4640 * flush() is concerned */
4641 b->buf++; /* Leave space in front of buffer */
4642 /* Note as we have moved buf up flush's
4644 will naturally make posn point at CR
4646 b->bufsiz--; /* Buffer is thus smaller */
4647 code = PerlIO_fill(f); /* Fetch some more */
4648 b->bufsiz++; /* Restore size for next time */
4649 b->buf--; /* Point at space */
4650 b->ptr = nl = b->buf; /* Which is what we hand
4652 *nl = 0xd; /* Fill in the CR */
4654 goto test; /* fill() call worked */
4656 * CR at EOF - just fall through
4658 /* Should we clear EOF though ??? */
4663 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4669 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4671 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4672 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4678 if (ptr == b->end && *c->nl == 0xd) {
4679 /* Deferred CR at end of buffer case - we lied about count */
4692 * Test code - delete when it works ...
4694 IV flags = PerlIOBase(f)->flags;
4695 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4696 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4697 /* Deferred CR at end of buffer case - we lied about count */
4703 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4704 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4705 flags, c->nl, b->end, cnt);
4712 * They have taken what we lied about
4720 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4724 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4726 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4727 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4729 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4730 const STDCHAR *buf = (const STDCHAR *) vbuf;
4731 const STDCHAR * const ebuf = buf + count;
4734 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4736 while (buf < ebuf) {
4737 const STDCHAR * const eptr = b->buf + b->bufsiz;
4738 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4739 while (buf < ebuf && b->ptr < eptr) {
4741 if ((b->ptr + 2) > eptr) {
4749 *(b->ptr)++ = 0xd; /* CR */
4750 *(b->ptr)++ = 0xa; /* LF */
4752 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4759 *(b->ptr)++ = *buf++;
4761 if (b->ptr >= eptr) {
4767 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4769 return (buf - (STDCHAR *) vbuf);
4774 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4776 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4781 return PerlIOBuf_flush(aTHX_ f);
4785 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4787 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4788 /* In text mode - flush any pending stuff and flip it */
4789 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4790 #ifndef PERLIO_USING_CRLF
4791 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4792 PerlIO_pop(aTHX_ f);
4798 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4799 sizeof(PerlIO_funcs),
4802 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4804 PerlIOBuf_popped, /* popped */
4806 PerlIOCrlf_binmode, /* binmode */
4810 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4811 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4812 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4820 PerlIOBase_clearerr,
4821 PerlIOBase_setlinebuf,
4826 PerlIOCrlf_set_ptrcnt,
4830 /*--------------------------------------------------------------------------------------*/
4832 * mmap as "buffer" layer
4836 PerlIOBuf base; /* PerlIOBuf stuff */
4837 Mmap_t mptr; /* Mapped address */
4838 Size_t len; /* mapped length */
4839 STDCHAR *bbuf; /* malloced buffer if map fails */
4843 PerlIOMmap_map(pTHX_ PerlIO *f)
4846 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4847 const IV flags = PerlIOBase(f)->flags;
4851 if (flags & PERLIO_F_CANREAD) {
4852 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4853 const int fd = PerlIO_fileno(f);
4855 code = Fstat(fd, &st);
4856 if (code == 0 && S_ISREG(st.st_mode)) {
4857 SSize_t len = st.st_size - b->posn;
4860 if (PL_mmap_page_size <= 0)
4861 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4865 * This is a hack - should never happen - open should
4868 b->posn = PerlIO_tell(PerlIONext(f));
4870 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4871 len = st.st_size - posn;
4872 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4873 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4874 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4875 madvise(m->mptr, len, MADV_SEQUENTIAL);
4877 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4878 madvise(m->mptr, len, MADV_WILLNEED);
4880 PerlIOBase(f)->flags =
4881 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4882 b->end = ((STDCHAR *) m->mptr) + len;
4883 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4892 PerlIOBase(f)->flags =
4893 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4895 b->ptr = b->end = b->ptr;
4904 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4906 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4909 PerlIOBuf * const b = &m->base;
4911 /* The munmap address argument is tricky: depending on the
4912 * standard it is either "void *" or "caddr_t" (which is
4913 * usually "char *" (signed or unsigned). If we cast it
4914 * to "void *", those that have it caddr_t and an uptight
4915 * C++ compiler, will freak out. But casting it as char*
4916 * should work. Maybe. (Using Mmap_t figured out by
4917 * Configure doesn't always work, apparently.) */
4918 code = munmap((char*)m->mptr, m->len);
4922 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4925 b->ptr = b->end = b->buf;
4926 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4932 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4934 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4935 PerlIOBuf * const b = &m->base;
4936 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4938 * Already have a readbuffer in progress
4944 * We have a write buffer or flushed PerlIOBuf read buffer
4946 m->bbuf = b->buf; /* save it in case we need it again */
4947 b->buf = NULL; /* Clear to trigger below */
4950 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4953 * Map did not work - recover PerlIOBuf buffer if we have one
4958 b->ptr = b->end = b->buf;
4961 return PerlIOBuf_get_base(aTHX_ f);
4965 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4967 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4968 PerlIOBuf * const b = &m->base;
4969 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4971 if (b->ptr && (b->ptr - count) >= b->buf
4972 && memEQ(b->ptr - count, vbuf, count)) {
4974 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4979 * Loose the unwritable mapped buffer
4983 * If flush took the "buffer" see if we have one from before
4985 if (!b->buf && m->bbuf)
4988 PerlIOBuf_get_base(aTHX_ f);
4992 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4996 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4998 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4999 PerlIOBuf * const b = &m->base;
5001 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
5003 * No, or wrong sort of, buffer
5006 if (PerlIOMmap_unmap(aTHX_ f) != 0)
5010 * If unmap took the "buffer" see if we have one from before
5012 if (!b->buf && m->bbuf)
5015 PerlIOBuf_get_base(aTHX_ f);
5019 return PerlIOBuf_write(aTHX_ f, vbuf, count);
5023 PerlIOMmap_flush(pTHX_ PerlIO *f)
5025 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5026 PerlIOBuf * const b = &m->base;
5027 IV code = PerlIOBuf_flush(aTHX_ f);
5029 * Now we are "synced" at PerlIOBuf level
5036 if (PerlIOMmap_unmap(aTHX_ f) != 0)
5041 * We seem to have a PerlIOBuf buffer which was not mapped
5042 * remember it in case we need one later
5051 PerlIOMmap_fill(pTHX_ PerlIO *f)
5053 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
5054 IV code = PerlIO_flush(f);
5055 if (code == 0 && !b->buf) {
5056 code = PerlIOMmap_map(aTHX_ f);
5058 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
5059 code = PerlIOBuf_fill(aTHX_ f);
5065 PerlIOMmap_close(pTHX_ PerlIO *f)
5067 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
5068 PerlIOBuf * const b = &m->base;
5069 IV code = PerlIO_flush(f);
5073 b->ptr = b->end = b->buf;
5075 if (PerlIOBuf_close(aTHX_ f) != 0)
5081 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
5083 return PerlIOBase_dup(aTHX_ f, o, param, flags);
5087 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
5088 sizeof(PerlIO_funcs),
5091 PERLIO_K_BUFFERED|PERLIO_K_RAW,
5095 PerlIOBase_binmode, /* binmode */
5109 PerlIOBase_clearerr,
5110 PerlIOBase_setlinebuf,
5111 PerlIOMmap_get_base,
5115 PerlIOBuf_set_ptrcnt,
5118 #endif /* HAS_MMAP */
5121 Perl_PerlIO_stdin(pTHX)
5125 PerlIO_stdstreams(aTHX);
5127 return (PerlIO*)&PL_perlio[1];
5131 Perl_PerlIO_stdout(pTHX)
5135 PerlIO_stdstreams(aTHX);
5137 return (PerlIO*)&PL_perlio[2];
5141 Perl_PerlIO_stderr(pTHX)
5145 PerlIO_stdstreams(aTHX);
5147 return (PerlIO*)&PL_perlio[3];
5150 /*--------------------------------------------------------------------------------------*/
5153 PerlIO_getname(PerlIO *f, char *buf)
5158 bool exported = FALSE;
5159 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
5161 stdio = PerlIO_exportFILE(f,0);
5165 name = fgetname(stdio, buf);
5166 if (exported) PerlIO_releaseFILE(f,stdio);
5171 PERL_UNUSED_ARG(buf);
5172 Perl_croak(aTHX_ "Don't know how to get file name");
5178 /*--------------------------------------------------------------------------------------*/
5180 * Functions which can be called on any kind of PerlIO implemented in
5184 #undef PerlIO_fdopen
5186 PerlIO_fdopen(int fd, const char *mode)
5189 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
5194 PerlIO_open(const char *path, const char *mode)
5197 SV *name = sv_2mortal(newSVpv(path, 0));
5198 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5201 #undef Perlio_reopen
5203 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5206 SV *name = sv_2mortal(newSVpv(path,0));
5207 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5212 PerlIO_getc(PerlIO *f)
5216 if ( 1 == PerlIO_read(f, buf, 1) ) {
5217 return (unsigned char) buf[0];
5222 #undef PerlIO_ungetc
5224 PerlIO_ungetc(PerlIO *f, int ch)
5229 if (PerlIO_unread(f, &buf, 1) == 1)
5237 PerlIO_putc(PerlIO *f, int ch)
5241 return PerlIO_write(f, &buf, 1);
5246 PerlIO_puts(PerlIO *f, const char *s)
5249 return PerlIO_write(f, s, strlen(s));
5252 #undef PerlIO_rewind
5254 PerlIO_rewind(PerlIO *f)
5257 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5261 #undef PerlIO_vprintf
5263 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5272 Perl_va_copy(ap, apc);
5273 sv = vnewSVpvf(fmt, &apc);
5275 sv = vnewSVpvf(fmt, &ap);
5277 s = SvPV_const(sv, len);
5278 wrote = PerlIO_write(f, s, len);
5283 #undef PerlIO_printf
5285 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5290 result = PerlIO_vprintf(f, fmt, ap);
5295 #undef PerlIO_stdoutf
5297 PerlIO_stdoutf(const char *fmt, ...)
5303 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5308 #undef PerlIO_tmpfile
5310 PerlIO_tmpfile(void)
5315 const int fd = win32_tmpfd();
5317 f = PerlIO_fdopen(fd, "w+b");
5319 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5321 char tempname[] = "/tmp/PerlIO_XXXXXX";
5322 const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR");
5325 * I have no idea how portable mkstemp() is ... NI-S
5327 if (tmpdir && *tmpdir) {
5328 /* if TMPDIR is set and not empty, we try that first */
5329 sv = newSVpv(tmpdir, 0);
5330 sv_catpv(sv, tempname + 4);
5331 fd = mkstemp(SvPVX(sv));
5335 /* else we try /tmp */
5336 fd = mkstemp(tempname);
5339 f = PerlIO_fdopen(fd, "w+");
5341 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5342 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5345 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5346 FILE * const stdio = PerlSIO_tmpfile();
5349 f = PerlIO_fdopen(fileno(stdio), "w+");
5351 # endif /* else HAS_MKSTEMP */
5352 #endif /* else WIN32 */
5359 #endif /* USE_SFIO */
5360 #endif /* PERLIO_IS_STDIO */
5362 /*======================================================================================*/
5364 * Now some functions in terms of above which may be needed even if we are
5365 * not in true PerlIO mode
5368 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5371 const char *direction = NULL;
5374 * Need to supply default layer info from open.pm
5380 if (mode && mode[0] != 'r') {
5381 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5382 direction = "open>";
5384 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5385 direction = "open<";
5390 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5393 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5398 #undef PerlIO_setpos
5400 PerlIO_setpos(PerlIO *f, SV *pos)
5405 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5406 if (f && len == sizeof(Off_t))
5407 return PerlIO_seek(f, *posn, SEEK_SET);
5409 SETERRNO(EINVAL, SS_IVCHAN);
5413 #undef PerlIO_setpos
5415 PerlIO_setpos(PerlIO *f, SV *pos)
5420 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5421 if (f && len == sizeof(Fpos_t)) {
5422 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5423 return fsetpos64(f, fpos);
5425 return fsetpos(f, fpos);
5429 SETERRNO(EINVAL, SS_IVCHAN);
5435 #undef PerlIO_getpos
5437 PerlIO_getpos(PerlIO *f, SV *pos)
5440 Off_t posn = PerlIO_tell(f);
5441 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5442 return (posn == (Off_t) - 1) ? -1 : 0;
5445 #undef PerlIO_getpos
5447 PerlIO_getpos(PerlIO *f, SV *pos)
5452 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5453 code = fgetpos64(f, &fpos);
5455 code = fgetpos(f, &fpos);
5457 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5462 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5465 vprintf(char *pat, char *args)
5467 _doprnt(pat, args, stdout);
5468 return 0; /* wrong, but perl doesn't use the return
5473 vfprintf(FILE *fd, char *pat, char *args)
5475 _doprnt(pat, args, fd);
5476 return 0; /* wrong, but perl doesn't use the return
5482 #ifndef PerlIO_vsprintf
5484 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5487 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5488 PERL_UNUSED_CONTEXT;
5490 #ifndef PERL_MY_VSNPRINTF_GUARDED
5491 if (val < 0 || (n > 0 ? val >= n : 0)) {
5492 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5499 #ifndef PerlIO_sprintf
5501 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5506 result = PerlIO_vsprintf(s, n, fmt, ap);
5514 * c-indentation-style: bsd
5516 * indent-tabs-mode: t
5519 * ex: set ts=8 sts=4 sw=4 noet: