3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 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.
15 /* This file contains the functions needed to implement PerlIO, which
16 * is Perl's private replacement for the C stdio library. This is used
17 * by default unless you compile with -Uuseperlio or run with
18 * PERLIO=:stdio (but don't do this unless you know what you're doing)
22 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
23 * at the dispatch tables, even when we do not need it for other reasons.
24 * Invent a dSYS macro to abstract this out
26 #ifdef PERL_IMPLICIT_SYS
36 # ifndef USE_CROSS_COMPILE
43 #define PERLIO_NOT_STDIO 0
44 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
50 * This file provides those parts of PerlIO abstraction
51 * which are not #defined in perlio.h.
52 * Which these are depends on various Configure #ifdef's
56 #define PERL_IN_PERLIO_C
59 #ifdef PERL_IMPLICIT_CONTEXT
67 /* Missing proto on LynxOS */
71 /* Call the callback or PerlIOBase, and return failure. */
72 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
73 if (PerlIOValid(f)) { \
74 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
75 if (tab && tab->callback) \
76 return (*tab->callback) args; \
78 return PerlIOBase_ ## base args; \
81 SETERRNO(EBADF, SS_IVCHAN); \
84 /* Call the callback or fail, and return failure. */
85 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
86 if (PerlIOValid(f)) { \
87 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
88 if (tab && tab->callback) \
89 return (*tab->callback) args; \
90 SETERRNO(EINVAL, LIB_INVARG); \
93 SETERRNO(EBADF, SS_IVCHAN); \
96 /* Call the callback or PerlIOBase, and be void. */
97 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
98 if (PerlIOValid(f)) { \
99 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
100 if (tab && tab->callback) \
101 (*tab->callback) args; \
103 PerlIOBase_ ## base args; \
106 SETERRNO(EBADF, SS_IVCHAN)
108 /* Call the callback or fail, and be void. */
109 #define Perl_PerlIO_or_fail_void(f, callback, args) \
110 if (PerlIOValid(f)) { \
111 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
112 if (tab && tab->callback) \
113 (*tab->callback) args; \
115 SETERRNO(EINVAL, LIB_INVARG); \
118 SETERRNO(EBADF, SS_IVCHAN)
120 #if defined(__osf__) && _XOPEN_SOURCE < 500
121 extern int fseeko(FILE *, off_t, int);
122 extern off_t ftello(FILE *);
127 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
130 perlsio_binmode(FILE *fp, int iotype, int mode)
133 * This used to be contents of do_binmode in doio.c
136 # if defined(atarist) || defined(__MINT__)
137 PERL_UNUSED_ARG(iotype);
140 ((FILE *) fp)->_flag |= _IOBIN;
142 ((FILE *) fp)->_flag &= ~_IOBIN;
148 PERL_UNUSED_ARG(iotype);
150 if (PerlLIO_setmode(fp, mode) != -1) {
152 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
154 # if defined(WIN32) && defined(__BORLANDC__)
156 * The translation mode of the stream is maintained independent
158 * the translation mode of the fd in the Borland RTL (heavy
159 * digging through their runtime sources reveal). User has to
161 * the mode explicitly for the stream (though they don't
163 * this anywhere). GSAR 97-5-24
169 fp->flags &= ~_F_BIN;
177 # if defined(USEMYBINMODE)
179 # if defined(__CYGWIN__)
180 PERL_UNUSED_ARG(iotype);
182 if (my_binmode(fp, iotype, mode) != FALSE)
188 PERL_UNUSED_ARG(iotype);
189 PERL_UNUSED_ARG(mode);
197 #define O_ACCMODE 3 /* Assume traditional implementation */
201 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
203 const int result = rawmode & O_ACCMODE;
208 ptype = IoTYPE_RDONLY;
211 ptype = IoTYPE_WRONLY;
219 *writing = (result != O_RDONLY);
221 if (result == O_RDONLY) {
225 else if (rawmode & O_APPEND) {
227 if (result != O_WRONLY)
232 if (result == O_WRONLY)
239 if (rawmode & O_BINARY)
245 #ifndef PERLIO_LAYERS
247 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
249 if (!names || !*names
250 || strEQ(names, ":crlf")
251 || strEQ(names, ":raw")
252 || strEQ(names, ":bytes")
256 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
264 PerlIO_destruct(pTHX)
269 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
272 PERL_UNUSED_ARG(iotype);
273 PERL_UNUSED_ARG(mode);
274 PERL_UNUSED_ARG(names);
277 return perlsio_binmode(fp, iotype, mode);
282 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
284 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
287 #ifdef PERL_IMPLICIT_SYS
288 return PerlSIO_fdupopen(f);
291 return win32_fdupopen(f);
294 const int fd = PerlLIO_dup(PerlIO_fileno(f));
298 const int omode = djgpp_get_stream_mode(f);
300 const int omode = fcntl(fd, F_GETFL);
302 PerlIO_intmode2str(omode,mode,NULL);
303 /* the r+ is a hack */
304 return PerlIO_fdopen(fd, mode);
309 SETERRNO(EBADF, SS_IVCHAN);
319 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
323 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
324 int imode, int perm, PerlIO *old, int narg, SV **args)
328 Perl_croak(aTHX_ "More than one argument to open");
330 if (*args == &PL_sv_undef)
331 return PerlIO_tmpfile();
333 const char *name = SvPV_nolen_const(*args);
334 if (*mode == IoTYPE_NUMERIC) {
335 fd = PerlLIO_open3(name, imode, perm);
337 return PerlIO_fdopen(fd, mode + 1);
340 return PerlIO_reopen(name, mode, old);
343 return PerlIO_open(name, mode);
348 return PerlIO_fdopen(fd, (char *) mode);
353 XS(XS_PerlIO__Layer__find)
357 Perl_croak(aTHX_ "Usage class->find(name[,load])");
359 const char * const name = SvPV_nolen_const(ST(1));
360 ST(0) = (strEQ(name, "crlf")
361 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
368 Perl_boot_core_PerlIO(pTHX)
370 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
376 #ifdef PERLIO_IS_STDIO
383 * Does nothing (yet) except force this file to be included in perl
384 * binary. That allows this file to force inclusion of other functions
385 * that may be required by loadable extensions e.g. for
386 * FileHandle::tmpfile
390 #undef PerlIO_tmpfile
397 #else /* PERLIO_IS_STDIO */
405 * This section is just to make sure these functions get pulled in from
409 #undef PerlIO_tmpfile
421 * Force this file to be included in perl binary. Which allows this
422 * file to force inclusion of other functions that may be required by
423 * loadable extensions e.g. for FileHandle::tmpfile
427 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
428 * results in a lot of lseek()s to regular files and lot of small
431 sfset(sfstdout, SF_SHARE, 0);
434 /* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
436 PerlIO_importFILE(FILE *stdio, const char *mode)
438 const int fd = fileno(stdio);
439 if (!mode || !*mode) {
442 return PerlIO_fdopen(fd, mode);
446 PerlIO_findFILE(PerlIO *pio)
448 const int fd = PerlIO_fileno(pio);
449 FILE * const f = fdopen(fd, "r+");
451 if (!f && errno == EINVAL)
453 if (!f && errno == EINVAL)
460 /*======================================================================================*/
462 * Implement all the PerlIO interface ourselves.
468 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
475 #include <sys/mman.h>
479 PerlIO_debug(const char *fmt, ...)
484 if (!PL_perlio_debug_fd) {
485 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
486 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
489 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
491 PL_perlio_debug_fd = -1;
493 /* tainting or set*id, so ignore the environment, and ensure we
494 skip these tests next time through. */
495 PL_perlio_debug_fd = -1;
498 if (PL_perlio_debug_fd > 0) {
501 const char * const s = CopFILE(PL_curcop);
502 /* Use fixed buffer as sv_catpvf etc. needs SVs */
504 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
505 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
506 PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
508 const char *s = CopFILE(PL_curcop);
510 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
511 (IV) CopLINE(PL_curcop));
512 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
514 s = SvPV_const(sv, len);
515 PerlLIO_write(PL_perlio_debug_fd, s, len);
522 /*--------------------------------------------------------------------------------------*/
525 * Inner level routines
529 * Table of pointers to the PerlIO structs (malloc'ed)
531 #define PERLIO_TABLE_SIZE 64
534 PerlIO_allocate(pTHX)
538 * Find a free slot in the table, allocating new table as necessary
543 while ((f = *last)) {
545 last = (PerlIO **) (f);
546 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
552 Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
560 #undef PerlIO_fdupopen
562 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
564 if (PerlIOValid(f)) {
565 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
566 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
568 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
570 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
574 SETERRNO(EBADF, SS_IVCHAN);
580 PerlIO_cleantable(pTHX_ PerlIO **tablep)
582 PerlIO * const table = *tablep;
585 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
586 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
587 PerlIO * const f = table + i;
599 PerlIO_list_alloc(pTHX)
603 Newxz(list, 1, PerlIO_list_t);
609 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
612 if (--list->refcnt == 0) {
615 for (i = 0; i < list->cur; i++) {
616 if (list->array[i].arg)
617 SvREFCNT_dec(list->array[i].arg);
619 Safefree(list->array);
627 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
633 if (list->cur >= list->len) {
636 Renew(list->array, list->len, PerlIO_pair_t);
638 Newx(list->array, list->len, PerlIO_pair_t);
640 p = &(list->array[list->cur++]);
642 if ((p->arg = arg)) {
643 SvREFCNT_inc_simple_void_NN(arg);
648 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
650 PerlIO_list_t *list = NULL;
653 list = PerlIO_list_alloc(aTHX);
654 for (i=0; i < proto->cur; i++) {
655 SV *arg = proto->array[i].arg;
658 arg = sv_dup(arg, param);
660 PERL_UNUSED_ARG(param);
662 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
669 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
672 PerlIO **table = &proto->Iperlio;
675 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
676 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
677 PerlIO_allocate(aTHX); /* root slot is never used */
678 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
679 while ((f = *table)) {
681 table = (PerlIO **) (f++);
682 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
684 (void) fp_dup(f, 0, param);
691 PERL_UNUSED_ARG(proto);
692 PERL_UNUSED_ARG(param);
697 PerlIO_destruct(pTHX)
700 PerlIO **table = &PL_perlio;
703 PerlIO_debug("Destruct %p\n",(void*)aTHX);
705 while ((f = *table)) {
707 table = (PerlIO **) (f++);
708 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
712 if (l->tab->kind & PERLIO_K_DESTRUCT) {
713 PerlIO_debug("Destruct popping %s\n", l->tab->name);
727 PerlIO_pop(pTHX_ PerlIO *f)
729 const PerlIOl *l = *f;
731 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
732 if (l->tab->Popped) {
734 * If popped returns non-zero do not free its layer structure
735 * it has either done so itself, or it is shared and still in
738 if ((*l->tab->Popped) (aTHX_ f) != 0)
746 /* Return as an array the stack of layers on a filehandle. Note that
747 * the stack is returned top-first in the array, and there are three
748 * times as many array elements as there are layers in the stack: the
749 * first element of a layer triplet is the name, the second one is the
750 * arguments, and the third one is the flags. */
753 PerlIO_get_layers(pTHX_ PerlIO *f)
756 AV * const av = newAV();
758 if (PerlIOValid(f)) {
759 PerlIOl *l = PerlIOBase(f);
762 /* There is some collusion in the implementation of
763 XS_PerlIO_get_layers - it knows that name and flags are
764 generated as fresh SVs here, and takes advantage of that to
765 "copy" them by taking a reference. If it changes here, it needs
766 to change there too. */
767 SV * const name = l->tab && l->tab->name ?
768 newSVpv(l->tab->name, 0) : &PL_sv_undef;
769 SV * const arg = l->tab && l->tab->Getarg ?
770 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
773 av_push(av, newSViv((IV)l->flags));
781 /*--------------------------------------------------------------------------------------*/
783 * XS Interface for perl code
787 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
791 if ((SSize_t) len <= 0)
793 for (i = 0; i < PL_known_layers->cur; i++) {
794 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
795 if (memEQ(f->name, name, len) && f->name[len] == 0) {
796 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
800 if (load && PL_subname && PL_def_layerlist
801 && PL_def_layerlist->cur >= 2) {
802 if (PL_in_load_module) {
803 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
806 SV * const pkgsv = newSVpvs("PerlIO");
807 SV * const layer = newSVpvn(name, len);
808 CV * const cv = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
810 SAVEINT(PL_in_load_module);
812 SAVEGENERICSV(PL_warnhook);
813 PL_warnhook = (SV *) (SvREFCNT_inc_simple_NN(cv));
817 * The two SVs are magically freed by load_module
819 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
822 return PerlIO_find_layer(aTHX_ name, len, 0);
825 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
829 #ifdef USE_ATTRIBUTES_FOR_PERLIO
832 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
835 IO * const io = GvIOn((GV *) SvRV(sv));
836 PerlIO * const ifp = IoIFP(io);
837 PerlIO * const ofp = IoOFP(io);
838 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
839 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
845 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
848 IO * const io = GvIOn((GV *) SvRV(sv));
849 PerlIO * const ifp = IoIFP(io);
850 PerlIO * const ofp = IoOFP(io);
851 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
852 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
858 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
860 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
865 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
867 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
871 MGVTBL perlio_vtab = {
879 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
882 SV * const sv = SvRV(ST(1));
883 AV * const av = newAV();
887 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
889 mg = mg_find(sv, PERL_MAGIC_ext);
890 mg->mg_virtual = &perlio_vtab;
892 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
893 for (i = 2; i < items; i++) {
895 const char * const name = SvPV_const(ST(i), len);
896 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
898 av_push(av, SvREFCNT_inc_simple_NN(layer));
909 #endif /* USE_ATTIBUTES_FOR_PERLIO */
912 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
914 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
915 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
919 XS(XS_PerlIO__Layer__NoWarnings)
921 /* This is used as a %SIG{__WARN__} handler to supress warnings
922 during loading of layers.
928 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
932 XS(XS_PerlIO__Layer__find)
938 Perl_croak(aTHX_ "Usage class->find(name[,load])");
941 const char * const name = SvPV_const(ST(1), len);
942 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
943 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
945 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
952 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
955 if (!PL_known_layers)
956 PL_known_layers = PerlIO_list_alloc(aTHX);
957 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
958 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
962 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
966 const char *s = names;
968 while (isSPACE(*s) || *s == ':')
973 const char *as = NULL;
975 if (!isIDFIRST(*s)) {
977 * Message is consistent with how attribute lists are
978 * passed. Even though this means "foo : : bar" is
979 * seen as an invalid separator character.
981 const char q = ((*s == '\'') ? '"' : '\'');
982 if (ckWARN(WARN_LAYER))
983 Perl_warner(aTHX_ packWARN(WARN_LAYER),
984 "Invalid separator character %c%c%c in PerlIO layer specification %s",
986 SETERRNO(EINVAL, LIB_INVARG);
991 } while (isALNUM(*e));
1000 alen = (e - 1) - as;
1007 * It's a nul terminated string, not allowed
1008 * to \ the terminating null. Anything other
1009 * character is passed over.
1019 if (ckWARN(WARN_LAYER))
1020 Perl_warner(aTHX_ packWARN(WARN_LAYER),
1021 "Argument list not closed for PerlIO layer \"%.*s\"",
1033 PerlIO_funcs * const layer =
1034 PerlIO_find_layer(aTHX_ s, llen, 1);
1038 arg = newSVpvn(as, alen);
1039 PerlIO_list_push(aTHX_ av, layer,
1040 (arg) ? arg : &PL_sv_undef);
1045 if (ckWARN(WARN_LAYER))
1046 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1059 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1062 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1063 #ifdef PERLIO_USING_CRLF
1066 if (PerlIO_stdio.Set_ptrcnt)
1067 tab = &PerlIO_stdio;
1069 PerlIO_debug("Pushing %s\n", tab->name);
1070 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1075 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1077 return av->array[n].arg;
1081 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1083 if (n >= 0 && n < av->cur) {
1084 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1085 av->array[n].funcs->name);
1086 return av->array[n].funcs;
1089 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1094 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1096 PERL_UNUSED_ARG(mode);
1097 PERL_UNUSED_ARG(arg);
1098 PERL_UNUSED_ARG(tab);
1099 if (PerlIOValid(f)) {
1101 PerlIO_pop(aTHX_ f);
1107 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1108 sizeof(PerlIO_funcs),
1111 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1131 NULL, /* get_base */
1132 NULL, /* get_bufsiz */
1135 NULL, /* set_ptrcnt */
1139 PerlIO_default_layers(pTHX)
1142 if (!PL_def_layerlist) {
1143 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1144 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1145 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1146 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1148 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1150 osLayer = &PerlIO_win32;
1153 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1154 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1155 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1156 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1158 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1160 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1161 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1162 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1163 PerlIO_list_push(aTHX_ PL_def_layerlist,
1164 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1167 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1170 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1173 if (PL_def_layerlist->cur < 2) {
1174 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1176 return PL_def_layerlist;
1180 Perl_boot_core_PerlIO(pTHX)
1182 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1183 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1186 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1187 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1191 PerlIO_default_layer(pTHX_ I32 n)
1194 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1197 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1200 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1201 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1204 PerlIO_stdstreams(pTHX)
1208 PerlIO_allocate(aTHX);
1209 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1210 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1211 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1216 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1218 if (tab->fsize != sizeof(PerlIO_funcs)) {
1220 Perl_croak(aTHX_ "Layer does not match this perl");
1224 if (tab->size < sizeof(PerlIOl)) {
1227 /* Real layer with a data area */
1230 Newxz(temp, tab->size, char);
1234 l->tab = (PerlIO_funcs*) tab;
1236 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1237 (void*)f, tab->name,
1238 (mode) ? mode : "(Null)", (void*)arg);
1239 if (*l->tab->Pushed &&
1241 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1242 PerlIO_pop(aTHX_ f);
1251 /* Pseudo-layer where push does its own stack adjust */
1252 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1253 (mode) ? mode : "(Null)", (void*)arg);
1255 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1263 PerlIOBase_binmode(pTHX_ PerlIO *f)
1265 if (PerlIOValid(f)) {
1266 /* Is layer suitable for raw stream ? */
1267 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1268 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1269 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1272 /* Not suitable - pop it */
1273 PerlIO_pop(aTHX_ f);
1281 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1283 PERL_UNUSED_ARG(mode);
1284 PERL_UNUSED_ARG(arg);
1285 PERL_UNUSED_ARG(tab);
1287 if (PerlIOValid(f)) {
1292 * Strip all layers that are not suitable for a raw stream
1295 while (t && (l = *t)) {
1296 if (l->tab->Binmode) {
1297 /* Has a handler - normal case */
1298 if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1300 /* Layer still there - move down a layer */
1309 /* No handler - pop it */
1310 PerlIO_pop(aTHX_ t);
1313 if (PerlIOValid(f)) {
1314 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1322 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1323 PerlIO_list_t *layers, IV n, IV max)
1327 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1329 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1340 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1344 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1345 code = PerlIO_parse_layers(aTHX_ layers, names);
1347 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1349 PerlIO_list_free(aTHX_ layers);
1355 /*--------------------------------------------------------------------------------------*/
1357 * Given the abstraction above the public API functions
1361 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1363 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1364 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1365 iotype, mode, (names) ? names : "(Null)");
1368 /* Do not flush etc. if (e.g.) switching encodings.
1369 if a pushed layer knows it needs to flush lower layers
1370 (for example :unix which is never going to call them)
1371 it can do the flush when it is pushed.
1373 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1376 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1377 #ifdef PERLIO_USING_CRLF
1378 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1379 O_BINARY so we can look for it in mode.
1381 if (!(mode & O_BINARY)) {
1383 /* FIXME?: Looking down the layer stack seems wrong,
1384 but is a way of reaching past (say) an encoding layer
1385 to flip CRLF-ness of the layer(s) below
1388 /* Perhaps we should turn on bottom-most aware layer
1389 e.g. Ilya's idea that UNIX TTY could serve
1391 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1392 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1393 /* Not in text mode - flush any pending stuff and flip it */
1395 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1397 /* Only need to turn it on in one layer so we are done */
1402 /* Not finding a CRLF aware layer presumably means we are binary
1403 which is not what was requested - so we failed
1404 We _could_ push :crlf layer but so could caller
1409 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1410 So code that used to be here is now in PerlIORaw_pushed().
1412 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1417 PerlIO__close(pTHX_ PerlIO *f)
1419 if (PerlIOValid(f)) {
1420 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1421 if (tab && tab->Close)
1422 return (*tab->Close)(aTHX_ f);
1424 return PerlIOBase_close(aTHX_ f);
1427 SETERRNO(EBADF, SS_IVCHAN);
1433 Perl_PerlIO_close(pTHX_ PerlIO *f)
1435 const int code = PerlIO__close(aTHX_ f);
1436 while (PerlIOValid(f)) {
1437 PerlIO_pop(aTHX_ f);
1443 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1446 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1450 static PerlIO_funcs *
1451 PerlIO_layer_from_ref(pTHX_ SV *sv)
1455 * For any scalar type load the handler which is bundled with perl
1457 if (SvTYPE(sv) < SVt_PVAV) {
1458 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1459 /* This isn't supposed to happen, since PerlIO::scalar is core,
1460 * but could happen anyway in smaller installs or with PAR */
1461 if (!f && ckWARN(WARN_LAYER))
1462 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1467 * For other types allow if layer is known but don't try and load it
1469 switch (SvTYPE(sv)) {
1471 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1473 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1475 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1477 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1484 PerlIO_resolve_layers(pTHX_ const char *layers,
1485 const char *mode, int narg, SV **args)
1488 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1491 PerlIO_stdstreams(aTHX);
1493 SV * const arg = *args;
1495 * If it is a reference but not an object see if we have a handler
1498 if (SvROK(arg) && !sv_isobject(arg)) {
1499 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1501 def = PerlIO_list_alloc(aTHX);
1502 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1506 * Don't fail if handler cannot be found :via(...) etc. may do
1507 * something sensible else we will just stringfy and open
1512 if (!layers || !*layers)
1513 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1514 if (layers && *layers) {
1517 av = PerlIO_clone_list(aTHX_ def, NULL);
1522 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1526 PerlIO_list_free(aTHX_ av);
1538 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1539 int imode, int perm, PerlIO *f, int narg, SV **args)
1542 if (!f && narg == 1 && *args == &PL_sv_undef) {
1543 if ((f = PerlIO_tmpfile())) {
1544 if (!layers || !*layers)
1545 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1546 if (layers && *layers)
1547 PerlIO_apply_layers(aTHX_ f, mode, layers);
1551 PerlIO_list_t *layera;
1553 PerlIO_funcs *tab = NULL;
1554 if (PerlIOValid(f)) {
1556 * This is "reopen" - it is not tested as perl does not use it
1560 layera = PerlIO_list_alloc(aTHX);
1564 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1565 PerlIO_list_push(aTHX_ layera, l->tab,
1566 (arg) ? arg : &PL_sv_undef);
1569 l = *PerlIONext(&l);
1573 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1579 * Start at "top" of layer stack
1581 n = layera->cur - 1;
1583 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1592 * Found that layer 'n' can do opens - call it
1594 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1595 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1597 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1598 tab->name, layers ? layers : "(Null)", mode, fd,
1599 imode, perm, (void*)f, narg, (void*)args);
1601 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1604 SETERRNO(EINVAL, LIB_INVARG);
1608 if (n + 1 < layera->cur) {
1610 * More layers above the one that we used to open -
1613 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1614 /* If pushing layers fails close the file */
1621 PerlIO_list_free(aTHX_ layera);
1628 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1630 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1634 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1636 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1640 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1642 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1646 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1648 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1652 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1654 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1658 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1663 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1665 if (tab && tab->Flush)
1666 return (*tab->Flush) (aTHX_ f);
1668 return 0; /* If no Flush defined, silently succeed. */
1671 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1672 SETERRNO(EBADF, SS_IVCHAN);
1678 * Is it good API design to do flush-all on NULL, a potentially
1679 * errorneous input? Maybe some magical value (PerlIO*
1680 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1681 * things on fflush(NULL), but should we be bound by their design
1684 PerlIO **table = &PL_perlio;
1686 while ((f = *table)) {
1688 table = (PerlIO **) (f++);
1689 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1690 if (*f && PerlIO_flush(f) != 0)
1700 PerlIOBase_flush_linebuf(pTHX)
1703 PerlIO **table = &PL_perlio;
1705 while ((f = *table)) {
1707 table = (PerlIO **) (f++);
1708 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1711 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1712 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1720 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1722 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1726 PerlIO_isutf8(PerlIO *f)
1729 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1731 SETERRNO(EBADF, SS_IVCHAN);
1737 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1739 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1743 Perl_PerlIO_error(pTHX_ PerlIO *f)
1745 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1749 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1751 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1755 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1757 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1761 PerlIO_has_base(PerlIO *f)
1763 if (PerlIOValid(f)) {
1764 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1767 return (tab->Get_base != NULL);
1768 SETERRNO(EINVAL, LIB_INVARG);
1771 SETERRNO(EBADF, SS_IVCHAN);
1777 PerlIO_fast_gets(PerlIO *f)
1779 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1780 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1783 return (tab->Set_ptrcnt != NULL);
1784 SETERRNO(EINVAL, LIB_INVARG);
1787 SETERRNO(EBADF, SS_IVCHAN);
1793 PerlIO_has_cntptr(PerlIO *f)
1795 if (PerlIOValid(f)) {
1796 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1799 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1800 SETERRNO(EINVAL, LIB_INVARG);
1803 SETERRNO(EBADF, SS_IVCHAN);
1809 PerlIO_canset_cnt(PerlIO *f)
1811 if (PerlIOValid(f)) {
1812 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1815 return (tab->Set_ptrcnt != NULL);
1816 SETERRNO(EINVAL, LIB_INVARG);
1819 SETERRNO(EBADF, SS_IVCHAN);
1825 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1827 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1831 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1833 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1837 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1839 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1843 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1845 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1849 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1851 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1855 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1857 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1861 /*--------------------------------------------------------------------------------------*/
1863 * utf8 and raw dummy layers
1867 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1869 PERL_UNUSED_CONTEXT;
1870 PERL_UNUSED_ARG(mode);
1871 PERL_UNUSED_ARG(arg);
1872 if (PerlIOValid(f)) {
1873 if (tab->kind & PERLIO_K_UTF8)
1874 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1876 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1882 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1883 sizeof(PerlIO_funcs),
1886 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1906 NULL, /* get_base */
1907 NULL, /* get_bufsiz */
1910 NULL, /* set_ptrcnt */
1913 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1914 sizeof(PerlIO_funcs),
1937 NULL, /* get_base */
1938 NULL, /* get_bufsiz */
1941 NULL, /* set_ptrcnt */
1945 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1946 IV n, const char *mode, int fd, int imode, int perm,
1947 PerlIO *old, int narg, SV **args)
1949 PerlIO_funcs * const tab = PerlIO_default_btm();
1950 PERL_UNUSED_ARG(self);
1951 if (tab && tab->Open)
1952 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1954 SETERRNO(EINVAL, LIB_INVARG);
1958 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1959 sizeof(PerlIO_funcs),
1982 NULL, /* get_base */
1983 NULL, /* get_bufsiz */
1986 NULL, /* set_ptrcnt */
1988 /*--------------------------------------------------------------------------------------*/
1989 /*--------------------------------------------------------------------------------------*/
1991 * "Methods" of the "base class"
1995 PerlIOBase_fileno(pTHX_ PerlIO *f)
1997 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
2001 PerlIO_modestr(PerlIO * f, char *buf)
2004 if (PerlIOValid(f)) {
2005 const IV flags = PerlIOBase(f)->flags;
2006 if (flags & PERLIO_F_APPEND) {
2008 if (flags & PERLIO_F_CANREAD) {
2012 else if (flags & PERLIO_F_CANREAD) {
2014 if (flags & PERLIO_F_CANWRITE)
2017 else if (flags & PERLIO_F_CANWRITE) {
2019 if (flags & PERLIO_F_CANREAD) {
2023 #ifdef PERLIO_USING_CRLF
2024 if (!(flags & PERLIO_F_CRLF))
2034 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2036 PerlIOl * const l = PerlIOBase(f);
2037 PERL_UNUSED_CONTEXT;
2038 PERL_UNUSED_ARG(arg);
2040 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2041 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2042 if (tab->Set_ptrcnt != NULL)
2043 l->flags |= PERLIO_F_FASTGETS;
2045 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2049 l->flags |= PERLIO_F_CANREAD;
2052 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2055 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2058 SETERRNO(EINVAL, LIB_INVARG);
2064 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2067 l->flags &= ~PERLIO_F_CRLF;
2070 l->flags |= PERLIO_F_CRLF;
2073 SETERRNO(EINVAL, LIB_INVARG);
2080 l->flags |= l->next->flags &
2081 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2086 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2087 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2088 l->flags, PerlIO_modestr(f, temp));
2094 PerlIOBase_popped(pTHX_ PerlIO *f)
2096 PERL_UNUSED_CONTEXT;
2102 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2105 * Save the position as current head considers it
2107 const Off_t old = PerlIO_tell(f);
2108 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2109 PerlIOSelf(f, PerlIOBuf)->posn = old;
2110 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2114 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2116 STDCHAR *buf = (STDCHAR *) vbuf;
2118 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2119 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2120 SETERRNO(EBADF, SS_IVCHAN);
2126 SSize_t avail = PerlIO_get_cnt(f);
2129 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2131 STDCHAR *ptr = PerlIO_get_ptr(f);
2132 Copy(ptr, buf, take, STDCHAR);
2133 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2136 if (avail == 0) /* set_ptrcnt could have reset avail */
2139 if (count > 0 && avail <= 0) {
2140 if (PerlIO_fill(f) != 0)
2145 return (buf - (STDCHAR *) vbuf);
2151 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2153 PERL_UNUSED_CONTEXT;
2159 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2161 PERL_UNUSED_CONTEXT;
2167 PerlIOBase_close(pTHX_ PerlIO *f)
2170 if (PerlIOValid(f)) {
2171 PerlIO *n = PerlIONext(f);
2172 code = PerlIO_flush(f);
2173 PerlIOBase(f)->flags &=
2174 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2175 while (PerlIOValid(n)) {
2176 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2177 if (tab && tab->Close) {
2178 if ((*tab->Close)(aTHX_ n) != 0)
2183 PerlIOBase(n)->flags &=
2184 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2190 SETERRNO(EBADF, SS_IVCHAN);
2196 PerlIOBase_eof(pTHX_ PerlIO *f)
2198 PERL_UNUSED_CONTEXT;
2199 if (PerlIOValid(f)) {
2200 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2206 PerlIOBase_error(pTHX_ PerlIO *f)
2208 PERL_UNUSED_CONTEXT;
2209 if (PerlIOValid(f)) {
2210 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2216 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2218 if (PerlIOValid(f)) {
2219 PerlIO * const n = PerlIONext(f);
2220 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2227 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2229 PERL_UNUSED_CONTEXT;
2230 if (PerlIOValid(f)) {
2231 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2236 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2242 arg = sv_dup(arg, param);
2243 SvREFCNT_inc_simple_void_NN(arg);
2247 return newSVsv(arg);
2250 PERL_UNUSED_ARG(param);
2251 return newSVsv(arg);
2256 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2258 PerlIO * const nexto = PerlIONext(o);
2259 if (PerlIOValid(nexto)) {
2260 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2261 if (tab && tab->Dup)
2262 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2264 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2267 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2270 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2271 self->name, (void*)f, (void*)o, (void*)param);
2273 arg = (*self->Getarg)(aTHX_ o, param, flags);
2274 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2275 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2276 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2283 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2285 /* Must be called with PL_perlio_mutex locked. */
2287 S_more_refcounted_fds(pTHX_ const int new_fd) {
2289 const int old_max = PL_perlio_fd_refcnt_size;
2290 const int new_max = 16 + (new_fd & ~15);
2293 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2294 old_max, new_fd, new_max);
2296 if (new_fd < old_max) {
2300 assert (new_max > new_fd);
2302 /* Use plain realloc() since we need this memory to be really
2303 * global and visible to all the interpreters and/or threads. */
2304 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2308 MUTEX_UNLOCK(&PL_perlio_mutex);
2310 /* Can't use PerlIO to write as it allocates memory */
2311 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2312 PL_no_mem, strlen(PL_no_mem));
2316 PL_perlio_fd_refcnt_size = new_max;
2317 PL_perlio_fd_refcnt = new_array;
2319 PerlIO_debug("Zeroing %p, %d\n",
2320 (void*)(new_array + old_max),
2323 Zero(new_array + old_max, new_max - old_max, int);
2330 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2331 PERL_UNUSED_CONTEXT;
2335 PerlIOUnix_refcnt_inc(int fd)
2342 MUTEX_LOCK(&PL_perlio_mutex);
2344 if (fd >= PL_perlio_fd_refcnt_size)
2345 S_more_refcounted_fds(aTHX_ fd);
2347 PL_perlio_fd_refcnt[fd]++;
2348 if (PL_perlio_fd_refcnt[fd] <= 0) {
2349 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2350 fd, PL_perlio_fd_refcnt[fd]);
2352 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2353 fd, PL_perlio_fd_refcnt[fd]);
2356 MUTEX_UNLOCK(&PL_perlio_mutex);
2359 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2364 PerlIOUnix_refcnt_dec(int fd)
2371 MUTEX_LOCK(&PL_perlio_mutex);
2373 if (fd >= PL_perlio_fd_refcnt_size) {
2374 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2375 fd, PL_perlio_fd_refcnt_size);
2377 if (PL_perlio_fd_refcnt[fd] <= 0) {
2378 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2379 fd, PL_perlio_fd_refcnt[fd]);
2381 cnt = --PL_perlio_fd_refcnt[fd];
2382 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2384 MUTEX_UNLOCK(&PL_perlio_mutex);
2387 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2393 PerlIO_cleanup(pTHX)
2398 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2400 PerlIO_debug("Cleanup layers\n");
2403 /* Raise STDIN..STDERR refcount so we don't close them */
2404 for (i=0; i < 3; i++)
2405 PerlIOUnix_refcnt_inc(i);
2406 PerlIO_cleantable(aTHX_ &PL_perlio);
2407 /* Restore STDIN..STDERR refcount */
2408 for (i=0; i < 3; i++)
2409 PerlIOUnix_refcnt_dec(i);
2411 if (PL_known_layers) {
2412 PerlIO_list_free(aTHX_ PL_known_layers);
2413 PL_known_layers = NULL;
2415 if (PL_def_layerlist) {
2416 PerlIO_list_free(aTHX_ PL_def_layerlist);
2417 PL_def_layerlist = NULL;
2421 void PerlIO_teardown() /* Call only from PERL_SYS_TERM(). */
2425 /* XXX we can't rely on an interpreter being present at this late stage,
2426 XXX so we can't use a function like PerlLIO_write that relies on one
2427 being present (at least in win32) :-(.
2432 /* By now all filehandles should have been closed, so any
2433 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2435 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2436 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2437 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2439 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2440 if (PL_perlio_fd_refcnt[i]) {
2442 my_snprintf(buf, sizeof(buf),
2443 "PerlIO_teardown: fd %d refcnt=%d\n",
2444 i, PL_perlio_fd_refcnt[i]);
2445 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2451 /* Not bothering with PL_perlio_mutex since by now
2452 * all the interpreters are gone. */
2453 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2454 && PL_perlio_fd_refcnt) {
2455 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2456 PL_perlio_fd_refcnt = NULL;
2457 PL_perlio_fd_refcnt_size = 0;
2461 /*--------------------------------------------------------------------------------------*/
2463 * Bottom-most level for UNIX-like case
2467 struct _PerlIO base; /* The generic part */
2468 int fd; /* UNIX like file descriptor */
2469 int oflags; /* open/fcntl flags */
2473 PerlIOUnix_oflags(const char *mode)
2476 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2481 if (*++mode == '+') {
2488 oflags = O_CREAT | O_TRUNC;
2489 if (*++mode == '+') {
2498 oflags = O_CREAT | O_APPEND;
2499 if (*++mode == '+') {
2512 else if (*mode == 't') {
2514 oflags &= ~O_BINARY;
2518 * Always open in binary mode
2521 if (*mode || oflags == -1) {
2522 SETERRNO(EINVAL, LIB_INVARG);
2529 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2531 PERL_UNUSED_CONTEXT;
2532 return PerlIOSelf(f, PerlIOUnix)->fd;
2536 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2538 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2541 if (PerlLIO_fstat(fd, &st) == 0) {
2542 if (!S_ISREG(st.st_mode)) {
2543 PerlIO_debug("%d is not regular file\n",fd);
2544 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2547 PerlIO_debug("%d _is_ a regular file\n",fd);
2553 PerlIOUnix_refcnt_inc(fd);
2554 PERL_UNUSED_CONTEXT;
2558 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2560 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2561 if (*PerlIONext(f)) {
2562 /* We never call down so do any pending stuff now */
2563 PerlIO_flush(PerlIONext(f));
2565 * XXX could (or should) we retrieve the oflags from the open file
2566 * handle rather than believing the "mode" we are passed in? XXX
2567 * Should the value on NULL mode be 0 or -1?
2569 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2570 mode ? PerlIOUnix_oflags(mode) : -1);
2572 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2578 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2580 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2582 PERL_UNUSED_CONTEXT;
2583 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2585 SETERRNO(ESPIPE, LIB_INVARG);
2587 SETERRNO(EINVAL, LIB_INVARG);
2591 new_loc = PerlLIO_lseek(fd, offset, whence);
2592 if (new_loc == (Off_t) - 1)
2594 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2599 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2600 IV n, const char *mode, int fd, int imode,
2601 int perm, PerlIO *f, int narg, SV **args)
2603 if (PerlIOValid(f)) {
2604 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2605 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2608 if (*mode == IoTYPE_NUMERIC)
2611 imode = PerlIOUnix_oflags(mode);
2615 const char *path = SvPV_nolen_const(*args);
2616 fd = PerlLIO_open3(path, imode, perm);
2620 if (*mode == IoTYPE_IMPLICIT)
2623 f = PerlIO_allocate(aTHX);
2625 if (!PerlIOValid(f)) {
2626 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2630 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2631 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2632 if (*mode == IoTYPE_APPEND)
2633 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2640 * FIXME: pop layers ???
2648 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2650 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2652 if (flags & PERLIO_DUP_FD) {
2653 fd = PerlLIO_dup(fd);
2656 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2658 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2659 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2668 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2671 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2672 #ifdef PERLIO_STD_SPECIAL
2674 return PERLIO_STD_IN(fd, vbuf, count);
2676 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2677 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2681 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2682 if (len >= 0 || errno != EINTR) {
2684 if (errno != EAGAIN) {
2685 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2688 else if (len == 0 && count != 0) {
2689 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2700 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2703 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2704 #ifdef PERLIO_STD_SPECIAL
2705 if (fd == 1 || fd == 2)
2706 return PERLIO_STD_OUT(fd, vbuf, count);
2709 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2710 if (len >= 0 || errno != EINTR) {
2712 if (errno != EAGAIN) {
2713 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2724 PerlIOUnix_tell(pTHX_ PerlIO *f)
2726 PERL_UNUSED_CONTEXT;
2728 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2733 PerlIOUnix_close(pTHX_ PerlIO *f)
2736 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2738 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2739 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2740 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2745 SETERRNO(EBADF,SS_IVCHAN);
2748 while (PerlLIO_close(fd) != 0) {
2749 if (errno != EINTR) {
2756 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2761 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2762 sizeof(PerlIO_funcs),
2769 PerlIOBase_binmode, /* binmode */
2779 PerlIOBase_noop_ok, /* flush */
2780 PerlIOBase_noop_fail, /* fill */
2783 PerlIOBase_clearerr,
2784 PerlIOBase_setlinebuf,
2785 NULL, /* get_base */
2786 NULL, /* get_bufsiz */
2789 NULL, /* set_ptrcnt */
2792 /*--------------------------------------------------------------------------------------*/
2797 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2798 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2799 broken by the last second glibc 2.3 fix
2801 #define STDIO_BUFFER_WRITABLE
2806 struct _PerlIO base;
2807 FILE *stdio; /* The stream */
2811 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2813 PERL_UNUSED_CONTEXT;
2815 if (PerlIOValid(f)) {
2816 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2818 return PerlSIO_fileno(s);
2825 PerlIOStdio_mode(const char *mode, char *tmode)
2827 char * const ret = tmode;
2833 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2841 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2844 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2845 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2846 if (toptab == tab) {
2847 /* Top is already stdio - pop self (duplicate) and use original */
2848 PerlIO_pop(aTHX_ f);
2851 const int fd = PerlIO_fileno(n);
2854 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2855 mode = PerlIOStdio_mode(mode, tmode)))) {
2856 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2857 /* We never call down so do any pending stuff now */
2858 PerlIO_flush(PerlIONext(f));
2865 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2870 PerlIO_importFILE(FILE *stdio, const char *mode)
2876 if (!mode || !*mode) {
2877 /* We need to probe to see how we can open the stream
2878 so start with read/write and then try write and read
2879 we dup() so that we can fclose without loosing the fd.
2881 Note that the errno value set by a failing fdopen
2882 varies between stdio implementations.
2884 const int fd = PerlLIO_dup(fileno(stdio));
2885 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2887 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2890 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2893 /* Don't seem to be able to open */
2899 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2900 s = PerlIOSelf(f, PerlIOStdio);
2902 PerlIOUnix_refcnt_inc(fileno(stdio));
2909 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2910 IV n, const char *mode, int fd, int imode,
2911 int perm, PerlIO *f, int narg, SV **args)
2914 if (PerlIOValid(f)) {
2915 const char * const path = SvPV_nolen_const(*args);
2916 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2918 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2919 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2924 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2929 const char * const path = SvPV_nolen_const(*args);
2930 if (*mode == IoTYPE_NUMERIC) {
2932 fd = PerlLIO_open3(path, imode, perm);
2936 bool appended = FALSE;
2938 /* Cygwin wants its 'b' early. */
2940 mode = PerlIOStdio_mode(mode, tmode);
2942 stdio = PerlSIO_fopen(path, mode);
2945 f = PerlIO_allocate(aTHX);
2948 mode = PerlIOStdio_mode(mode, tmode);
2949 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2951 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2952 PerlIOUnix_refcnt_inc(fileno(stdio));
2954 PerlSIO_fclose(stdio);
2966 if (*mode == IoTYPE_IMPLICIT) {
2973 stdio = PerlSIO_stdin;
2976 stdio = PerlSIO_stdout;
2979 stdio = PerlSIO_stderr;
2984 stdio = PerlSIO_fdopen(fd, mode =
2985 PerlIOStdio_mode(mode, tmode));
2989 f = PerlIO_allocate(aTHX);
2991 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2992 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2993 PerlIOUnix_refcnt_inc(fileno(stdio));
3003 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3005 /* This assumes no layers underneath - which is what
3006 happens, but is not how I remember it. NI-S 2001/10/16
3008 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3009 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3010 const int fd = fileno(stdio);
3012 if (flags & PERLIO_DUP_FD) {
3013 const int dfd = PerlLIO_dup(fileno(stdio));
3015 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3020 /* FIXME: To avoid messy error recovery if dup fails
3021 re-use the existing stdio as though flag was not set
3025 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3027 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3028 PerlIOUnix_refcnt_inc(fileno(stdio));
3034 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3036 PERL_UNUSED_CONTEXT;
3038 /* XXX this could use PerlIO_canset_fileno() and
3039 * PerlIO_set_fileno() support from Configure
3041 # if defined(__UCLIBC__)
3042 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3045 # elif defined(__GLIBC__)
3046 /* There may be a better way for GLIBC:
3047 - libio.h defines a flag to not close() on cleanup
3051 # elif defined(__sun__)
3054 # elif defined(__hpux)
3058 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3059 your platform does not have special entry try this one.
3060 [For OSF only have confirmation for Tru64 (alpha)
3061 but assume other OSFs will be similar.]
3063 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3066 # elif defined(__FreeBSD__)
3067 /* There may be a better way on FreeBSD:
3068 - we could insert a dummy func in the _close function entry
3069 f->_close = (int (*)(void *)) dummy_close;
3073 # elif defined(__OpenBSD__)
3074 /* There may be a better way on OpenBSD:
3075 - we could insert a dummy func in the _close function entry
3076 f->_close = (int (*)(void *)) dummy_close;
3080 # elif defined(__EMX__)
3081 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3084 # elif defined(__CYGWIN__)
3085 /* There may be a better way on CYGWIN:
3086 - we could insert a dummy func in the _close function entry
3087 f->_close = (int (*)(void *)) dummy_close;
3091 # elif defined(WIN32)
3092 # if defined(__BORLANDC__)
3093 f->fd = PerlLIO_dup(fileno(f));
3094 # elif defined(UNDER_CE)
3095 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3104 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3105 (which isn't thread safe) instead
3107 # error "Don't know how to set FILE.fileno on your platform"
3115 PerlIOStdio_close(pTHX_ PerlIO *f)
3117 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3123 const int fd = fileno(stdio);
3128 #ifdef SOCKS5_VERSION_NAME
3129 /* Socks lib overrides close() but stdio isn't linked to
3130 that library (though we are) - so we must call close()
3131 on sockets on stdio's behalf.
3134 Sock_size_t optlen = sizeof(int);
3135 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3138 if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
3141 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3142 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3144 if (stdio == stdout || stdio == stderr)
3145 return PerlIO_flush(f);
3146 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3147 Use Sarathy's trick from maint-5.6 to invalidate the
3148 fileno slot of the FILE *
3150 result = PerlIO_flush(f);
3152 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3154 dupfd = PerlLIO_dup(fd);
3156 result = PerlSIO_fclose(stdio);
3157 /* We treat error from stdio as success if we invalidated
3158 errno may NOT be expected EBADF
3160 if (invalidate && result != 0) {
3164 #ifdef SOCKS5_VERSION_NAME
3165 /* in SOCKS' case, let close() determine return value */
3169 PerlLIO_dup2(dupfd,fd);
3170 PerlLIO_close(dupfd);
3177 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3180 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3184 STDCHAR *buf = (STDCHAR *) vbuf;
3186 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3187 * stdio does not do that for fread()
3189 const int ch = PerlSIO_fgetc(s);
3196 got = PerlSIO_fread(vbuf, 1, count, s);
3197 if (got == 0 && PerlSIO_ferror(s))
3199 if (got >= 0 || errno != EINTR)
3202 SETERRNO(0,0); /* just in case */
3208 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3211 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3213 #ifdef STDIO_BUFFER_WRITABLE
3214 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3215 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3216 STDCHAR *base = PerlIO_get_base(f);
3217 SSize_t cnt = PerlIO_get_cnt(f);
3218 STDCHAR *ptr = PerlIO_get_ptr(f);
3219 SSize_t avail = ptr - base;
3221 if (avail > count) {
3225 Move(buf-avail,ptr,avail,STDCHAR);
3228 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3229 if (PerlSIO_feof(s) && unread >= 0)
3230 PerlSIO_clearerr(s);
3235 if (PerlIO_has_cntptr(f)) {
3236 /* We can get pointer to buffer but not its base
3237 Do ungetc() but check chars are ending up in the
3240 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3241 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3243 const int ch = *--buf & 0xFF;
3244 if (ungetc(ch,s) != ch) {
3245 /* ungetc did not work */
3248 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3249 /* Did not change pointer as expected */
3250 fgetc(s); /* get char back again */
3260 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3266 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3271 got = PerlSIO_fwrite(vbuf, 1, count,
3272 PerlIOSelf(f, PerlIOStdio)->stdio);
3273 if (got >= 0 || errno != EINTR)
3276 SETERRNO(0,0); /* just in case */
3282 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3284 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3285 PERL_UNUSED_CONTEXT;
3287 return PerlSIO_fseek(stdio, offset, whence);
3291 PerlIOStdio_tell(pTHX_ PerlIO *f)
3293 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3294 PERL_UNUSED_CONTEXT;
3296 return PerlSIO_ftell(stdio);
3300 PerlIOStdio_flush(pTHX_ PerlIO *f)
3302 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3303 PERL_UNUSED_CONTEXT;
3305 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3306 return PerlSIO_fflush(stdio);
3312 * FIXME: This discards ungetc() and pre-read stuff which is not
3313 * right if this is just a "sync" from a layer above Suspect right
3314 * design is to do _this_ but not have layer above flush this
3315 * layer read-to-read
3318 * Not writeable - sync by attempting a seek
3320 const int err = errno;
3321 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3329 PerlIOStdio_eof(pTHX_ PerlIO *f)
3331 PERL_UNUSED_CONTEXT;
3333 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3337 PerlIOStdio_error(pTHX_ PerlIO *f)
3339 PERL_UNUSED_CONTEXT;
3341 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3345 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3347 PERL_UNUSED_CONTEXT;
3349 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3353 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3355 PERL_UNUSED_CONTEXT;
3357 #ifdef HAS_SETLINEBUF
3358 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3360 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3366 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3368 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3369 return (STDCHAR*)PerlSIO_get_base(stdio);
3373 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3375 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3376 return PerlSIO_get_bufsiz(stdio);
3380 #ifdef USE_STDIO_PTR
3382 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3384 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3385 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3389 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3391 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3392 return PerlSIO_get_cnt(stdio);
3396 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3398 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3400 #ifdef STDIO_PTR_LVALUE
3401 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3402 #ifdef STDIO_PTR_LVAL_SETS_CNT
3403 assert(PerlSIO_get_cnt(stdio) == (cnt));
3405 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3407 * Setting ptr _does_ change cnt - we are done
3411 #else /* STDIO_PTR_LVALUE */
3413 #endif /* STDIO_PTR_LVALUE */
3416 * Now (or only) set cnt
3418 #ifdef STDIO_CNT_LVALUE
3419 PerlSIO_set_cnt(stdio, cnt);
3420 #else /* STDIO_CNT_LVALUE */
3421 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3422 PerlSIO_set_ptr(stdio,
3423 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3425 #else /* STDIO_PTR_LVAL_SETS_CNT */
3427 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3428 #endif /* STDIO_CNT_LVALUE */
3435 PerlIOStdio_fill(pTHX_ PerlIO *f)
3437 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3439 PERL_UNUSED_CONTEXT;
3442 * fflush()ing read-only streams can cause trouble on some stdio-s
3444 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3445 if (PerlSIO_fflush(stdio) != 0)
3449 c = PerlSIO_fgetc(stdio);
3452 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3458 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3460 #ifdef STDIO_BUFFER_WRITABLE
3461 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3462 /* Fake ungetc() to the real buffer in case system's ungetc
3465 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3466 SSize_t cnt = PerlSIO_get_cnt(stdio);
3467 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3468 if (ptr == base+1) {
3469 *--ptr = (STDCHAR) c;
3470 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3471 if (PerlSIO_feof(stdio))
3472 PerlSIO_clearerr(stdio);
3478 if (PerlIO_has_cntptr(f)) {
3480 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3487 /* An ungetc()d char is handled separately from the regular
3488 * buffer, so we stuff it in the buffer ourselves.
3489 * Should never get called as should hit code above
3491 *(--((*stdio)->_ptr)) = (unsigned char) c;
3494 /* If buffer snoop scheme above fails fall back to
3497 if (PerlSIO_ungetc(c, stdio) != c)
3505 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3506 sizeof(PerlIO_funcs),
3508 sizeof(PerlIOStdio),
3509 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3513 PerlIOBase_binmode, /* binmode */
3527 PerlIOStdio_clearerr,
3528 PerlIOStdio_setlinebuf,
3530 PerlIOStdio_get_base,
3531 PerlIOStdio_get_bufsiz,
3536 #ifdef USE_STDIO_PTR
3537 PerlIOStdio_get_ptr,
3538 PerlIOStdio_get_cnt,
3539 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3540 PerlIOStdio_set_ptrcnt,
3543 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3548 #endif /* USE_STDIO_PTR */
3551 /* Note that calls to PerlIO_exportFILE() are reversed using
3552 * PerlIO_releaseFILE(), not importFILE. */
3554 PerlIO_exportFILE(PerlIO * f, const char *mode)
3558 if (PerlIOValid(f)) {
3561 if (!mode || !*mode) {
3562 mode = PerlIO_modestr(f, buf);
3564 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3568 /* De-link any lower layers so new :stdio sticks */
3570 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3571 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3573 PerlIOUnix_refcnt_inc(fileno(stdio));
3574 /* Link previous lower layers under new one */
3578 /* restore layers list */
3588 PerlIO_findFILE(PerlIO *f)
3593 if (l->tab == &PerlIO_stdio) {
3594 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3597 l = *PerlIONext(&l);
3599 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3600 /* However, we're not really exporting a FILE * to someone else (who
3601 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3602 So we need to undo its refernce count increase on the underlying file
3603 descriptor. We have to do this, because if the loop above returns you
3604 the FILE *, then *it* didn't increase any reference count. So there's
3605 only one way to be consistent. */
3606 stdio = PerlIO_exportFILE(f, NULL);
3608 const int fd = fileno(stdio);
3610 PerlIOUnix_refcnt_dec(fd);
3615 /* Use this to reverse PerlIO_exportFILE calls. */
3617 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3622 if (l->tab == &PerlIO_stdio) {
3623 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3624 if (s->stdio == f) {
3626 const int fd = fileno(f);
3628 PerlIOUnix_refcnt_dec(fd);
3629 PerlIO_pop(aTHX_ p);
3638 /*--------------------------------------------------------------------------------------*/
3640 * perlio buffer layer
3644 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3646 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3647 const int fd = PerlIO_fileno(f);
3648 if (fd >= 0 && PerlLIO_isatty(fd)) {
3649 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3651 if (*PerlIONext(f)) {
3652 const Off_t posn = PerlIO_tell(PerlIONext(f));
3653 if (posn != (Off_t) - 1) {
3657 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3661 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3662 IV n, const char *mode, int fd, int imode, int perm,
3663 PerlIO *f, int narg, SV **args)
3665 if (PerlIOValid(f)) {
3666 PerlIO *next = PerlIONext(f);
3668 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3669 if (tab && tab->Open)
3671 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3673 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3678 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3680 if (*mode == IoTYPE_IMPLICIT) {
3686 if (tab && tab->Open)
3687 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3690 SETERRNO(EINVAL, LIB_INVARG);
3692 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3694 * if push fails during open, open fails. close will pop us.
3699 fd = PerlIO_fileno(f);
3700 if (init && fd == 2) {
3702 * Initial stderr is unbuffered
3704 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3706 #ifdef PERLIO_USING_CRLF
3707 # ifdef PERLIO_IS_BINMODE_FD
3708 if (PERLIO_IS_BINMODE_FD(fd))
3709 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3713 * do something about failing setmode()? --jhi
3715 PerlLIO_setmode(fd, O_BINARY);
3724 * This "flush" is akin to sfio's sync in that it handles files in either
3725 * read or write state. For write state, we put the postponed data through
3726 * the next layers. For read state, we seek() the next layers to the
3727 * offset given by current position in the buffer, and discard the buffer
3728 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3729 * in any case?). Then the pass the stick further in chain.
3732 PerlIOBuf_flush(pTHX_ PerlIO *f)
3734 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3736 PerlIO *n = PerlIONext(f);
3737 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3739 * write() the buffer
3741 const STDCHAR *buf = b->buf;
3742 const STDCHAR *p = buf;
3743 while (p < b->ptr) {
3744 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3748 else if (count < 0 || PerlIO_error(n)) {
3749 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3754 b->posn += (p - buf);
3756 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3757 STDCHAR *buf = PerlIO_get_base(f);
3759 * Note position change
3761 b->posn += (b->ptr - buf);
3762 if (b->ptr < b->end) {
3763 /* We did not consume all of it - try and seek downstream to
3764 our logical position
3766 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3767 /* Reload n as some layers may pop themselves on seek */
3768 b->posn = PerlIO_tell(n = PerlIONext(f));
3771 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3772 data is lost for good - so return saying "ok" having undone
3775 b->posn -= (b->ptr - buf);
3780 b->ptr = b->end = b->buf;
3781 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3782 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3783 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3788 /* This discards the content of the buffer after b->ptr, and rereads
3789 * the buffer from the position off in the layer downstream; here off
3790 * is at offset corresponding to b->ptr - b->buf.
3793 PerlIOBuf_fill(pTHX_ PerlIO *f)
3795 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3796 PerlIO *n = PerlIONext(f);
3799 * Down-stream flush is defined not to loose read data so is harmless.
3800 * we would not normally be fill'ing if there was data left in anycase.
3802 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3804 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3805 PerlIOBase_flush_linebuf(aTHX);
3808 PerlIO_get_base(f); /* allocate via vtable */
3810 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3812 b->ptr = b->end = b->buf;
3814 if (!PerlIOValid(n)) {
3815 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3819 if (PerlIO_fast_gets(n)) {
3821 * Layer below is also buffered. We do _NOT_ want to call its
3822 * ->Read() because that will loop till it gets what we asked for
3823 * which may hang on a pipe etc. Instead take anything it has to
3824 * hand, or ask it to fill _once_.
3826 avail = PerlIO_get_cnt(n);
3828 avail = PerlIO_fill(n);
3830 avail = PerlIO_get_cnt(n);
3832 if (!PerlIO_error(n) && PerlIO_eof(n))
3837 STDCHAR *ptr = PerlIO_get_ptr(n);
3838 const SSize_t cnt = avail;
3839 if (avail > (SSize_t)b->bufsiz)
3841 Copy(ptr, b->buf, avail, STDCHAR);
3842 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3846 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3850 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3852 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3855 b->end = b->buf + avail;
3856 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3861 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3863 if (PerlIOValid(f)) {
3864 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3867 return PerlIOBase_read(aTHX_ f, vbuf, count);
3873 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3875 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3876 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3879 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3884 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3886 * Buffer is already a read buffer, we can overwrite any chars
3887 * which have been read back to buffer start
3889 avail = (b->ptr - b->buf);
3893 * Buffer is idle, set it up so whole buffer is available for
3897 b->end = b->buf + avail;
3899 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3901 * Buffer extends _back_ from where we are now
3903 b->posn -= b->bufsiz;
3905 if (avail > (SSize_t) count) {
3907 * If we have space for more than count, just move count
3915 * In simple stdio-like ungetc() case chars will be already
3918 if (buf != b->ptr) {
3919 Copy(buf, b->ptr, avail, STDCHAR);
3923 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3927 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3933 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3935 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3936 const STDCHAR *buf = (const STDCHAR *) vbuf;
3937 const STDCHAR *flushptr = buf;
3941 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3943 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3944 if (PerlIO_flush(f) != 0) {
3948 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3949 flushptr = buf + count;
3950 while (flushptr > buf && *(flushptr - 1) != '\n')
3954 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3955 if ((SSize_t) count < avail)
3957 if (flushptr > buf && flushptr <= buf + avail)
3958 avail = flushptr - buf;
3959 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3961 Copy(buf, b->ptr, avail, STDCHAR);
3966 if (buf == flushptr)
3969 if (b->ptr >= (b->buf + b->bufsiz))
3972 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3978 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3981 if ((code = PerlIO_flush(f)) == 0) {
3982 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3983 code = PerlIO_seek(PerlIONext(f), offset, whence);
3985 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3986 b->posn = PerlIO_tell(PerlIONext(f));
3993 PerlIOBuf_tell(pTHX_ PerlIO *f)
3995 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3997 * b->posn is file position where b->buf was read, or will be written
3999 Off_t posn = b->posn;
4000 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4001 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4003 /* As O_APPEND files are normally shared in some sense it is better
4008 /* when file is NOT shared then this is sufficient */
4009 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4011 posn = b->posn = PerlIO_tell(PerlIONext(f));
4015 * If buffer is valid adjust position by amount in buffer
4017 posn += (b->ptr - b->buf);
4023 PerlIOBuf_popped(pTHX_ PerlIO *f)
4025 const IV code = PerlIOBase_popped(aTHX_ f);
4026 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4027 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4030 b->ptr = b->end = b->buf = NULL;
4031 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4036 PerlIOBuf_close(pTHX_ PerlIO *f)
4038 const IV code = PerlIOBase_close(aTHX_ f);
4039 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4040 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4043 b->ptr = b->end = b->buf = NULL;
4044 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4049 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4051 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4058 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4060 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4063 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4064 return (b->end - b->ptr);
4069 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4071 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4072 PERL_UNUSED_CONTEXT;
4077 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4079 b->buf = (STDCHAR *) & b->oneword;
4080 b->bufsiz = sizeof(b->oneword);
4082 b->end = b->ptr = b->buf;
4088 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4090 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4093 return (b->end - b->buf);
4097 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4099 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4103 assert(PerlIO_get_cnt(f) == cnt);
4104 assert(b->ptr >= b->buf);
4105 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4109 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4111 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4116 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4117 sizeof(PerlIO_funcs),
4120 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4124 PerlIOBase_binmode, /* binmode */
4138 PerlIOBase_clearerr,
4139 PerlIOBase_setlinebuf,
4144 PerlIOBuf_set_ptrcnt,
4147 /*--------------------------------------------------------------------------------------*/
4149 * Temp layer to hold unread chars when cannot do it any other way
4153 PerlIOPending_fill(pTHX_ PerlIO *f)
4156 * Should never happen
4163 PerlIOPending_close(pTHX_ PerlIO *f)
4166 * A tad tricky - flush pops us, then we close new top
4169 return PerlIO_close(f);
4173 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4176 * A tad tricky - flush pops us, then we seek new top
4179 return PerlIO_seek(f, offset, whence);
4184 PerlIOPending_flush(pTHX_ PerlIO *f)
4186 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4187 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4191 PerlIO_pop(aTHX_ f);
4196 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4202 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4207 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4209 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4210 PerlIOl * const l = PerlIOBase(f);
4212 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4213 * etc. get muddled when it changes mid-string when we auto-pop.
4215 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4216 (PerlIOBase(PerlIONext(f))->
4217 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4222 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4224 SSize_t avail = PerlIO_get_cnt(f);
4226 if ((SSize_t)count < avail)
4229 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4230 if (got >= 0 && got < (SSize_t)count) {
4231 const SSize_t more =
4232 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4233 if (more >= 0 || got == 0)
4239 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4240 sizeof(PerlIO_funcs),
4243 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4244 PerlIOPending_pushed,
4247 PerlIOBase_binmode, /* binmode */
4256 PerlIOPending_close,
4257 PerlIOPending_flush,
4261 PerlIOBase_clearerr,
4262 PerlIOBase_setlinebuf,
4267 PerlIOPending_set_ptrcnt,
4272 /*--------------------------------------------------------------------------------------*/
4274 * crlf - translation On read translate CR,LF to "\n" we do this by
4275 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4276 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4278 * c->nl points on the first byte of CR LF pair when it is temporarily
4279 * replaced by LF, or to the last CR of the buffer. In the former case
4280 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4281 * that it ends at c->nl; these two cases can be distinguished by
4282 * *c->nl. c->nl is set during _getcnt() call, and unset during
4283 * _unread() and _flush() calls.
4284 * It only matters for read operations.
4288 PerlIOBuf base; /* PerlIOBuf stuff */
4289 STDCHAR *nl; /* Position of crlf we "lied" about in the
4293 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4294 * Otherwise the :crlf layer would always revert back to
4298 S_inherit_utf8_flag(PerlIO *f)
4300 PerlIO *g = PerlIONext(f);
4301 if (PerlIOValid(g)) {
4302 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4303 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4309 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4312 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4313 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4315 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4316 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4317 PerlIOBase(f)->flags);
4320 /* Enable the first CRLF capable layer you can find, but if none
4321 * found, the one we just pushed is fine. This results in at
4322 * any given moment at most one CRLF-capable layer being enabled
4323 * in the whole layer stack. */
4324 PerlIO *g = PerlIONext(f);
4325 while (PerlIOValid(g)) {
4326 PerlIOl *b = PerlIOBase(g);
4327 if (b && b->tab == &PerlIO_crlf) {
4328 if (!(b->flags & PERLIO_F_CRLF))
4329 b->flags |= PERLIO_F_CRLF;
4330 S_inherit_utf8_flag(g);
4331 PerlIO_pop(aTHX_ f);
4337 S_inherit_utf8_flag(f);
4343 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4345 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4346 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4350 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4351 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4353 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4354 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4356 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4361 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4362 b->end = b->ptr = b->buf + b->bufsiz;
4363 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4364 b->posn -= b->bufsiz;
4366 while (count > 0 && b->ptr > b->buf) {
4367 const int ch = *--buf;
4369 if (b->ptr - 2 >= b->buf) {
4376 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4377 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4393 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4395 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4397 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4400 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4401 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4402 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4403 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4405 while (nl < b->end && *nl != 0xd)
4407 if (nl < b->end && *nl == 0xd) {
4409 if (nl + 1 < b->end) {
4416 * Not CR,LF but just CR
4424 * Blast - found CR as last char in buffer
4429 * They may not care, defer work as long as
4433 return (nl - b->ptr);
4437 b->ptr++; /* say we have read it as far as
4438 * flush() is concerned */
4439 b->buf++; /* Leave space in front of buffer */
4440 /* Note as we have moved buf up flush's
4442 will naturally make posn point at CR
4444 b->bufsiz--; /* Buffer is thus smaller */
4445 code = PerlIO_fill(f); /* Fetch some more */
4446 b->bufsiz++; /* Restore size for next time */
4447 b->buf--; /* Point at space */
4448 b->ptr = nl = b->buf; /* Which is what we hand
4450 *nl = 0xd; /* Fill in the CR */
4452 goto test; /* fill() call worked */
4454 * CR at EOF - just fall through
4456 /* Should we clear EOF though ??? */
4461 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4467 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4469 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4470 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4476 if (ptr == b->end && *c->nl == 0xd) {
4477 /* Defered CR at end of buffer case - we lied about count */
4490 * Test code - delete when it works ...
4492 IV flags = PerlIOBase(f)->flags;
4493 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4494 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4495 /* Defered CR at end of buffer case - we lied about count */
4501 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4502 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4503 flags, c->nl, b->end, cnt);
4510 * They have taken what we lied about
4518 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4522 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4524 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4525 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4527 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4528 const STDCHAR *buf = (const STDCHAR *) vbuf;
4529 const STDCHAR * const ebuf = buf + count;
4532 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4534 while (buf < ebuf) {
4535 const STDCHAR * const eptr = b->buf + b->bufsiz;
4536 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4537 while (buf < ebuf && b->ptr < eptr) {
4539 if ((b->ptr + 2) > eptr) {
4547 *(b->ptr)++ = 0xd; /* CR */
4548 *(b->ptr)++ = 0xa; /* LF */
4550 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4557 *(b->ptr)++ = *buf++;
4559 if (b->ptr >= eptr) {
4565 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4567 return (buf - (STDCHAR *) vbuf);
4572 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4574 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4579 return PerlIOBuf_flush(aTHX_ f);
4583 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4585 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4586 /* In text mode - flush any pending stuff and flip it */
4587 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4588 #ifndef PERLIO_USING_CRLF
4589 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4590 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4591 PerlIO_pop(aTHX_ f);
4598 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4599 sizeof(PerlIO_funcs),
4602 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4604 PerlIOBuf_popped, /* popped */
4606 PerlIOCrlf_binmode, /* binmode */
4610 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4611 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4612 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4620 PerlIOBase_clearerr,
4621 PerlIOBase_setlinebuf,
4626 PerlIOCrlf_set_ptrcnt,
4630 /*--------------------------------------------------------------------------------------*/
4632 * mmap as "buffer" layer
4636 PerlIOBuf base; /* PerlIOBuf stuff */
4637 Mmap_t mptr; /* Mapped address */
4638 Size_t len; /* mapped length */
4639 STDCHAR *bbuf; /* malloced buffer if map fails */
4643 PerlIOMmap_map(pTHX_ PerlIO *f)
4646 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4647 const IV flags = PerlIOBase(f)->flags;
4651 if (flags & PERLIO_F_CANREAD) {
4652 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4653 const int fd = PerlIO_fileno(f);
4655 code = Fstat(fd, &st);
4656 if (code == 0 && S_ISREG(st.st_mode)) {
4657 SSize_t len = st.st_size - b->posn;
4660 if (PL_mmap_page_size <= 0)
4661 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4665 * This is a hack - should never happen - open should
4668 b->posn = PerlIO_tell(PerlIONext(f));
4670 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4671 len = st.st_size - posn;
4672 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4673 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4674 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4675 madvise(m->mptr, len, MADV_SEQUENTIAL);
4677 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4678 madvise(m->mptr, len, MADV_WILLNEED);
4680 PerlIOBase(f)->flags =
4681 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4682 b->end = ((STDCHAR *) m->mptr) + len;
4683 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4692 PerlIOBase(f)->flags =
4693 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4695 b->ptr = b->end = b->ptr;
4704 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4706 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4709 PerlIOBuf * const b = &m->base;
4711 /* The munmap address argument is tricky: depending on the
4712 * standard it is either "void *" or "caddr_t" (which is
4713 * usually "char *" (signed or unsigned). If we cast it
4714 * to "void *", those that have it caddr_t and an uptight
4715 * C++ compiler, will freak out. But casting it as char*
4716 * should work. Maybe. (Using Mmap_t figured out by
4717 * Configure doesn't always work, apparently.) */
4718 code = munmap((char*)m->mptr, m->len);
4722 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4725 b->ptr = b->end = b->buf;
4726 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4732 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4734 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4735 PerlIOBuf * const b = &m->base;
4736 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4738 * Already have a readbuffer in progress
4744 * We have a write buffer or flushed PerlIOBuf read buffer
4746 m->bbuf = b->buf; /* save it in case we need it again */
4747 b->buf = NULL; /* Clear to trigger below */
4750 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4753 * Map did not work - recover PerlIOBuf buffer if we have one
4758 b->ptr = b->end = b->buf;
4761 return PerlIOBuf_get_base(aTHX_ f);
4765 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4767 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4768 PerlIOBuf * const b = &m->base;
4769 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4771 if (b->ptr && (b->ptr - count) >= b->buf
4772 && memEQ(b->ptr - count, vbuf, count)) {
4774 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4779 * Loose the unwritable mapped buffer
4783 * If flush took the "buffer" see if we have one from before
4785 if (!b->buf && m->bbuf)
4788 PerlIOBuf_get_base(aTHX_ f);
4792 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4796 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4798 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4799 PerlIOBuf * const b = &m->base;
4801 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4803 * No, or wrong sort of, buffer
4806 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4810 * If unmap took the "buffer" see if we have one from before
4812 if (!b->buf && m->bbuf)
4815 PerlIOBuf_get_base(aTHX_ f);
4819 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4823 PerlIOMmap_flush(pTHX_ PerlIO *f)
4825 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4826 PerlIOBuf * const b = &m->base;
4827 IV code = PerlIOBuf_flush(aTHX_ f);
4829 * Now we are "synced" at PerlIOBuf level
4836 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4841 * We seem to have a PerlIOBuf buffer which was not mapped
4842 * remember it in case we need one later
4851 PerlIOMmap_fill(pTHX_ PerlIO *f)
4853 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4854 IV code = PerlIO_flush(f);
4855 if (code == 0 && !b->buf) {
4856 code = PerlIOMmap_map(aTHX_ f);
4858 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4859 code = PerlIOBuf_fill(aTHX_ f);
4865 PerlIOMmap_close(pTHX_ PerlIO *f)
4867 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4868 PerlIOBuf * const b = &m->base;
4869 IV code = PerlIO_flush(f);
4873 b->ptr = b->end = b->buf;
4875 if (PerlIOBuf_close(aTHX_ f) != 0)
4881 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4883 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4887 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4888 sizeof(PerlIO_funcs),
4891 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4895 PerlIOBase_binmode, /* binmode */
4909 PerlIOBase_clearerr,
4910 PerlIOBase_setlinebuf,
4911 PerlIOMmap_get_base,
4915 PerlIOBuf_set_ptrcnt,
4918 #endif /* HAS_MMAP */
4921 Perl_PerlIO_stdin(pTHX)
4925 PerlIO_stdstreams(aTHX);
4927 return &PL_perlio[1];
4931 Perl_PerlIO_stdout(pTHX)
4935 PerlIO_stdstreams(aTHX);
4937 return &PL_perlio[2];
4941 Perl_PerlIO_stderr(pTHX)
4945 PerlIO_stdstreams(aTHX);
4947 return &PL_perlio[3];
4950 /*--------------------------------------------------------------------------------------*/
4953 PerlIO_getname(PerlIO *f, char *buf)
4958 bool exported = FALSE;
4959 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4961 stdio = PerlIO_exportFILE(f,0);
4965 name = fgetname(stdio, buf);
4966 if (exported) PerlIO_releaseFILE(f,stdio);
4971 PERL_UNUSED_ARG(buf);
4972 Perl_croak(aTHX_ "Don't know how to get file name");
4978 /*--------------------------------------------------------------------------------------*/
4980 * Functions which can be called on any kind of PerlIO implemented in
4984 #undef PerlIO_fdopen
4986 PerlIO_fdopen(int fd, const char *mode)
4989 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4994 PerlIO_open(const char *path, const char *mode)
4997 SV *name = sv_2mortal(newSVpv(path, 0));
4998 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5001 #undef Perlio_reopen
5003 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5006 SV *name = sv_2mortal(newSVpv(path,0));
5007 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5012 PerlIO_getc(PerlIO *f)
5016 if ( 1 == PerlIO_read(f, buf, 1) ) {
5017 return (unsigned char) buf[0];
5022 #undef PerlIO_ungetc
5024 PerlIO_ungetc(PerlIO *f, int ch)
5029 if (PerlIO_unread(f, &buf, 1) == 1)
5037 PerlIO_putc(PerlIO *f, int ch)
5041 return PerlIO_write(f, &buf, 1);
5046 PerlIO_puts(PerlIO *f, const char *s)
5049 return PerlIO_write(f, s, strlen(s));
5052 #undef PerlIO_rewind
5054 PerlIO_rewind(PerlIO *f)
5057 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5061 #undef PerlIO_vprintf
5063 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5072 Perl_va_copy(ap, apc);
5073 sv = vnewSVpvf(fmt, &apc);
5075 sv = vnewSVpvf(fmt, &ap);
5077 s = SvPV_const(sv, len);
5078 wrote = PerlIO_write(f, s, len);
5083 #undef PerlIO_printf
5085 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5090 result = PerlIO_vprintf(f, fmt, ap);
5095 #undef PerlIO_stdoutf
5097 PerlIO_stdoutf(const char *fmt, ...)
5103 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5108 #undef PerlIO_tmpfile
5110 PerlIO_tmpfile(void)
5115 const int fd = win32_tmpfd();
5117 f = PerlIO_fdopen(fd, "w+b");
5119 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5120 SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
5122 * I have no idea how portable mkstemp() is ... NI-S
5124 const int fd = mkstemp(SvPVX(sv));
5126 f = PerlIO_fdopen(fd, "w+");
5128 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5129 PerlLIO_unlink(SvPVX_const(sv));
5132 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5133 FILE * const stdio = PerlSIO_tmpfile();
5136 f = PerlIO_fdopen(fileno(stdio), "w+");
5138 # endif /* else HAS_MKSTEMP */
5139 #endif /* else WIN32 */
5146 #endif /* USE_SFIO */
5147 #endif /* PERLIO_IS_STDIO */
5149 /*======================================================================================*/
5151 * Now some functions in terms of above which may be needed even if we are
5152 * not in true PerlIO mode
5155 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5158 const char *direction = NULL;
5161 * Need to supply default layer info from open.pm
5167 if (mode && mode[0] != 'r') {
5168 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5169 direction = "open>";
5171 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5172 direction = "open<";
5177 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5178 0, direction, 5, 0, 0);
5181 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5186 #undef PerlIO_setpos
5188 PerlIO_setpos(PerlIO *f, SV *pos)
5193 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5194 if (f && len == sizeof(Off_t))
5195 return PerlIO_seek(f, *posn, SEEK_SET);
5197 SETERRNO(EINVAL, SS_IVCHAN);
5201 #undef PerlIO_setpos
5203 PerlIO_setpos(PerlIO *f, SV *pos)
5208 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5209 if (f && len == sizeof(Fpos_t)) {
5210 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5211 return fsetpos64(f, fpos);
5213 return fsetpos(f, fpos);
5217 SETERRNO(EINVAL, SS_IVCHAN);
5223 #undef PerlIO_getpos
5225 PerlIO_getpos(PerlIO *f, SV *pos)
5228 Off_t posn = PerlIO_tell(f);
5229 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5230 return (posn == (Off_t) - 1) ? -1 : 0;
5233 #undef PerlIO_getpos
5235 PerlIO_getpos(PerlIO *f, SV *pos)
5240 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5241 code = fgetpos64(f, &fpos);
5243 code = fgetpos(f, &fpos);
5245 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5250 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5253 vprintf(char *pat, char *args)
5255 _doprnt(pat, args, stdout);
5256 return 0; /* wrong, but perl doesn't use the return
5261 vfprintf(FILE *fd, char *pat, char *args)
5263 _doprnt(pat, args, fd);
5264 return 0; /* wrong, but perl doesn't use the return
5270 #ifndef PerlIO_vsprintf
5272 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5275 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5276 PERL_UNUSED_CONTEXT;
5278 #ifndef PERL_MY_VSNPRINTF_GUARDED
5279 if (val < 0 || (n > 0 ? val >= n : 0)) {
5280 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5287 #ifndef PerlIO_sprintf
5289 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5294 result = PerlIO_vsprintf(s, n, fmt, ap);
5302 * c-indentation-style: bsd
5304 * indent-tabs-mode: t
5307 * ex: set ts=8 sts=4 sw=4 noet: