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 SV * const name = l->tab && l->tab->name ?
763 newSVpv(l->tab->name, 0) : &PL_sv_undef;
764 SV * const arg = l->tab && l->tab->Getarg ?
765 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
768 av_push(av, newSViv((IV)l->flags));
776 /*--------------------------------------------------------------------------------------*/
778 * XS Interface for perl code
782 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
786 if ((SSize_t) len <= 0)
788 for (i = 0; i < PL_known_layers->cur; i++) {
789 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
790 if (memEQ(f->name, name, len) && f->name[len] == 0) {
791 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
795 if (load && PL_subname && PL_def_layerlist
796 && PL_def_layerlist->cur >= 2) {
797 if (PL_in_load_module) {
798 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
801 SV * const pkgsv = newSVpvs("PerlIO");
802 SV * const layer = newSVpvn(name, len);
803 CV * const cv = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0);
805 SAVEINT(PL_in_load_module);
807 SAVEGENERICSV(PL_warnhook);
808 PL_warnhook = (SV *) (SvREFCNT_inc_simple_NN(cv));
812 * The two SVs are magically freed by load_module
814 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
817 return PerlIO_find_layer(aTHX_ name, len, 0);
820 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
824 #ifdef USE_ATTRIBUTES_FOR_PERLIO
827 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
830 IO * const io = GvIOn((GV *) SvRV(sv));
831 PerlIO * const ifp = IoIFP(io);
832 PerlIO * const ofp = IoOFP(io);
833 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
834 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
840 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
843 IO * const io = GvIOn((GV *) SvRV(sv));
844 PerlIO * const ifp = IoIFP(io);
845 PerlIO * const ofp = IoOFP(io);
846 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
847 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
853 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
855 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
860 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
862 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
866 MGVTBL perlio_vtab = {
874 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
877 SV * const sv = SvRV(ST(1));
878 AV * const av = newAV();
882 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
884 mg = mg_find(sv, PERL_MAGIC_ext);
885 mg->mg_virtual = &perlio_vtab;
887 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
888 for (i = 2; i < items; i++) {
890 const char * const name = SvPV_const(ST(i), len);
891 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
893 av_push(av, SvREFCNT_inc_simple_NN(layer));
904 #endif /* USE_ATTIBUTES_FOR_PERLIO */
907 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
909 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
910 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
914 XS(XS_PerlIO__Layer__NoWarnings)
916 /* This is used as a %SIG{__WARN__} handler to supress warnings
917 during loading of layers.
923 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
927 XS(XS_PerlIO__Layer__find)
933 Perl_croak(aTHX_ "Usage class->find(name[,load])");
936 const char * const name = SvPV_const(ST(1), len);
937 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
938 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
940 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
947 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
950 if (!PL_known_layers)
951 PL_known_layers = PerlIO_list_alloc(aTHX);
952 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
953 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
957 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
961 const char *s = names;
963 while (isSPACE(*s) || *s == ':')
968 const char *as = NULL;
970 if (!isIDFIRST(*s)) {
972 * Message is consistent with how attribute lists are
973 * passed. Even though this means "foo : : bar" is
974 * seen as an invalid separator character.
976 const char q = ((*s == '\'') ? '"' : '\'');
977 if (ckWARN(WARN_LAYER))
978 Perl_warner(aTHX_ packWARN(WARN_LAYER),
979 "Invalid separator character %c%c%c in PerlIO layer specification %s",
981 SETERRNO(EINVAL, LIB_INVARG);
986 } while (isALNUM(*e));
1002 * It's a nul terminated string, not allowed
1003 * to \ the terminating null. Anything other
1004 * character is passed over.
1014 if (ckWARN(WARN_LAYER))
1015 Perl_warner(aTHX_ packWARN(WARN_LAYER),
1016 "Argument list not closed for PerlIO layer \"%.*s\"",
1028 PerlIO_funcs * const layer =
1029 PerlIO_find_layer(aTHX_ s, llen, 1);
1033 arg = newSVpvn(as, alen);
1034 PerlIO_list_push(aTHX_ av, layer,
1035 (arg) ? arg : &PL_sv_undef);
1040 if (ckWARN(WARN_LAYER))
1041 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1054 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1057 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1058 #ifdef PERLIO_USING_CRLF
1061 if (PerlIO_stdio.Set_ptrcnt)
1062 tab = &PerlIO_stdio;
1064 PerlIO_debug("Pushing %s\n", tab->name);
1065 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1070 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1072 return av->array[n].arg;
1076 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1078 if (n >= 0 && n < av->cur) {
1079 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1080 av->array[n].funcs->name);
1081 return av->array[n].funcs;
1084 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1089 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1091 PERL_UNUSED_ARG(mode);
1092 PERL_UNUSED_ARG(arg);
1093 PERL_UNUSED_ARG(tab);
1094 if (PerlIOValid(f)) {
1096 PerlIO_pop(aTHX_ f);
1102 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1103 sizeof(PerlIO_funcs),
1106 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1126 NULL, /* get_base */
1127 NULL, /* get_bufsiz */
1130 NULL, /* set_ptrcnt */
1134 PerlIO_default_layers(pTHX)
1137 if (!PL_def_layerlist) {
1138 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
1139 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1140 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1141 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1143 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1145 osLayer = &PerlIO_win32;
1148 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1149 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1150 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1151 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1153 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
1155 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1156 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1157 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1158 PerlIO_list_push(aTHX_ PL_def_layerlist,
1159 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1162 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1165 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1168 if (PL_def_layerlist->cur < 2) {
1169 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1171 return PL_def_layerlist;
1175 Perl_boot_core_PerlIO(pTHX)
1177 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1178 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1181 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1182 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1186 PerlIO_default_layer(pTHX_ I32 n)
1189 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1192 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1195 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1196 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1199 PerlIO_stdstreams(pTHX)
1203 PerlIO_allocate(aTHX);
1204 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1205 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1206 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1211 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1213 if (tab->fsize != sizeof(PerlIO_funcs)) {
1215 Perl_croak(aTHX_ "Layer does not match this perl");
1219 if (tab->size < sizeof(PerlIOl)) {
1222 /* Real layer with a data area */
1225 Newxz(temp, tab->size, char);
1229 l->tab = (PerlIO_funcs*) tab;
1231 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1232 (void*)f, tab->name,
1233 (mode) ? mode : "(Null)", (void*)arg);
1234 if (*l->tab->Pushed &&
1236 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1237 PerlIO_pop(aTHX_ f);
1246 /* Pseudo-layer where push does its own stack adjust */
1247 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1248 (mode) ? mode : "(Null)", (void*)arg);
1250 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1258 PerlIOBase_binmode(pTHX_ PerlIO *f)
1260 if (PerlIOValid(f)) {
1261 /* Is layer suitable for raw stream ? */
1262 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1263 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1264 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1267 /* Not suitable - pop it */
1268 PerlIO_pop(aTHX_ f);
1276 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1278 PERL_UNUSED_ARG(mode);
1279 PERL_UNUSED_ARG(arg);
1280 PERL_UNUSED_ARG(tab);
1282 if (PerlIOValid(f)) {
1287 * Strip all layers that are not suitable for a raw stream
1290 while (t && (l = *t)) {
1291 if (l->tab->Binmode) {
1292 /* Has a handler - normal case */
1293 if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1295 /* Layer still there - move down a layer */
1304 /* No handler - pop it */
1305 PerlIO_pop(aTHX_ t);
1308 if (PerlIOValid(f)) {
1309 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1317 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1318 PerlIO_list_t *layers, IV n, IV max)
1322 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1324 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1335 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1339 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1340 code = PerlIO_parse_layers(aTHX_ layers, names);
1342 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1344 PerlIO_list_free(aTHX_ layers);
1350 /*--------------------------------------------------------------------------------------*/
1352 * Given the abstraction above the public API functions
1356 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1358 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1359 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1360 iotype, mode, (names) ? names : "(Null)");
1363 /* Do not flush etc. if (e.g.) switching encodings.
1364 if a pushed layer knows it needs to flush lower layers
1365 (for example :unix which is never going to call them)
1366 it can do the flush when it is pushed.
1368 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1371 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1372 #ifdef PERLIO_USING_CRLF
1373 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1374 O_BINARY so we can look for it in mode.
1376 if (!(mode & O_BINARY)) {
1378 /* FIXME?: Looking down the layer stack seems wrong,
1379 but is a way of reaching past (say) an encoding layer
1380 to flip CRLF-ness of the layer(s) below
1383 /* Perhaps we should turn on bottom-most aware layer
1384 e.g. Ilya's idea that UNIX TTY could serve
1386 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1387 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1388 /* Not in text mode - flush any pending stuff and flip it */
1390 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1392 /* Only need to turn it on in one layer so we are done */
1397 /* Not finding a CRLF aware layer presumably means we are binary
1398 which is not what was requested - so we failed
1399 We _could_ push :crlf layer but so could caller
1404 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1405 So code that used to be here is now in PerlIORaw_pushed().
1407 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1412 PerlIO__close(pTHX_ PerlIO *f)
1414 if (PerlIOValid(f)) {
1415 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1416 if (tab && tab->Close)
1417 return (*tab->Close)(aTHX_ f);
1419 return PerlIOBase_close(aTHX_ f);
1422 SETERRNO(EBADF, SS_IVCHAN);
1428 Perl_PerlIO_close(pTHX_ PerlIO *f)
1430 const int code = PerlIO__close(aTHX_ f);
1431 while (PerlIOValid(f)) {
1432 PerlIO_pop(aTHX_ f);
1438 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1441 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1445 static PerlIO_funcs *
1446 PerlIO_layer_from_ref(pTHX_ SV *sv)
1450 * For any scalar type load the handler which is bundled with perl
1452 if (SvTYPE(sv) < SVt_PVAV) {
1453 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1454 /* This isn't supposed to happen, since PerlIO::scalar is core,
1455 * but could happen anyway in smaller installs or with PAR */
1456 if (!f && ckWARN(WARN_LAYER))
1457 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1462 * For other types allow if layer is known but don't try and load it
1464 switch (SvTYPE(sv)) {
1466 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1468 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1470 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1472 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1479 PerlIO_resolve_layers(pTHX_ const char *layers,
1480 const char *mode, int narg, SV **args)
1483 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1486 PerlIO_stdstreams(aTHX);
1488 SV * const arg = *args;
1490 * If it is a reference but not an object see if we have a handler
1493 if (SvROK(arg) && !sv_isobject(arg)) {
1494 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1496 def = PerlIO_list_alloc(aTHX);
1497 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1501 * Don't fail if handler cannot be found :via(...) etc. may do
1502 * something sensible else we will just stringfy and open
1507 if (!layers || !*layers)
1508 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1509 if (layers && *layers) {
1512 av = PerlIO_clone_list(aTHX_ def, NULL);
1517 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1521 PerlIO_list_free(aTHX_ av);
1533 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1534 int imode, int perm, PerlIO *f, int narg, SV **args)
1537 if (!f && narg == 1 && *args == &PL_sv_undef) {
1538 if ((f = PerlIO_tmpfile())) {
1539 if (!layers || !*layers)
1540 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1541 if (layers && *layers)
1542 PerlIO_apply_layers(aTHX_ f, mode, layers);
1546 PerlIO_list_t *layera;
1548 PerlIO_funcs *tab = NULL;
1549 if (PerlIOValid(f)) {
1551 * This is "reopen" - it is not tested as perl does not use it
1555 layera = PerlIO_list_alloc(aTHX);
1559 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1560 PerlIO_list_push(aTHX_ layera, l->tab,
1561 (arg) ? arg : &PL_sv_undef);
1564 l = *PerlIONext(&l);
1568 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1574 * Start at "top" of layer stack
1576 n = layera->cur - 1;
1578 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1587 * Found that layer 'n' can do opens - call it
1589 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1590 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1592 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1593 tab->name, layers ? layers : "(Null)", mode, fd,
1594 imode, perm, (void*)f, narg, (void*)args);
1596 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1599 SETERRNO(EINVAL, LIB_INVARG);
1603 if (n + 1 < layera->cur) {
1605 * More layers above the one that we used to open -
1608 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1609 /* If pushing layers fails close the file */
1616 PerlIO_list_free(aTHX_ layera);
1623 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1625 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1629 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1631 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1635 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1637 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1641 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1643 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1647 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1649 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1653 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1658 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1660 if (tab && tab->Flush)
1661 return (*tab->Flush) (aTHX_ f);
1663 return 0; /* If no Flush defined, silently succeed. */
1666 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1667 SETERRNO(EBADF, SS_IVCHAN);
1673 * Is it good API design to do flush-all on NULL, a potentially
1674 * errorneous input? Maybe some magical value (PerlIO*
1675 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1676 * things on fflush(NULL), but should we be bound by their design
1679 PerlIO **table = &PL_perlio;
1681 while ((f = *table)) {
1683 table = (PerlIO **) (f++);
1684 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1685 if (*f && PerlIO_flush(f) != 0)
1695 PerlIOBase_flush_linebuf(pTHX)
1698 PerlIO **table = &PL_perlio;
1700 while ((f = *table)) {
1702 table = (PerlIO **) (f++);
1703 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1706 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1707 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1715 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1717 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1721 PerlIO_isutf8(PerlIO *f)
1724 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1726 SETERRNO(EBADF, SS_IVCHAN);
1732 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1734 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1738 Perl_PerlIO_error(pTHX_ PerlIO *f)
1740 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1744 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1746 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1750 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1752 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1756 PerlIO_has_base(PerlIO *f)
1758 if (PerlIOValid(f)) {
1759 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1762 return (tab->Get_base != NULL);
1763 SETERRNO(EINVAL, LIB_INVARG);
1766 SETERRNO(EBADF, SS_IVCHAN);
1772 PerlIO_fast_gets(PerlIO *f)
1774 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1775 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1778 return (tab->Set_ptrcnt != NULL);
1779 SETERRNO(EINVAL, LIB_INVARG);
1782 SETERRNO(EBADF, SS_IVCHAN);
1788 PerlIO_has_cntptr(PerlIO *f)
1790 if (PerlIOValid(f)) {
1791 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1794 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1795 SETERRNO(EINVAL, LIB_INVARG);
1798 SETERRNO(EBADF, SS_IVCHAN);
1804 PerlIO_canset_cnt(PerlIO *f)
1806 if (PerlIOValid(f)) {
1807 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1810 return (tab->Set_ptrcnt != NULL);
1811 SETERRNO(EINVAL, LIB_INVARG);
1814 SETERRNO(EBADF, SS_IVCHAN);
1820 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1822 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1826 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1828 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1832 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1834 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1838 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1840 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1844 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1846 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1850 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1852 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1856 /*--------------------------------------------------------------------------------------*/
1858 * utf8 and raw dummy layers
1862 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1864 PERL_UNUSED_CONTEXT;
1865 PERL_UNUSED_ARG(mode);
1866 PERL_UNUSED_ARG(arg);
1867 if (PerlIOValid(f)) {
1868 if (tab->kind & PERLIO_K_UTF8)
1869 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1871 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1877 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1878 sizeof(PerlIO_funcs),
1881 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1901 NULL, /* get_base */
1902 NULL, /* get_bufsiz */
1905 NULL, /* set_ptrcnt */
1908 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1909 sizeof(PerlIO_funcs),
1932 NULL, /* get_base */
1933 NULL, /* get_bufsiz */
1936 NULL, /* set_ptrcnt */
1940 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1941 IV n, const char *mode, int fd, int imode, int perm,
1942 PerlIO *old, int narg, SV **args)
1944 PerlIO_funcs * const tab = PerlIO_default_btm();
1945 PERL_UNUSED_ARG(self);
1946 if (tab && tab->Open)
1947 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1949 SETERRNO(EINVAL, LIB_INVARG);
1953 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1954 sizeof(PerlIO_funcs),
1977 NULL, /* get_base */
1978 NULL, /* get_bufsiz */
1981 NULL, /* set_ptrcnt */
1983 /*--------------------------------------------------------------------------------------*/
1984 /*--------------------------------------------------------------------------------------*/
1986 * "Methods" of the "base class"
1990 PerlIOBase_fileno(pTHX_ PerlIO *f)
1992 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1996 PerlIO_modestr(PerlIO * f, char *buf)
1999 if (PerlIOValid(f)) {
2000 const IV flags = PerlIOBase(f)->flags;
2001 if (flags & PERLIO_F_APPEND) {
2003 if (flags & PERLIO_F_CANREAD) {
2007 else if (flags & PERLIO_F_CANREAD) {
2009 if (flags & PERLIO_F_CANWRITE)
2012 else if (flags & PERLIO_F_CANWRITE) {
2014 if (flags & PERLIO_F_CANREAD) {
2018 #ifdef PERLIO_USING_CRLF
2019 if (!(flags & PERLIO_F_CRLF))
2029 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2031 PerlIOl * const l = PerlIOBase(f);
2032 PERL_UNUSED_CONTEXT;
2033 PERL_UNUSED_ARG(arg);
2035 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2036 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2037 if (tab->Set_ptrcnt != NULL)
2038 l->flags |= PERLIO_F_FASTGETS;
2040 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2044 l->flags |= PERLIO_F_CANREAD;
2047 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2050 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2053 SETERRNO(EINVAL, LIB_INVARG);
2059 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2062 l->flags &= ~PERLIO_F_CRLF;
2065 l->flags |= PERLIO_F_CRLF;
2068 SETERRNO(EINVAL, LIB_INVARG);
2075 l->flags |= l->next->flags &
2076 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2081 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2082 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2083 l->flags, PerlIO_modestr(f, temp));
2089 PerlIOBase_popped(pTHX_ PerlIO *f)
2091 PERL_UNUSED_CONTEXT;
2097 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2100 * Save the position as current head considers it
2102 const Off_t old = PerlIO_tell(f);
2103 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2104 PerlIOSelf(f, PerlIOBuf)->posn = old;
2105 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2109 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2111 STDCHAR *buf = (STDCHAR *) vbuf;
2113 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2114 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2115 SETERRNO(EBADF, SS_IVCHAN);
2121 SSize_t avail = PerlIO_get_cnt(f);
2124 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
2126 STDCHAR *ptr = PerlIO_get_ptr(f);
2127 Copy(ptr, buf, take, STDCHAR);
2128 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2131 if (avail == 0) /* set_ptrcnt could have reset avail */
2134 if (count > 0 && avail <= 0) {
2135 if (PerlIO_fill(f) != 0)
2140 return (buf - (STDCHAR *) vbuf);
2146 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2148 PERL_UNUSED_CONTEXT;
2154 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2156 PERL_UNUSED_CONTEXT;
2162 PerlIOBase_close(pTHX_ PerlIO *f)
2165 if (PerlIOValid(f)) {
2166 PerlIO *n = PerlIONext(f);
2167 code = PerlIO_flush(f);
2168 PerlIOBase(f)->flags &=
2169 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2170 while (PerlIOValid(n)) {
2171 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2172 if (tab && tab->Close) {
2173 if ((*tab->Close)(aTHX_ n) != 0)
2178 PerlIOBase(n)->flags &=
2179 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2185 SETERRNO(EBADF, SS_IVCHAN);
2191 PerlIOBase_eof(pTHX_ PerlIO *f)
2193 PERL_UNUSED_CONTEXT;
2194 if (PerlIOValid(f)) {
2195 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2201 PerlIOBase_error(pTHX_ PerlIO *f)
2203 PERL_UNUSED_CONTEXT;
2204 if (PerlIOValid(f)) {
2205 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2211 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2213 if (PerlIOValid(f)) {
2214 PerlIO * const n = PerlIONext(f);
2215 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2222 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2224 PERL_UNUSED_CONTEXT;
2225 if (PerlIOValid(f)) {
2226 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2231 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2237 arg = sv_dup(arg, param);
2238 SvREFCNT_inc_simple_void_NN(arg);
2242 return newSVsv(arg);
2245 PERL_UNUSED_ARG(param);
2246 return newSVsv(arg);
2251 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2253 PerlIO * const nexto = PerlIONext(o);
2254 if (PerlIOValid(nexto)) {
2255 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2256 if (tab && tab->Dup)
2257 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2259 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2262 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2265 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2266 self->name, (void*)f, (void*)o, (void*)param);
2268 arg = (*self->Getarg)(aTHX_ o, param, flags);
2269 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2270 if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
2271 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2278 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2280 /* Must be called with PL_perlio_mutex locked. */
2282 S_more_refcounted_fds(pTHX_ const int new_fd) {
2284 const int old_max = PL_perlio_fd_refcnt_size;
2285 const int new_max = 16 + (new_fd & ~15);
2288 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2289 old_max, new_fd, new_max);
2291 if (new_fd < old_max) {
2295 assert (new_max > new_fd);
2297 /* Use plain realloc() since we need this memory to be really
2298 * global and visible to all the interpreters and/or threads. */
2299 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2303 MUTEX_UNLOCK(&PL_perlio_mutex);
2305 /* Can't use PerlIO to write as it allocates memory */
2306 PerlLIO_write(PerlIO_fileno(Perl_error_log),
2307 PL_no_mem, strlen(PL_no_mem));
2311 PL_perlio_fd_refcnt_size = new_max;
2312 PL_perlio_fd_refcnt = new_array;
2314 PerlIO_debug("Zeroing %p, %d\n",
2315 (void*)(new_array + old_max),
2318 Zero(new_array + old_max, new_max - old_max, int);
2325 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2326 PERL_UNUSED_CONTEXT;
2330 PerlIOUnix_refcnt_inc(int fd)
2337 MUTEX_LOCK(&PL_perlio_mutex);
2339 if (fd >= PL_perlio_fd_refcnt_size)
2340 S_more_refcounted_fds(aTHX_ fd);
2342 PL_perlio_fd_refcnt[fd]++;
2343 if (PL_perlio_fd_refcnt[fd] <= 0) {
2344 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2345 fd, PL_perlio_fd_refcnt[fd]);
2347 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2348 fd, PL_perlio_fd_refcnt[fd]);
2351 MUTEX_UNLOCK(&PL_perlio_mutex);
2354 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2359 PerlIOUnix_refcnt_dec(int fd)
2366 MUTEX_LOCK(&PL_perlio_mutex);
2368 if (fd >= PL_perlio_fd_refcnt_size) {
2369 Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n",
2370 fd, PL_perlio_fd_refcnt_size);
2372 if (PL_perlio_fd_refcnt[fd] <= 0) {
2373 Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n",
2374 fd, PL_perlio_fd_refcnt[fd]);
2376 cnt = --PL_perlio_fd_refcnt[fd];
2377 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2379 MUTEX_UNLOCK(&PL_perlio_mutex);
2382 Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd);
2388 PerlIO_cleanup(pTHX)
2393 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2395 PerlIO_debug("Cleanup layers\n");
2398 /* Raise STDIN..STDERR refcount so we don't close them */
2399 for (i=0; i < 3; i++)
2400 PerlIOUnix_refcnt_inc(i);
2401 PerlIO_cleantable(aTHX_ &PL_perlio);
2402 /* Restore STDIN..STDERR refcount */
2403 for (i=0; i < 3; i++)
2404 PerlIOUnix_refcnt_dec(i);
2406 if (PL_known_layers) {
2407 PerlIO_list_free(aTHX_ PL_known_layers);
2408 PL_known_layers = NULL;
2410 if (PL_def_layerlist) {
2411 PerlIO_list_free(aTHX_ PL_def_layerlist);
2412 PL_def_layerlist = NULL;
2416 void PerlIO_teardown() /* Call only from PERL_SYS_TERM(). */
2420 /* XXX we can't rely on an interpreter being present at this late stage,
2421 XXX so we can't use a function like PerlLIO_write that relies on one
2422 being present (at least in win32) :-(.
2427 /* By now all filehandles should have been closed, so any
2428 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2430 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2431 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2432 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2434 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2435 if (PL_perlio_fd_refcnt[i]) {
2437 my_snprintf(buf, sizeof(buf),
2438 "PerlIO_teardown: fd %d refcnt=%d\n",
2439 i, PL_perlio_fd_refcnt[i]);
2440 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2446 /* Not bothering with PL_perlio_mutex since by now
2447 * all the interpreters are gone. */
2448 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2449 && PL_perlio_fd_refcnt) {
2450 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2451 PL_perlio_fd_refcnt = NULL;
2452 PL_perlio_fd_refcnt_size = 0;
2456 /*--------------------------------------------------------------------------------------*/
2458 * Bottom-most level for UNIX-like case
2462 struct _PerlIO base; /* The generic part */
2463 int fd; /* UNIX like file descriptor */
2464 int oflags; /* open/fcntl flags */
2468 PerlIOUnix_oflags(const char *mode)
2471 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2476 if (*++mode == '+') {
2483 oflags = O_CREAT | O_TRUNC;
2484 if (*++mode == '+') {
2493 oflags = O_CREAT | O_APPEND;
2494 if (*++mode == '+') {
2507 else if (*mode == 't') {
2509 oflags &= ~O_BINARY;
2513 * Always open in binary mode
2516 if (*mode || oflags == -1) {
2517 SETERRNO(EINVAL, LIB_INVARG);
2524 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2526 PERL_UNUSED_CONTEXT;
2527 return PerlIOSelf(f, PerlIOUnix)->fd;
2531 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2533 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2536 if (PerlLIO_fstat(fd, &st) == 0) {
2537 if (!S_ISREG(st.st_mode)) {
2538 PerlIO_debug("%d is not regular file\n",fd);
2539 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2542 PerlIO_debug("%d _is_ a regular file\n",fd);
2548 PerlIOUnix_refcnt_inc(fd);
2549 PERL_UNUSED_CONTEXT;
2553 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2555 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2556 if (*PerlIONext(f)) {
2557 /* We never call down so do any pending stuff now */
2558 PerlIO_flush(PerlIONext(f));
2560 * XXX could (or should) we retrieve the oflags from the open file
2561 * handle rather than believing the "mode" we are passed in? XXX
2562 * Should the value on NULL mode be 0 or -1?
2564 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2565 mode ? PerlIOUnix_oflags(mode) : -1);
2567 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2573 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2575 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2577 PERL_UNUSED_CONTEXT;
2578 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2580 SETERRNO(ESPIPE, LIB_INVARG);
2582 SETERRNO(EINVAL, LIB_INVARG);
2586 new_loc = PerlLIO_lseek(fd, offset, whence);
2587 if (new_loc == (Off_t) - 1)
2589 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2594 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2595 IV n, const char *mode, int fd, int imode,
2596 int perm, PerlIO *f, int narg, SV **args)
2598 if (PerlIOValid(f)) {
2599 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2600 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2603 if (*mode == IoTYPE_NUMERIC)
2606 imode = PerlIOUnix_oflags(mode);
2610 const char *path = SvPV_nolen_const(*args);
2611 fd = PerlLIO_open3(path, imode, perm);
2615 if (*mode == IoTYPE_IMPLICIT)
2618 f = PerlIO_allocate(aTHX);
2620 if (!PerlIOValid(f)) {
2621 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2625 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2626 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2627 if (*mode == IoTYPE_APPEND)
2628 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2635 * FIXME: pop layers ???
2643 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2645 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2647 if (flags & PERLIO_DUP_FD) {
2648 fd = PerlLIO_dup(fd);
2651 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2653 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2654 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2663 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2666 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2667 #ifdef PERLIO_STD_SPECIAL
2669 return PERLIO_STD_IN(fd, vbuf, count);
2671 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2672 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2676 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2677 if (len >= 0 || errno != EINTR) {
2679 if (errno != EAGAIN) {
2680 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2683 else if (len == 0 && count != 0) {
2684 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2695 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2698 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2699 #ifdef PERLIO_STD_SPECIAL
2700 if (fd == 1 || fd == 2)
2701 return PERLIO_STD_OUT(fd, vbuf, count);
2704 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2705 if (len >= 0 || errno != EINTR) {
2707 if (errno != EAGAIN) {
2708 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2719 PerlIOUnix_tell(pTHX_ PerlIO *f)
2721 PERL_UNUSED_CONTEXT;
2723 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2728 PerlIOUnix_close(pTHX_ PerlIO *f)
2731 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2733 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2734 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2735 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2740 SETERRNO(EBADF,SS_IVCHAN);
2743 while (PerlLIO_close(fd) != 0) {
2744 if (errno != EINTR) {
2751 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2756 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2757 sizeof(PerlIO_funcs),
2764 PerlIOBase_binmode, /* binmode */
2774 PerlIOBase_noop_ok, /* flush */
2775 PerlIOBase_noop_fail, /* fill */
2778 PerlIOBase_clearerr,
2779 PerlIOBase_setlinebuf,
2780 NULL, /* get_base */
2781 NULL, /* get_bufsiz */
2784 NULL, /* set_ptrcnt */
2787 /*--------------------------------------------------------------------------------------*/
2792 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2793 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2794 broken by the last second glibc 2.3 fix
2796 #define STDIO_BUFFER_WRITABLE
2801 struct _PerlIO base;
2802 FILE *stdio; /* The stream */
2806 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2808 PERL_UNUSED_CONTEXT;
2810 if (PerlIOValid(f)) {
2811 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2813 return PerlSIO_fileno(s);
2820 PerlIOStdio_mode(const char *mode, char *tmode)
2822 char * const ret = tmode;
2828 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2836 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2839 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2840 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2841 if (toptab == tab) {
2842 /* Top is already stdio - pop self (duplicate) and use original */
2843 PerlIO_pop(aTHX_ f);
2846 const int fd = PerlIO_fileno(n);
2849 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2850 mode = PerlIOStdio_mode(mode, tmode)))) {
2851 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2852 /* We never call down so do any pending stuff now */
2853 PerlIO_flush(PerlIONext(f));
2860 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2865 PerlIO_importFILE(FILE *stdio, const char *mode)
2871 if (!mode || !*mode) {
2872 /* We need to probe to see how we can open the stream
2873 so start with read/write and then try write and read
2874 we dup() so that we can fclose without loosing the fd.
2876 Note that the errno value set by a failing fdopen
2877 varies between stdio implementations.
2879 const int fd = PerlLIO_dup(fileno(stdio));
2880 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2882 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2885 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2888 /* Don't seem to be able to open */
2894 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2895 s = PerlIOSelf(f, PerlIOStdio);
2897 PerlIOUnix_refcnt_inc(fileno(stdio));
2904 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2905 IV n, const char *mode, int fd, int imode,
2906 int perm, PerlIO *f, int narg, SV **args)
2909 if (PerlIOValid(f)) {
2910 const char * const path = SvPV_nolen_const(*args);
2911 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2913 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2914 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2919 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2924 const char * const path = SvPV_nolen_const(*args);
2925 if (*mode == IoTYPE_NUMERIC) {
2927 fd = PerlLIO_open3(path, imode, perm);
2931 bool appended = FALSE;
2933 /* Cygwin wants its 'b' early. */
2935 mode = PerlIOStdio_mode(mode, tmode);
2937 stdio = PerlSIO_fopen(path, mode);
2940 f = PerlIO_allocate(aTHX);
2943 mode = PerlIOStdio_mode(mode, tmode);
2944 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2946 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2947 PerlIOUnix_refcnt_inc(fileno(stdio));
2949 PerlSIO_fclose(stdio);
2961 if (*mode == IoTYPE_IMPLICIT) {
2968 stdio = PerlSIO_stdin;
2971 stdio = PerlSIO_stdout;
2974 stdio = PerlSIO_stderr;
2979 stdio = PerlSIO_fdopen(fd, mode =
2980 PerlIOStdio_mode(mode, tmode));
2984 f = PerlIO_allocate(aTHX);
2986 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2987 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2988 PerlIOUnix_refcnt_inc(fileno(stdio));
2998 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3000 /* This assumes no layers underneath - which is what
3001 happens, but is not how I remember it. NI-S 2001/10/16
3003 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3004 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3005 const int fd = fileno(stdio);
3007 if (flags & PERLIO_DUP_FD) {
3008 const int dfd = PerlLIO_dup(fileno(stdio));
3010 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3015 /* FIXME: To avoid messy error recovery if dup fails
3016 re-use the existing stdio as though flag was not set
3020 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3022 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3023 PerlIOUnix_refcnt_inc(fileno(stdio));
3029 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3031 PERL_UNUSED_CONTEXT;
3033 /* XXX this could use PerlIO_canset_fileno() and
3034 * PerlIO_set_fileno() support from Configure
3036 # if defined(__UCLIBC__)
3037 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3040 # elif defined(__GLIBC__)
3041 /* There may be a better way for GLIBC:
3042 - libio.h defines a flag to not close() on cleanup
3046 # elif defined(__sun__)
3049 # elif defined(__hpux)
3053 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3054 your platform does not have special entry try this one.
3055 [For OSF only have confirmation for Tru64 (alpha)
3056 but assume other OSFs will be similar.]
3058 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3061 # elif defined(__FreeBSD__)
3062 /* There may be a better way on FreeBSD:
3063 - we could insert a dummy func in the _close function entry
3064 f->_close = (int (*)(void *)) dummy_close;
3068 # elif defined(__OpenBSD__)
3069 /* There may be a better way on OpenBSD:
3070 - we could insert a dummy func in the _close function entry
3071 f->_close = (int (*)(void *)) dummy_close;
3075 # elif defined(__EMX__)
3076 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3079 # elif defined(__CYGWIN__)
3080 /* There may be a better way on CYGWIN:
3081 - we could insert a dummy func in the _close function entry
3082 f->_close = (int (*)(void *)) dummy_close;
3086 # elif defined(WIN32)
3087 # if defined(__BORLANDC__)
3088 f->fd = PerlLIO_dup(fileno(f));
3089 # elif defined(UNDER_CE)
3090 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3099 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3100 (which isn't thread safe) instead
3102 # error "Don't know how to set FILE.fileno on your platform"
3110 PerlIOStdio_close(pTHX_ PerlIO *f)
3112 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3118 const int fd = fileno(stdio);
3123 #ifdef SOCKS5_VERSION_NAME
3124 /* Socks lib overrides close() but stdio isn't linked to
3125 that library (though we are) - so we must call close()
3126 on sockets on stdio's behalf.
3129 Sock_size_t optlen = sizeof(int);
3130 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3133 if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
3136 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3137 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3139 if (stdio == stdout || stdio == stderr)
3140 return PerlIO_flush(f);
3141 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3142 Use Sarathy's trick from maint-5.6 to invalidate the
3143 fileno slot of the FILE *
3145 result = PerlIO_flush(f);
3147 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3149 dupfd = PerlLIO_dup(fd);
3151 result = PerlSIO_fclose(stdio);
3152 /* We treat error from stdio as success if we invalidated
3153 errno may NOT be expected EBADF
3155 if (invalidate && result != 0) {
3159 #ifdef SOCKS5_VERSION_NAME
3160 /* in SOCKS' case, let close() determine return value */
3164 PerlLIO_dup2(dupfd,fd);
3165 PerlLIO_close(dupfd);
3172 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3175 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3179 STDCHAR *buf = (STDCHAR *) vbuf;
3181 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3182 * stdio does not do that for fread()
3184 const int ch = PerlSIO_fgetc(s);
3191 got = PerlSIO_fread(vbuf, 1, count, s);
3192 if (got == 0 && PerlSIO_ferror(s))
3194 if (got >= 0 || errno != EINTR)
3197 SETERRNO(0,0); /* just in case */
3203 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3206 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3208 #ifdef STDIO_BUFFER_WRITABLE
3209 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3210 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3211 STDCHAR *base = PerlIO_get_base(f);
3212 SSize_t cnt = PerlIO_get_cnt(f);
3213 STDCHAR *ptr = PerlIO_get_ptr(f);
3214 SSize_t avail = ptr - base;
3216 if (avail > count) {
3220 Move(buf-avail,ptr,avail,STDCHAR);
3223 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3224 if (PerlSIO_feof(s) && unread >= 0)
3225 PerlSIO_clearerr(s);
3230 if (PerlIO_has_cntptr(f)) {
3231 /* We can get pointer to buffer but not its base
3232 Do ungetc() but check chars are ending up in the
3235 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3236 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3238 const int ch = *--buf & 0xFF;
3239 if (ungetc(ch,s) != ch) {
3240 /* ungetc did not work */
3243 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3244 /* Did not change pointer as expected */
3245 fgetc(s); /* get char back again */
3255 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3261 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3266 got = PerlSIO_fwrite(vbuf, 1, count,
3267 PerlIOSelf(f, PerlIOStdio)->stdio);
3268 if (got >= 0 || errno != EINTR)
3271 SETERRNO(0,0); /* just in case */
3277 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3279 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3280 PERL_UNUSED_CONTEXT;
3282 return PerlSIO_fseek(stdio, offset, whence);
3286 PerlIOStdio_tell(pTHX_ PerlIO *f)
3288 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3289 PERL_UNUSED_CONTEXT;
3291 return PerlSIO_ftell(stdio);
3295 PerlIOStdio_flush(pTHX_ PerlIO *f)
3297 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3298 PERL_UNUSED_CONTEXT;
3300 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3301 return PerlSIO_fflush(stdio);
3307 * FIXME: This discards ungetc() and pre-read stuff which is not
3308 * right if this is just a "sync" from a layer above Suspect right
3309 * design is to do _this_ but not have layer above flush this
3310 * layer read-to-read
3313 * Not writeable - sync by attempting a seek
3315 const int err = errno;
3316 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3324 PerlIOStdio_eof(pTHX_ PerlIO *f)
3326 PERL_UNUSED_CONTEXT;
3328 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3332 PerlIOStdio_error(pTHX_ PerlIO *f)
3334 PERL_UNUSED_CONTEXT;
3336 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3340 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3342 PERL_UNUSED_CONTEXT;
3344 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3348 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3350 PERL_UNUSED_CONTEXT;
3352 #ifdef HAS_SETLINEBUF
3353 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3355 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3361 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3363 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3364 return (STDCHAR*)PerlSIO_get_base(stdio);
3368 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3370 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3371 return PerlSIO_get_bufsiz(stdio);
3375 #ifdef USE_STDIO_PTR
3377 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3379 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3380 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3384 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3386 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3387 return PerlSIO_get_cnt(stdio);
3391 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3393 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3395 #ifdef STDIO_PTR_LVALUE
3396 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3397 #ifdef STDIO_PTR_LVAL_SETS_CNT
3398 if (PerlSIO_get_cnt(stdio) != (cnt)) {
3399 assert(PerlSIO_get_cnt(stdio) == (cnt));
3402 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3404 * Setting ptr _does_ change cnt - we are done
3408 #else /* STDIO_PTR_LVALUE */
3410 #endif /* STDIO_PTR_LVALUE */
3413 * Now (or only) set cnt
3415 #ifdef STDIO_CNT_LVALUE
3416 PerlSIO_set_cnt(stdio, cnt);
3417 #else /* STDIO_CNT_LVALUE */
3418 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3419 PerlSIO_set_ptr(stdio,
3420 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3422 #else /* STDIO_PTR_LVAL_SETS_CNT */
3424 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3425 #endif /* STDIO_CNT_LVALUE */
3432 PerlIOStdio_fill(pTHX_ PerlIO *f)
3434 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3436 PERL_UNUSED_CONTEXT;
3439 * fflush()ing read-only streams can cause trouble on some stdio-s
3441 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3442 if (PerlSIO_fflush(stdio) != 0)
3446 c = PerlSIO_fgetc(stdio);
3449 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3455 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3457 #ifdef STDIO_BUFFER_WRITABLE
3458 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3459 /* Fake ungetc() to the real buffer in case system's ungetc
3462 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3463 SSize_t cnt = PerlSIO_get_cnt(stdio);
3464 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3465 if (ptr == base+1) {
3466 *--ptr = (STDCHAR) c;
3467 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3468 if (PerlSIO_feof(stdio))
3469 PerlSIO_clearerr(stdio);
3475 if (PerlIO_has_cntptr(f)) {
3477 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3484 /* An ungetc()d char is handled separately from the regular
3485 * buffer, so we stuff it in the buffer ourselves.
3486 * Should never get called as should hit code above
3488 *(--((*stdio)->_ptr)) = (unsigned char) c;
3491 /* If buffer snoop scheme above fails fall back to
3494 if (PerlSIO_ungetc(c, stdio) != c)
3502 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3503 sizeof(PerlIO_funcs),
3505 sizeof(PerlIOStdio),
3506 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3510 PerlIOBase_binmode, /* binmode */
3524 PerlIOStdio_clearerr,
3525 PerlIOStdio_setlinebuf,
3527 PerlIOStdio_get_base,
3528 PerlIOStdio_get_bufsiz,
3533 #ifdef USE_STDIO_PTR
3534 PerlIOStdio_get_ptr,
3535 PerlIOStdio_get_cnt,
3536 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3537 PerlIOStdio_set_ptrcnt,
3540 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3545 #endif /* USE_STDIO_PTR */
3548 /* Note that calls to PerlIO_exportFILE() are reversed using
3549 * PerlIO_releaseFILE(), not importFILE. */
3551 PerlIO_exportFILE(PerlIO * f, const char *mode)
3555 if (PerlIOValid(f)) {
3558 if (!mode || !*mode) {
3559 mode = PerlIO_modestr(f, buf);
3561 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3565 /* De-link any lower layers so new :stdio sticks */
3567 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3568 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3570 PerlIOUnix_refcnt_inc(fileno(stdio));
3571 /* Link previous lower layers under new one */
3575 /* restore layers list */
3585 PerlIO_findFILE(PerlIO *f)
3590 if (l->tab == &PerlIO_stdio) {
3591 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3594 l = *PerlIONext(&l);
3596 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3597 /* However, we're not really exporting a FILE * to someone else (who
3598 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3599 So we need to undo its refernce count increase on the underlying file
3600 descriptor. We have to do this, because if the loop above returns you
3601 the FILE *, then *it* didn't increase any reference count. So there's
3602 only one way to be consistent. */
3603 stdio = PerlIO_exportFILE(f, NULL);
3605 const int fd = fileno(stdio);
3607 PerlIOUnix_refcnt_dec(fd);
3612 /* Use this to reverse PerlIO_exportFILE calls. */
3614 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3619 if (l->tab == &PerlIO_stdio) {
3620 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3621 if (s->stdio == f) {
3623 const int fd = fileno(f);
3625 PerlIOUnix_refcnt_dec(fd);
3626 PerlIO_pop(aTHX_ p);
3635 /*--------------------------------------------------------------------------------------*/
3637 * perlio buffer layer
3641 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3643 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3644 const int fd = PerlIO_fileno(f);
3645 if (fd >= 0 && PerlLIO_isatty(fd)) {
3646 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3648 if (*PerlIONext(f)) {
3649 const Off_t posn = PerlIO_tell(PerlIONext(f));
3650 if (posn != (Off_t) - 1) {
3654 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3658 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3659 IV n, const char *mode, int fd, int imode, int perm,
3660 PerlIO *f, int narg, SV **args)
3662 if (PerlIOValid(f)) {
3663 PerlIO *next = PerlIONext(f);
3665 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3666 if (tab && tab->Open)
3668 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3670 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3675 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3677 if (*mode == IoTYPE_IMPLICIT) {
3683 if (tab && tab->Open)
3684 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3687 SETERRNO(EINVAL, LIB_INVARG);
3689 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3691 * if push fails during open, open fails. close will pop us.
3696 fd = PerlIO_fileno(f);
3697 if (init && fd == 2) {
3699 * Initial stderr is unbuffered
3701 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3703 #ifdef PERLIO_USING_CRLF
3704 # ifdef PERLIO_IS_BINMODE_FD
3705 if (PERLIO_IS_BINMODE_FD(fd))
3706 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3710 * do something about failing setmode()? --jhi
3712 PerlLIO_setmode(fd, O_BINARY);
3721 * This "flush" is akin to sfio's sync in that it handles files in either
3722 * read or write state. For write state, we put the postponed data through
3723 * the next layers. For read state, we seek() the next layers to the
3724 * offset given by current position in the buffer, and discard the buffer
3725 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3726 * in any case?). Then the pass the stick further in chain.
3729 PerlIOBuf_flush(pTHX_ PerlIO *f)
3731 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3733 PerlIO *n = PerlIONext(f);
3734 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3736 * write() the buffer
3738 const STDCHAR *buf = b->buf;
3739 const STDCHAR *p = buf;
3740 while (p < b->ptr) {
3741 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3745 else if (count < 0 || PerlIO_error(n)) {
3746 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3751 b->posn += (p - buf);
3753 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3754 STDCHAR *buf = PerlIO_get_base(f);
3756 * Note position change
3758 b->posn += (b->ptr - buf);
3759 if (b->ptr < b->end) {
3760 /* We did not consume all of it - try and seek downstream to
3761 our logical position
3763 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3764 /* Reload n as some layers may pop themselves on seek */
3765 b->posn = PerlIO_tell(n = PerlIONext(f));
3768 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3769 data is lost for good - so return saying "ok" having undone
3772 b->posn -= (b->ptr - buf);
3777 b->ptr = b->end = b->buf;
3778 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3779 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3780 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3785 /* This discards the content of the buffer after b->ptr, and rereads
3786 * the buffer from the position off in the layer downstream; here off
3787 * is at offset corresponding to b->ptr - b->buf.
3790 PerlIOBuf_fill(pTHX_ PerlIO *f)
3792 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3793 PerlIO *n = PerlIONext(f);
3796 * Down-stream flush is defined not to loose read data so is harmless.
3797 * we would not normally be fill'ing if there was data left in anycase.
3799 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3801 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3802 PerlIOBase_flush_linebuf(aTHX);
3805 PerlIO_get_base(f); /* allocate via vtable */
3807 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3809 b->ptr = b->end = b->buf;
3811 if (!PerlIOValid(n)) {
3812 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3816 if (PerlIO_fast_gets(n)) {
3818 * Layer below is also buffered. We do _NOT_ want to call its
3819 * ->Read() because that will loop till it gets what we asked for
3820 * which may hang on a pipe etc. Instead take anything it has to
3821 * hand, or ask it to fill _once_.
3823 avail = PerlIO_get_cnt(n);
3825 avail = PerlIO_fill(n);
3827 avail = PerlIO_get_cnt(n);
3829 if (!PerlIO_error(n) && PerlIO_eof(n))
3834 STDCHAR *ptr = PerlIO_get_ptr(n);
3835 const SSize_t cnt = avail;
3836 if (avail > (SSize_t)b->bufsiz)
3838 Copy(ptr, b->buf, avail, STDCHAR);
3839 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3843 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3847 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3849 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3852 b->end = b->buf + avail;
3853 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3858 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3860 if (PerlIOValid(f)) {
3861 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3864 return PerlIOBase_read(aTHX_ f, vbuf, count);
3870 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3872 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3873 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3876 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3881 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3883 * Buffer is already a read buffer, we can overwrite any chars
3884 * which have been read back to buffer start
3886 avail = (b->ptr - b->buf);
3890 * Buffer is idle, set it up so whole buffer is available for
3894 b->end = b->buf + avail;
3896 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3898 * Buffer extends _back_ from where we are now
3900 b->posn -= b->bufsiz;
3902 if (avail > (SSize_t) count) {
3904 * If we have space for more than count, just move count
3912 * In simple stdio-like ungetc() case chars will be already
3915 if (buf != b->ptr) {
3916 Copy(buf, b->ptr, avail, STDCHAR);
3920 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3924 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3930 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3932 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3933 const STDCHAR *buf = (const STDCHAR *) vbuf;
3934 const STDCHAR *flushptr = buf;
3938 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3940 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3941 if (PerlIO_flush(f) != 0) {
3945 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3946 flushptr = buf + count;
3947 while (flushptr > buf && *(flushptr - 1) != '\n')
3951 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3952 if ((SSize_t) count < avail)
3954 if (flushptr > buf && flushptr <= buf + avail)
3955 avail = flushptr - buf;
3956 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3958 Copy(buf, b->ptr, avail, STDCHAR);
3963 if (buf == flushptr)
3966 if (b->ptr >= (b->buf + b->bufsiz))
3969 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3975 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3978 if ((code = PerlIO_flush(f)) == 0) {
3979 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3980 code = PerlIO_seek(PerlIONext(f), offset, whence);
3982 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3983 b->posn = PerlIO_tell(PerlIONext(f));
3990 PerlIOBuf_tell(pTHX_ PerlIO *f)
3992 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3994 * b->posn is file position where b->buf was read, or will be written
3996 Off_t posn = b->posn;
3997 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
3998 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4000 /* As O_APPEND files are normally shared in some sense it is better
4005 /* when file is NOT shared then this is sufficient */
4006 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4008 posn = b->posn = PerlIO_tell(PerlIONext(f));
4012 * If buffer is valid adjust position by amount in buffer
4014 posn += (b->ptr - b->buf);
4020 PerlIOBuf_popped(pTHX_ PerlIO *f)
4022 const IV code = PerlIOBase_popped(aTHX_ f);
4023 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4024 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4027 b->ptr = b->end = b->buf = NULL;
4028 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4033 PerlIOBuf_close(pTHX_ PerlIO *f)
4035 const IV code = PerlIOBase_close(aTHX_ f);
4036 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4037 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4040 b->ptr = b->end = b->buf = NULL;
4041 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4046 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4048 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4055 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4057 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4060 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4061 return (b->end - b->ptr);
4066 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4068 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4069 PERL_UNUSED_CONTEXT;
4074 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4076 b->buf = (STDCHAR *) & b->oneword;
4077 b->bufsiz = sizeof(b->oneword);
4079 b->end = b->ptr = b->buf;
4085 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4087 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4090 return (b->end - b->buf);
4094 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4096 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4100 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
4101 assert(PerlIO_get_cnt(f) == cnt);
4102 assert(b->ptr >= b->buf);
4104 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4108 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4110 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4115 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4116 sizeof(PerlIO_funcs),
4119 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4123 PerlIOBase_binmode, /* binmode */
4137 PerlIOBase_clearerr,
4138 PerlIOBase_setlinebuf,
4143 PerlIOBuf_set_ptrcnt,
4146 /*--------------------------------------------------------------------------------------*/
4148 * Temp layer to hold unread chars when cannot do it any other way
4152 PerlIOPending_fill(pTHX_ PerlIO *f)
4155 * Should never happen
4162 PerlIOPending_close(pTHX_ PerlIO *f)
4165 * A tad tricky - flush pops us, then we close new top
4168 return PerlIO_close(f);
4172 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4175 * A tad tricky - flush pops us, then we seek new top
4178 return PerlIO_seek(f, offset, whence);
4183 PerlIOPending_flush(pTHX_ PerlIO *f)
4185 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4186 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4190 PerlIO_pop(aTHX_ f);
4195 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4201 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4206 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4208 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4209 PerlIOl * const l = PerlIOBase(f);
4211 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4212 * etc. get muddled when it changes mid-string when we auto-pop.
4214 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4215 (PerlIOBase(PerlIONext(f))->
4216 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4221 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4223 SSize_t avail = PerlIO_get_cnt(f);
4225 if ((SSize_t)count < avail)
4228 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4229 if (got >= 0 && got < (SSize_t)count) {
4230 const SSize_t more =
4231 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4232 if (more >= 0 || got == 0)
4238 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4239 sizeof(PerlIO_funcs),
4242 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4243 PerlIOPending_pushed,
4246 PerlIOBase_binmode, /* binmode */
4255 PerlIOPending_close,
4256 PerlIOPending_flush,
4260 PerlIOBase_clearerr,
4261 PerlIOBase_setlinebuf,
4266 PerlIOPending_set_ptrcnt,
4271 /*--------------------------------------------------------------------------------------*/
4273 * crlf - translation On read translate CR,LF to "\n" we do this by
4274 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4275 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4277 * c->nl points on the first byte of CR LF pair when it is temporarily
4278 * replaced by LF, or to the last CR of the buffer. In the former case
4279 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4280 * that it ends at c->nl; these two cases can be distinguished by
4281 * *c->nl. c->nl is set during _getcnt() call, and unset during
4282 * _unread() and _flush() calls.
4283 * It only matters for read operations.
4287 PerlIOBuf base; /* PerlIOBuf stuff */
4288 STDCHAR *nl; /* Position of crlf we "lied" about in the
4292 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4293 * Otherwise the :crlf layer would always revert back to
4297 S_inherit_utf8_flag(PerlIO *f)
4299 PerlIO *g = PerlIONext(f);
4300 if (PerlIOValid(g)) {
4301 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4302 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4308 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4311 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4312 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4314 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4315 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4316 PerlIOBase(f)->flags);
4319 /* Enable the first CRLF capable layer you can find, but if none
4320 * found, the one we just pushed is fine. This results in at
4321 * any given moment at most one CRLF-capable layer being enabled
4322 * in the whole layer stack. */
4323 PerlIO *g = PerlIONext(f);
4324 while (PerlIOValid(g)) {
4325 PerlIOl *b = PerlIOBase(g);
4326 if (b && b->tab == &PerlIO_crlf) {
4327 if (!(b->flags & PERLIO_F_CRLF))
4328 b->flags |= PERLIO_F_CRLF;
4329 S_inherit_utf8_flag(g);
4330 PerlIO_pop(aTHX_ f);
4336 S_inherit_utf8_flag(f);
4342 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4344 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4345 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4349 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4350 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4352 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4353 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4355 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4360 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4361 b->end = b->ptr = b->buf + b->bufsiz;
4362 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4363 b->posn -= b->bufsiz;
4365 while (count > 0 && b->ptr > b->buf) {
4366 const int ch = *--buf;
4368 if (b->ptr - 2 >= b->buf) {
4375 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4376 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4392 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4394 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4396 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4399 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4400 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4401 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4402 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4404 while (nl < b->end && *nl != 0xd)
4406 if (nl < b->end && *nl == 0xd) {
4408 if (nl + 1 < b->end) {
4415 * Not CR,LF but just CR
4423 * Blast - found CR as last char in buffer
4428 * They may not care, defer work as long as
4432 return (nl - b->ptr);
4436 b->ptr++; /* say we have read it as far as
4437 * flush() is concerned */
4438 b->buf++; /* Leave space in front of buffer */
4439 /* Note as we have moved buf up flush's
4441 will naturally make posn point at CR
4443 b->bufsiz--; /* Buffer is thus smaller */
4444 code = PerlIO_fill(f); /* Fetch some more */
4445 b->bufsiz++; /* Restore size for next time */
4446 b->buf--; /* Point at space */
4447 b->ptr = nl = b->buf; /* Which is what we hand
4449 *nl = 0xd; /* Fill in the CR */
4451 goto test; /* fill() call worked */
4453 * CR at EOF - just fall through
4455 /* Should we clear EOF though ??? */
4460 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4466 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4468 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4469 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4475 if (ptr == b->end && *c->nl == 0xd) {
4476 /* Defered CR at end of buffer case - we lied about count */
4489 * Test code - delete when it works ...
4491 IV flags = PerlIOBase(f)->flags;
4492 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4493 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4494 /* Defered CR at end of buffer case - we lied about count */
4500 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4501 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4502 flags, c->nl, b->end, cnt);
4509 * They have taken what we lied about
4517 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4521 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4523 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4524 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4526 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4527 const STDCHAR *buf = (const STDCHAR *) vbuf;
4528 const STDCHAR * const ebuf = buf + count;
4531 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4533 while (buf < ebuf) {
4534 const STDCHAR * const eptr = b->buf + b->bufsiz;
4535 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4536 while (buf < ebuf && b->ptr < eptr) {
4538 if ((b->ptr + 2) > eptr) {
4546 *(b->ptr)++ = 0xd; /* CR */
4547 *(b->ptr)++ = 0xa; /* LF */
4549 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4556 *(b->ptr)++ = *buf++;
4558 if (b->ptr >= eptr) {
4564 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4566 return (buf - (STDCHAR *) vbuf);
4571 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4573 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4578 return PerlIOBuf_flush(aTHX_ f);
4582 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4584 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4585 /* In text mode - flush any pending stuff and flip it */
4586 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4587 #ifndef PERLIO_USING_CRLF
4588 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4589 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4590 PerlIO_pop(aTHX_ f);
4597 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4598 sizeof(PerlIO_funcs),
4601 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4603 PerlIOBuf_popped, /* popped */
4605 PerlIOCrlf_binmode, /* binmode */
4609 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4610 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4611 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4619 PerlIOBase_clearerr,
4620 PerlIOBase_setlinebuf,
4625 PerlIOCrlf_set_ptrcnt,
4629 /*--------------------------------------------------------------------------------------*/
4631 * mmap as "buffer" layer
4635 PerlIOBuf base; /* PerlIOBuf stuff */
4636 Mmap_t mptr; /* Mapped address */
4637 Size_t len; /* mapped length */
4638 STDCHAR *bbuf; /* malloced buffer if map fails */
4642 PerlIOMmap_map(pTHX_ PerlIO *f)
4645 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4646 const IV flags = PerlIOBase(f)->flags;
4650 if (flags & PERLIO_F_CANREAD) {
4651 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4652 const int fd = PerlIO_fileno(f);
4654 code = Fstat(fd, &st);
4655 if (code == 0 && S_ISREG(st.st_mode)) {
4656 SSize_t len = st.st_size - b->posn;
4659 if (PL_mmap_page_size <= 0)
4660 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4664 * This is a hack - should never happen - open should
4667 b->posn = PerlIO_tell(PerlIONext(f));
4669 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4670 len = st.st_size - posn;
4671 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4672 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4673 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4674 madvise(m->mptr, len, MADV_SEQUENTIAL);
4676 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4677 madvise(m->mptr, len, MADV_WILLNEED);
4679 PerlIOBase(f)->flags =
4680 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4681 b->end = ((STDCHAR *) m->mptr) + len;
4682 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4691 PerlIOBase(f)->flags =
4692 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4694 b->ptr = b->end = b->ptr;
4703 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4705 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4708 PerlIOBuf * const b = &m->base;
4710 /* The munmap address argument is tricky: depending on the
4711 * standard it is either "void *" or "caddr_t" (which is
4712 * usually "char *" (signed or unsigned). If we cast it
4713 * to "void *", those that have it caddr_t and an uptight
4714 * C++ compiler, will freak out. But casting it as char*
4715 * should work. Maybe. (Using Mmap_t figured out by
4716 * Configure doesn't always work, apparently.) */
4717 code = munmap((char*)m->mptr, m->len);
4721 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4724 b->ptr = b->end = b->buf;
4725 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4731 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4733 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4734 PerlIOBuf * const b = &m->base;
4735 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4737 * Already have a readbuffer in progress
4743 * We have a write buffer or flushed PerlIOBuf read buffer
4745 m->bbuf = b->buf; /* save it in case we need it again */
4746 b->buf = NULL; /* Clear to trigger below */
4749 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4752 * Map did not work - recover PerlIOBuf buffer if we have one
4757 b->ptr = b->end = b->buf;
4760 return PerlIOBuf_get_base(aTHX_ f);
4764 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4766 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4767 PerlIOBuf * const b = &m->base;
4768 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4770 if (b->ptr && (b->ptr - count) >= b->buf
4771 && memEQ(b->ptr - count, vbuf, count)) {
4773 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4778 * Loose the unwritable mapped buffer
4782 * If flush took the "buffer" see if we have one from before
4784 if (!b->buf && m->bbuf)
4787 PerlIOBuf_get_base(aTHX_ f);
4791 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4795 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4797 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4798 PerlIOBuf * const b = &m->base;
4800 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4802 * No, or wrong sort of, buffer
4805 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4809 * If unmap took the "buffer" see if we have one from before
4811 if (!b->buf && m->bbuf)
4814 PerlIOBuf_get_base(aTHX_ f);
4818 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4822 PerlIOMmap_flush(pTHX_ PerlIO *f)
4824 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4825 PerlIOBuf * const b = &m->base;
4826 IV code = PerlIOBuf_flush(aTHX_ f);
4828 * Now we are "synced" at PerlIOBuf level
4835 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4840 * We seem to have a PerlIOBuf buffer which was not mapped
4841 * remember it in case we need one later
4850 PerlIOMmap_fill(pTHX_ PerlIO *f)
4852 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4853 IV code = PerlIO_flush(f);
4854 if (code == 0 && !b->buf) {
4855 code = PerlIOMmap_map(aTHX_ f);
4857 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4858 code = PerlIOBuf_fill(aTHX_ f);
4864 PerlIOMmap_close(pTHX_ PerlIO *f)
4866 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4867 PerlIOBuf * const b = &m->base;
4868 IV code = PerlIO_flush(f);
4872 b->ptr = b->end = b->buf;
4874 if (PerlIOBuf_close(aTHX_ f) != 0)
4880 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4882 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4886 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4887 sizeof(PerlIO_funcs),
4890 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4894 PerlIOBase_binmode, /* binmode */
4908 PerlIOBase_clearerr,
4909 PerlIOBase_setlinebuf,
4910 PerlIOMmap_get_base,
4914 PerlIOBuf_set_ptrcnt,
4917 #endif /* HAS_MMAP */
4920 Perl_PerlIO_stdin(pTHX)
4924 PerlIO_stdstreams(aTHX);
4926 return &PL_perlio[1];
4930 Perl_PerlIO_stdout(pTHX)
4934 PerlIO_stdstreams(aTHX);
4936 return &PL_perlio[2];
4940 Perl_PerlIO_stderr(pTHX)
4944 PerlIO_stdstreams(aTHX);
4946 return &PL_perlio[3];
4949 /*--------------------------------------------------------------------------------------*/
4952 PerlIO_getname(PerlIO *f, char *buf)
4957 bool exported = FALSE;
4958 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4960 stdio = PerlIO_exportFILE(f,0);
4964 name = fgetname(stdio, buf);
4965 if (exported) PerlIO_releaseFILE(f,stdio);
4970 PERL_UNUSED_ARG(buf);
4971 Perl_croak(aTHX_ "Don't know how to get file name");
4977 /*--------------------------------------------------------------------------------------*/
4979 * Functions which can be called on any kind of PerlIO implemented in
4983 #undef PerlIO_fdopen
4985 PerlIO_fdopen(int fd, const char *mode)
4988 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4993 PerlIO_open(const char *path, const char *mode)
4996 SV *name = sv_2mortal(newSVpv(path, 0));
4997 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
5000 #undef Perlio_reopen
5002 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
5005 SV *name = sv_2mortal(newSVpv(path,0));
5006 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5011 PerlIO_getc(PerlIO *f)
5015 if ( 1 == PerlIO_read(f, buf, 1) ) {
5016 return (unsigned char) buf[0];
5021 #undef PerlIO_ungetc
5023 PerlIO_ungetc(PerlIO *f, int ch)
5028 if (PerlIO_unread(f, &buf, 1) == 1)
5036 PerlIO_putc(PerlIO *f, int ch)
5040 return PerlIO_write(f, &buf, 1);
5045 PerlIO_puts(PerlIO *f, const char *s)
5048 return PerlIO_write(f, s, strlen(s));
5051 #undef PerlIO_rewind
5053 PerlIO_rewind(PerlIO *f)
5056 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5060 #undef PerlIO_vprintf
5062 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5071 Perl_va_copy(ap, apc);
5072 sv = vnewSVpvf(fmt, &apc);
5074 sv = vnewSVpvf(fmt, &ap);
5076 s = SvPV_const(sv, len);
5077 wrote = PerlIO_write(f, s, len);
5082 #undef PerlIO_printf
5084 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5089 result = PerlIO_vprintf(f, fmt, ap);
5094 #undef PerlIO_stdoutf
5096 PerlIO_stdoutf(const char *fmt, ...)
5102 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5107 #undef PerlIO_tmpfile
5109 PerlIO_tmpfile(void)
5114 const int fd = win32_tmpfd();
5116 f = PerlIO_fdopen(fd, "w+b");
5118 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5119 SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
5121 * I have no idea how portable mkstemp() is ... NI-S
5123 const int fd = mkstemp(SvPVX(sv));
5125 f = PerlIO_fdopen(fd, "w+");
5127 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5128 PerlLIO_unlink(SvPVX_const(sv));
5131 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5132 FILE * const stdio = PerlSIO_tmpfile();
5135 f = PerlIO_fdopen(fileno(stdio), "w+");
5137 # endif /* else HAS_MKSTEMP */
5138 #endif /* else WIN32 */
5145 #endif /* USE_SFIO */
5146 #endif /* PERLIO_IS_STDIO */
5148 /*======================================================================================*/
5150 * Now some functions in terms of above which may be needed even if we are
5151 * not in true PerlIO mode
5154 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5157 const char *direction = NULL;
5160 * Need to supply default layer info from open.pm
5166 if (mode && mode[0] != 'r') {
5167 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5168 direction = "open>";
5170 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5171 direction = "open<";
5176 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5177 0, direction, 5, 0, 0);
5180 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5185 #undef PerlIO_setpos
5187 PerlIO_setpos(PerlIO *f, SV *pos)
5192 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5193 if (f && len == sizeof(Off_t))
5194 return PerlIO_seek(f, *posn, SEEK_SET);
5196 SETERRNO(EINVAL, SS_IVCHAN);
5200 #undef PerlIO_setpos
5202 PerlIO_setpos(PerlIO *f, SV *pos)
5207 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5208 if (f && len == sizeof(Fpos_t)) {
5209 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5210 return fsetpos64(f, fpos);
5212 return fsetpos(f, fpos);
5216 SETERRNO(EINVAL, SS_IVCHAN);
5222 #undef PerlIO_getpos
5224 PerlIO_getpos(PerlIO *f, SV *pos)
5227 Off_t posn = PerlIO_tell(f);
5228 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5229 return (posn == (Off_t) - 1) ? -1 : 0;
5232 #undef PerlIO_getpos
5234 PerlIO_getpos(PerlIO *f, SV *pos)
5239 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5240 code = fgetpos64(f, &fpos);
5242 code = fgetpos(f, &fpos);
5244 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5249 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5252 vprintf(char *pat, char *args)
5254 _doprnt(pat, args, stdout);
5255 return 0; /* wrong, but perl doesn't use the return
5260 vfprintf(FILE *fd, char *pat, char *args)
5262 _doprnt(pat, args, fd);
5263 return 0; /* wrong, but perl doesn't use the return
5269 #ifndef PerlIO_vsprintf
5271 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5274 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5275 PERL_UNUSED_CONTEXT;
5277 #ifndef PERL_MY_VSNPRINTF_GUARDED
5278 if (val < 0 || (n > 0 ? val >= n : 0)) {
5279 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5286 #ifndef PerlIO_sprintf
5288 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5293 result = PerlIO_vsprintf(s, n, fmt, ap);
5301 * c-indentation-style: bsd
5303 * indent-tabs-mode: t
5306 * ex: set ts=8 sts=4 sw=4 noet: