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(). */
2421 /* By now all filehandles should have been closed, so any
2422 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2424 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2425 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2426 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2428 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2429 if (PL_perlio_fd_refcnt[i]) {
2431 my_snprintf(buf, sizeof(buf),
2432 "PerlIO_teardown: fd %d refcnt=%d\n",
2433 i, PL_perlio_fd_refcnt[i]);
2434 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2439 /* Not bothering with PL_perlio_mutex since by now
2440 * all the interpreters are gone. */
2441 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2442 && PL_perlio_fd_refcnt) {
2443 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2444 PL_perlio_fd_refcnt = NULL;
2445 PL_perlio_fd_refcnt_size = 0;
2449 /*--------------------------------------------------------------------------------------*/
2451 * Bottom-most level for UNIX-like case
2455 struct _PerlIO base; /* The generic part */
2456 int fd; /* UNIX like file descriptor */
2457 int oflags; /* open/fcntl flags */
2461 PerlIOUnix_oflags(const char *mode)
2464 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2469 if (*++mode == '+') {
2476 oflags = O_CREAT | O_TRUNC;
2477 if (*++mode == '+') {
2486 oflags = O_CREAT | O_APPEND;
2487 if (*++mode == '+') {
2500 else if (*mode == 't') {
2502 oflags &= ~O_BINARY;
2506 * Always open in binary mode
2509 if (*mode || oflags == -1) {
2510 SETERRNO(EINVAL, LIB_INVARG);
2517 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2519 PERL_UNUSED_CONTEXT;
2520 return PerlIOSelf(f, PerlIOUnix)->fd;
2524 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2526 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2529 if (PerlLIO_fstat(fd, &st) == 0) {
2530 if (!S_ISREG(st.st_mode)) {
2531 PerlIO_debug("%d is not regular file\n",fd);
2532 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2535 PerlIO_debug("%d _is_ a regular file\n",fd);
2541 PerlIOUnix_refcnt_inc(fd);
2542 PERL_UNUSED_CONTEXT;
2546 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2548 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2549 if (*PerlIONext(f)) {
2550 /* We never call down so do any pending stuff now */
2551 PerlIO_flush(PerlIONext(f));
2553 * XXX could (or should) we retrieve the oflags from the open file
2554 * handle rather than believing the "mode" we are passed in? XXX
2555 * Should the value on NULL mode be 0 or -1?
2557 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2558 mode ? PerlIOUnix_oflags(mode) : -1);
2560 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2566 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2568 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2570 PERL_UNUSED_CONTEXT;
2571 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2573 SETERRNO(ESPIPE, LIB_INVARG);
2575 SETERRNO(EINVAL, LIB_INVARG);
2579 new_loc = PerlLIO_lseek(fd, offset, whence);
2580 if (new_loc == (Off_t) - 1)
2582 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2587 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2588 IV n, const char *mode, int fd, int imode,
2589 int perm, PerlIO *f, int narg, SV **args)
2591 if (PerlIOValid(f)) {
2592 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2593 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2596 if (*mode == IoTYPE_NUMERIC)
2599 imode = PerlIOUnix_oflags(mode);
2603 const char *path = SvPV_nolen_const(*args);
2604 fd = PerlLIO_open3(path, imode, perm);
2608 if (*mode == IoTYPE_IMPLICIT)
2611 f = PerlIO_allocate(aTHX);
2613 if (!PerlIOValid(f)) {
2614 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2618 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2619 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2620 if (*mode == IoTYPE_APPEND)
2621 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2628 * FIXME: pop layers ???
2636 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2638 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2640 if (flags & PERLIO_DUP_FD) {
2641 fd = PerlLIO_dup(fd);
2644 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2646 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2647 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2656 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2659 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2660 #ifdef PERLIO_STD_SPECIAL
2662 return PERLIO_STD_IN(fd, vbuf, count);
2664 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2665 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2669 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2670 if (len >= 0 || errno != EINTR) {
2672 if (errno != EAGAIN) {
2673 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2676 else if (len == 0 && count != 0) {
2677 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2688 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2691 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2692 #ifdef PERLIO_STD_SPECIAL
2693 if (fd == 1 || fd == 2)
2694 return PERLIO_STD_OUT(fd, vbuf, count);
2697 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2698 if (len >= 0 || errno != EINTR) {
2700 if (errno != EAGAIN) {
2701 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2712 PerlIOUnix_tell(pTHX_ PerlIO *f)
2714 PERL_UNUSED_CONTEXT;
2716 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2721 PerlIOUnix_close(pTHX_ PerlIO *f)
2724 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2726 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2727 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2728 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2733 SETERRNO(EBADF,SS_IVCHAN);
2736 while (PerlLIO_close(fd) != 0) {
2737 if (errno != EINTR) {
2744 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2749 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2750 sizeof(PerlIO_funcs),
2757 PerlIOBase_binmode, /* binmode */
2767 PerlIOBase_noop_ok, /* flush */
2768 PerlIOBase_noop_fail, /* fill */
2771 PerlIOBase_clearerr,
2772 PerlIOBase_setlinebuf,
2773 NULL, /* get_base */
2774 NULL, /* get_bufsiz */
2777 NULL, /* set_ptrcnt */
2780 /*--------------------------------------------------------------------------------------*/
2785 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2786 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2787 broken by the last second glibc 2.3 fix
2789 #define STDIO_BUFFER_WRITABLE
2794 struct _PerlIO base;
2795 FILE *stdio; /* The stream */
2799 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2801 PERL_UNUSED_CONTEXT;
2803 if (PerlIOValid(f)) {
2804 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2806 return PerlSIO_fileno(s);
2813 PerlIOStdio_mode(const char *mode, char *tmode)
2815 char * const ret = tmode;
2821 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2829 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2832 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2833 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2834 if (toptab == tab) {
2835 /* Top is already stdio - pop self (duplicate) and use original */
2836 PerlIO_pop(aTHX_ f);
2839 const int fd = PerlIO_fileno(n);
2842 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2843 mode = PerlIOStdio_mode(mode, tmode)))) {
2844 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2845 /* We never call down so do any pending stuff now */
2846 PerlIO_flush(PerlIONext(f));
2853 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2858 PerlIO_importFILE(FILE *stdio, const char *mode)
2864 if (!mode || !*mode) {
2865 /* We need to probe to see how we can open the stream
2866 so start with read/write and then try write and read
2867 we dup() so that we can fclose without loosing the fd.
2869 Note that the errno value set by a failing fdopen
2870 varies between stdio implementations.
2872 const int fd = PerlLIO_dup(fileno(stdio));
2873 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2875 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2878 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2881 /* Don't seem to be able to open */
2887 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2888 s = PerlIOSelf(f, PerlIOStdio);
2890 PerlIOUnix_refcnt_inc(fileno(stdio));
2897 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2898 IV n, const char *mode, int fd, int imode,
2899 int perm, PerlIO *f, int narg, SV **args)
2902 if (PerlIOValid(f)) {
2903 const char * const path = SvPV_nolen_const(*args);
2904 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2906 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2907 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2912 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2917 const char * const path = SvPV_nolen_const(*args);
2918 if (*mode == IoTYPE_NUMERIC) {
2920 fd = PerlLIO_open3(path, imode, perm);
2924 bool appended = FALSE;
2926 /* Cygwin wants its 'b' early. */
2928 mode = PerlIOStdio_mode(mode, tmode);
2930 stdio = PerlSIO_fopen(path, mode);
2933 f = PerlIO_allocate(aTHX);
2936 mode = PerlIOStdio_mode(mode, tmode);
2937 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2939 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2940 PerlIOUnix_refcnt_inc(fileno(stdio));
2942 PerlSIO_fclose(stdio);
2954 if (*mode == IoTYPE_IMPLICIT) {
2961 stdio = PerlSIO_stdin;
2964 stdio = PerlSIO_stdout;
2967 stdio = PerlSIO_stderr;
2972 stdio = PerlSIO_fdopen(fd, mode =
2973 PerlIOStdio_mode(mode, tmode));
2977 f = PerlIO_allocate(aTHX);
2979 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2980 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2981 PerlIOUnix_refcnt_inc(fileno(stdio));
2991 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2993 /* This assumes no layers underneath - which is what
2994 happens, but is not how I remember it. NI-S 2001/10/16
2996 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2997 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2998 const int fd = fileno(stdio);
3000 if (flags & PERLIO_DUP_FD) {
3001 const int dfd = PerlLIO_dup(fileno(stdio));
3003 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3008 /* FIXME: To avoid messy error recovery if dup fails
3009 re-use the existing stdio as though flag was not set
3013 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3015 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3016 PerlIOUnix_refcnt_inc(fileno(stdio));
3022 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3024 PERL_UNUSED_CONTEXT;
3026 /* XXX this could use PerlIO_canset_fileno() and
3027 * PerlIO_set_fileno() support from Configure
3029 # if defined(__UCLIBC__)
3030 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3033 # elif defined(__GLIBC__)
3034 /* There may be a better way for GLIBC:
3035 - libio.h defines a flag to not close() on cleanup
3039 # elif defined(__sun__)
3042 # elif defined(__hpux)
3046 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3047 your platform does not have special entry try this one.
3048 [For OSF only have confirmation for Tru64 (alpha)
3049 but assume other OSFs will be similar.]
3051 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3054 # elif defined(__FreeBSD__)
3055 /* There may be a better way on FreeBSD:
3056 - we could insert a dummy func in the _close function entry
3057 f->_close = (int (*)(void *)) dummy_close;
3061 # elif defined(__OpenBSD__)
3062 /* There may be a better way on OpenBSD:
3063 - we could insert a dummy func in the _close function entry
3064 f->_close = (int (*)(void *)) dummy_close;
3068 # elif defined(__EMX__)
3069 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3072 # elif defined(__CYGWIN__)
3073 /* There may be a better way on CYGWIN:
3074 - we could insert a dummy func in the _close function entry
3075 f->_close = (int (*)(void *)) dummy_close;
3079 # elif defined(WIN32)
3080 # if defined(__BORLANDC__)
3081 f->fd = PerlLIO_dup(fileno(f));
3082 # elif defined(UNDER_CE)
3083 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3092 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3093 (which isn't thread safe) instead
3095 # error "Don't know how to set FILE.fileno on your platform"
3103 PerlIOStdio_close(pTHX_ PerlIO *f)
3105 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3111 const int fd = fileno(stdio);
3116 #ifdef SOCKS5_VERSION_NAME
3117 /* Socks lib overrides close() but stdio isn't linked to
3118 that library (though we are) - so we must call close()
3119 on sockets on stdio's behalf.
3122 Sock_size_t optlen = sizeof(int);
3123 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3126 if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
3129 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3130 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3132 if (stdio == stdout || stdio == stderr)
3133 return PerlIO_flush(f);
3134 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3135 Use Sarathy's trick from maint-5.6 to invalidate the
3136 fileno slot of the FILE *
3138 result = PerlIO_flush(f);
3140 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3142 dupfd = PerlLIO_dup(fd);
3144 result = PerlSIO_fclose(stdio);
3145 /* We treat error from stdio as success if we invalidated
3146 errno may NOT be expected EBADF
3148 if (invalidate && result != 0) {
3152 #ifdef SOCKS5_VERSION_NAME
3153 /* in SOCKS' case, let close() determine return value */
3157 PerlLIO_dup2(dupfd,fd);
3158 PerlLIO_close(dupfd);
3165 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3168 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3172 STDCHAR *buf = (STDCHAR *) vbuf;
3174 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3175 * stdio does not do that for fread()
3177 const int ch = PerlSIO_fgetc(s);
3184 got = PerlSIO_fread(vbuf, 1, count, s);
3185 if (got == 0 && PerlSIO_ferror(s))
3187 if (got >= 0 || errno != EINTR)
3190 SETERRNO(0,0); /* just in case */
3196 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3199 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3201 #ifdef STDIO_BUFFER_WRITABLE
3202 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3203 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3204 STDCHAR *base = PerlIO_get_base(f);
3205 SSize_t cnt = PerlIO_get_cnt(f);
3206 STDCHAR *ptr = PerlIO_get_ptr(f);
3207 SSize_t avail = ptr - base;
3209 if (avail > count) {
3213 Move(buf-avail,ptr,avail,STDCHAR);
3216 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3217 if (PerlSIO_feof(s) && unread >= 0)
3218 PerlSIO_clearerr(s);
3223 if (PerlIO_has_cntptr(f)) {
3224 /* We can get pointer to buffer but not its base
3225 Do ungetc() but check chars are ending up in the
3228 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3229 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3231 const int ch = *--buf & 0xFF;
3232 if (ungetc(ch,s) != ch) {
3233 /* ungetc did not work */
3236 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3237 /* Did not change pointer as expected */
3238 fgetc(s); /* get char back again */
3248 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3254 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3259 got = PerlSIO_fwrite(vbuf, 1, count,
3260 PerlIOSelf(f, PerlIOStdio)->stdio);
3261 if (got >= 0 || errno != EINTR)
3264 SETERRNO(0,0); /* just in case */
3270 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3272 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3273 PERL_UNUSED_CONTEXT;
3275 return PerlSIO_fseek(stdio, offset, whence);
3279 PerlIOStdio_tell(pTHX_ PerlIO *f)
3281 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3282 PERL_UNUSED_CONTEXT;
3284 return PerlSIO_ftell(stdio);
3288 PerlIOStdio_flush(pTHX_ PerlIO *f)
3290 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3291 PERL_UNUSED_CONTEXT;
3293 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3294 return PerlSIO_fflush(stdio);
3300 * FIXME: This discards ungetc() and pre-read stuff which is not
3301 * right if this is just a "sync" from a layer above Suspect right
3302 * design is to do _this_ but not have layer above flush this
3303 * layer read-to-read
3306 * Not writeable - sync by attempting a seek
3308 const int err = errno;
3309 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3317 PerlIOStdio_eof(pTHX_ PerlIO *f)
3319 PERL_UNUSED_CONTEXT;
3321 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3325 PerlIOStdio_error(pTHX_ PerlIO *f)
3327 PERL_UNUSED_CONTEXT;
3329 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3333 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3335 PERL_UNUSED_CONTEXT;
3337 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3341 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3343 PERL_UNUSED_CONTEXT;
3345 #ifdef HAS_SETLINEBUF
3346 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3348 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3354 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3356 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3357 return (STDCHAR*)PerlSIO_get_base(stdio);
3361 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3363 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3364 return PerlSIO_get_bufsiz(stdio);
3368 #ifdef USE_STDIO_PTR
3370 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3372 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3373 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3377 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3379 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3380 return PerlSIO_get_cnt(stdio);
3384 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3386 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3388 #ifdef STDIO_PTR_LVALUE
3389 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3390 #ifdef STDIO_PTR_LVAL_SETS_CNT
3391 if (PerlSIO_get_cnt(stdio) != (cnt)) {
3392 assert(PerlSIO_get_cnt(stdio) == (cnt));
3395 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3397 * Setting ptr _does_ change cnt - we are done
3401 #else /* STDIO_PTR_LVALUE */
3403 #endif /* STDIO_PTR_LVALUE */
3406 * Now (or only) set cnt
3408 #ifdef STDIO_CNT_LVALUE
3409 PerlSIO_set_cnt(stdio, cnt);
3410 #else /* STDIO_CNT_LVALUE */
3411 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3412 PerlSIO_set_ptr(stdio,
3413 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3415 #else /* STDIO_PTR_LVAL_SETS_CNT */
3417 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3418 #endif /* STDIO_CNT_LVALUE */
3425 PerlIOStdio_fill(pTHX_ PerlIO *f)
3427 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3429 PERL_UNUSED_CONTEXT;
3432 * fflush()ing read-only streams can cause trouble on some stdio-s
3434 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3435 if (PerlSIO_fflush(stdio) != 0)
3439 c = PerlSIO_fgetc(stdio);
3442 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3448 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3450 #ifdef STDIO_BUFFER_WRITABLE
3451 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3452 /* Fake ungetc() to the real buffer in case system's ungetc
3455 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3456 SSize_t cnt = PerlSIO_get_cnt(stdio);
3457 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3458 if (ptr == base+1) {
3459 *--ptr = (STDCHAR) c;
3460 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3461 if (PerlSIO_feof(stdio))
3462 PerlSIO_clearerr(stdio);
3468 if (PerlIO_has_cntptr(f)) {
3470 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3477 /* An ungetc()d char is handled separately from the regular
3478 * buffer, so we stuff it in the buffer ourselves.
3479 * Should never get called as should hit code above
3481 *(--((*stdio)->_ptr)) = (unsigned char) c;
3484 /* If buffer snoop scheme above fails fall back to
3487 if (PerlSIO_ungetc(c, stdio) != c)
3495 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3496 sizeof(PerlIO_funcs),
3498 sizeof(PerlIOStdio),
3499 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3503 PerlIOBase_binmode, /* binmode */
3517 PerlIOStdio_clearerr,
3518 PerlIOStdio_setlinebuf,
3520 PerlIOStdio_get_base,
3521 PerlIOStdio_get_bufsiz,
3526 #ifdef USE_STDIO_PTR
3527 PerlIOStdio_get_ptr,
3528 PerlIOStdio_get_cnt,
3529 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3530 PerlIOStdio_set_ptrcnt,
3533 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3538 #endif /* USE_STDIO_PTR */
3541 /* Note that calls to PerlIO_exportFILE() are reversed using
3542 * PerlIO_releaseFILE(), not importFILE. */
3544 PerlIO_exportFILE(PerlIO * f, const char *mode)
3548 if (PerlIOValid(f)) {
3551 if (!mode || !*mode) {
3552 mode = PerlIO_modestr(f, buf);
3554 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3558 /* De-link any lower layers so new :stdio sticks */
3560 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3561 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3563 PerlIOUnix_refcnt_inc(fileno(stdio));
3564 /* Link previous lower layers under new one */
3568 /* restore layers list */
3578 PerlIO_findFILE(PerlIO *f)
3583 if (l->tab == &PerlIO_stdio) {
3584 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3587 l = *PerlIONext(&l);
3589 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3590 /* However, we're not really exporting a FILE * to someone else (who
3591 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3592 So we need to undo its refernce count increase on the underlying file
3593 descriptor. We have to do this, because if the loop above returns you
3594 the FILE *, then *it* didn't increase any reference count. So there's
3595 only one way to be consistent. */
3596 stdio = PerlIO_exportFILE(f, NULL);
3598 const int fd = fileno(stdio);
3600 PerlIOUnix_refcnt_dec(fd);
3605 /* Use this to reverse PerlIO_exportFILE calls. */
3607 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3612 if (l->tab == &PerlIO_stdio) {
3613 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3614 if (s->stdio == f) {
3616 const int fd = fileno(f);
3618 PerlIOUnix_refcnt_dec(fd);
3619 PerlIO_pop(aTHX_ p);
3628 /*--------------------------------------------------------------------------------------*/
3630 * perlio buffer layer
3634 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3636 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3637 const int fd = PerlIO_fileno(f);
3638 if (fd >= 0 && PerlLIO_isatty(fd)) {
3639 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3641 if (*PerlIONext(f)) {
3642 const Off_t posn = PerlIO_tell(PerlIONext(f));
3643 if (posn != (Off_t) - 1) {
3647 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3651 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3652 IV n, const char *mode, int fd, int imode, int perm,
3653 PerlIO *f, int narg, SV **args)
3655 if (PerlIOValid(f)) {
3656 PerlIO *next = PerlIONext(f);
3658 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3659 if (tab && tab->Open)
3661 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3663 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3668 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3670 if (*mode == IoTYPE_IMPLICIT) {
3676 if (tab && tab->Open)
3677 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3680 SETERRNO(EINVAL, LIB_INVARG);
3682 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3684 * if push fails during open, open fails. close will pop us.
3689 fd = PerlIO_fileno(f);
3690 if (init && fd == 2) {
3692 * Initial stderr is unbuffered
3694 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3696 #ifdef PERLIO_USING_CRLF
3697 # ifdef PERLIO_IS_BINMODE_FD
3698 if (PERLIO_IS_BINMODE_FD(fd))
3699 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3703 * do something about failing setmode()? --jhi
3705 PerlLIO_setmode(fd, O_BINARY);
3714 * This "flush" is akin to sfio's sync in that it handles files in either
3715 * read or write state. For write state, we put the postponed data through
3716 * the next layers. For read state, we seek() the next layers to the
3717 * offset given by current position in the buffer, and discard the buffer
3718 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3719 * in any case?). Then the pass the stick further in chain.
3722 PerlIOBuf_flush(pTHX_ PerlIO *f)
3724 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3726 PerlIO *n = PerlIONext(f);
3727 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3729 * write() the buffer
3731 const STDCHAR *buf = b->buf;
3732 const STDCHAR *p = buf;
3733 while (p < b->ptr) {
3734 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3738 else if (count < 0 || PerlIO_error(n)) {
3739 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3744 b->posn += (p - buf);
3746 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3747 STDCHAR *buf = PerlIO_get_base(f);
3749 * Note position change
3751 b->posn += (b->ptr - buf);
3752 if (b->ptr < b->end) {
3753 /* We did not consume all of it - try and seek downstream to
3754 our logical position
3756 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3757 /* Reload n as some layers may pop themselves on seek */
3758 b->posn = PerlIO_tell(n = PerlIONext(f));
3761 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3762 data is lost for good - so return saying "ok" having undone
3765 b->posn -= (b->ptr - buf);
3770 b->ptr = b->end = b->buf;
3771 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3772 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3773 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3778 /* This discards the content of the buffer after b->ptr, and rereads
3779 * the buffer from the position off in the layer downstream; here off
3780 * is at offset corresponding to b->ptr - b->buf.
3783 PerlIOBuf_fill(pTHX_ PerlIO *f)
3785 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3786 PerlIO *n = PerlIONext(f);
3789 * Down-stream flush is defined not to loose read data so is harmless.
3790 * we would not normally be fill'ing if there was data left in anycase.
3792 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3794 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3795 PerlIOBase_flush_linebuf(aTHX);
3798 PerlIO_get_base(f); /* allocate via vtable */
3800 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3802 b->ptr = b->end = b->buf;
3804 if (!PerlIOValid(n)) {
3805 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3809 if (PerlIO_fast_gets(n)) {
3811 * Layer below is also buffered. We do _NOT_ want to call its
3812 * ->Read() because that will loop till it gets what we asked for
3813 * which may hang on a pipe etc. Instead take anything it has to
3814 * hand, or ask it to fill _once_.
3816 avail = PerlIO_get_cnt(n);
3818 avail = PerlIO_fill(n);
3820 avail = PerlIO_get_cnt(n);
3822 if (!PerlIO_error(n) && PerlIO_eof(n))
3827 STDCHAR *ptr = PerlIO_get_ptr(n);
3828 const SSize_t cnt = avail;
3829 if (avail > (SSize_t)b->bufsiz)
3831 Copy(ptr, b->buf, avail, STDCHAR);
3832 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3836 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3840 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3842 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3845 b->end = b->buf + avail;
3846 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3851 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3853 if (PerlIOValid(f)) {
3854 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3857 return PerlIOBase_read(aTHX_ f, vbuf, count);
3863 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3865 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3866 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3869 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3874 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3876 * Buffer is already a read buffer, we can overwrite any chars
3877 * which have been read back to buffer start
3879 avail = (b->ptr - b->buf);
3883 * Buffer is idle, set it up so whole buffer is available for
3887 b->end = b->buf + avail;
3889 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3891 * Buffer extends _back_ from where we are now
3893 b->posn -= b->bufsiz;
3895 if (avail > (SSize_t) count) {
3897 * If we have space for more than count, just move count
3905 * In simple stdio-like ungetc() case chars will be already
3908 if (buf != b->ptr) {
3909 Copy(buf, b->ptr, avail, STDCHAR);
3913 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3917 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3923 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3925 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3926 const STDCHAR *buf = (const STDCHAR *) vbuf;
3927 const STDCHAR *flushptr = buf;
3931 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3933 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3934 if (PerlIO_flush(f) != 0) {
3938 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3939 flushptr = buf + count;
3940 while (flushptr > buf && *(flushptr - 1) != '\n')
3944 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3945 if ((SSize_t) count < avail)
3947 if (flushptr > buf && flushptr <= buf + avail)
3948 avail = flushptr - buf;
3949 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3951 Copy(buf, b->ptr, avail, STDCHAR);
3956 if (buf == flushptr)
3959 if (b->ptr >= (b->buf + b->bufsiz))
3962 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3968 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3971 if ((code = PerlIO_flush(f)) == 0) {
3972 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3973 code = PerlIO_seek(PerlIONext(f), offset, whence);
3975 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3976 b->posn = PerlIO_tell(PerlIONext(f));
3983 PerlIOBuf_tell(pTHX_ PerlIO *f)
3985 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3987 * b->posn is file position where b->buf was read, or will be written
3989 Off_t posn = b->posn;
3990 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
3991 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3993 /* As O_APPEND files are normally shared in some sense it is better
3998 /* when file is NOT shared then this is sufficient */
3999 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4001 posn = b->posn = PerlIO_tell(PerlIONext(f));
4005 * If buffer is valid adjust position by amount in buffer
4007 posn += (b->ptr - b->buf);
4013 PerlIOBuf_popped(pTHX_ PerlIO *f)
4015 const IV code = PerlIOBase_popped(aTHX_ f);
4016 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4017 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4020 b->ptr = b->end = b->buf = NULL;
4021 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4026 PerlIOBuf_close(pTHX_ PerlIO *f)
4028 const IV code = PerlIOBase_close(aTHX_ f);
4029 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4030 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4033 b->ptr = b->end = b->buf = NULL;
4034 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4039 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4041 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4048 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4050 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4053 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4054 return (b->end - b->ptr);
4059 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4061 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4062 PERL_UNUSED_CONTEXT;
4067 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
4069 b->buf = (STDCHAR *) & b->oneword;
4070 b->bufsiz = sizeof(b->oneword);
4072 b->end = b->ptr = b->buf;
4078 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4080 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4083 return (b->end - b->buf);
4087 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4089 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4093 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
4094 assert(PerlIO_get_cnt(f) == cnt);
4095 assert(b->ptr >= b->buf);
4097 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4101 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4103 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4108 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4109 sizeof(PerlIO_funcs),
4112 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4116 PerlIOBase_binmode, /* binmode */
4130 PerlIOBase_clearerr,
4131 PerlIOBase_setlinebuf,
4136 PerlIOBuf_set_ptrcnt,
4139 /*--------------------------------------------------------------------------------------*/
4141 * Temp layer to hold unread chars when cannot do it any other way
4145 PerlIOPending_fill(pTHX_ PerlIO *f)
4148 * Should never happen
4155 PerlIOPending_close(pTHX_ PerlIO *f)
4158 * A tad tricky - flush pops us, then we close new top
4161 return PerlIO_close(f);
4165 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4168 * A tad tricky - flush pops us, then we seek new top
4171 return PerlIO_seek(f, offset, whence);
4176 PerlIOPending_flush(pTHX_ PerlIO *f)
4178 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4179 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4183 PerlIO_pop(aTHX_ f);
4188 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4194 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4199 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4201 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4202 PerlIOl * const l = PerlIOBase(f);
4204 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4205 * etc. get muddled when it changes mid-string when we auto-pop.
4207 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4208 (PerlIOBase(PerlIONext(f))->
4209 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4214 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4216 SSize_t avail = PerlIO_get_cnt(f);
4218 if ((SSize_t)count < avail)
4221 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4222 if (got >= 0 && got < (SSize_t)count) {
4223 const SSize_t more =
4224 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4225 if (more >= 0 || got == 0)
4231 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4232 sizeof(PerlIO_funcs),
4235 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4236 PerlIOPending_pushed,
4239 PerlIOBase_binmode, /* binmode */
4248 PerlIOPending_close,
4249 PerlIOPending_flush,
4253 PerlIOBase_clearerr,
4254 PerlIOBase_setlinebuf,
4259 PerlIOPending_set_ptrcnt,
4264 /*--------------------------------------------------------------------------------------*/
4266 * crlf - translation On read translate CR,LF to "\n" we do this by
4267 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4268 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4270 * c->nl points on the first byte of CR LF pair when it is temporarily
4271 * replaced by LF, or to the last CR of the buffer. In the former case
4272 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4273 * that it ends at c->nl; these two cases can be distinguished by
4274 * *c->nl. c->nl is set during _getcnt() call, and unset during
4275 * _unread() and _flush() calls.
4276 * It only matters for read operations.
4280 PerlIOBuf base; /* PerlIOBuf stuff */
4281 STDCHAR *nl; /* Position of crlf we "lied" about in the
4285 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4286 * Otherwise the :crlf layer would always revert back to
4290 S_inherit_utf8_flag(PerlIO *f)
4292 PerlIO *g = PerlIONext(f);
4293 if (PerlIOValid(g)) {
4294 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4295 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4301 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4304 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4305 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4307 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4308 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4309 PerlIOBase(f)->flags);
4312 /* Enable the first CRLF capable layer you can find, but if none
4313 * found, the one we just pushed is fine. This results in at
4314 * any given moment at most one CRLF-capable layer being enabled
4315 * in the whole layer stack. */
4316 PerlIO *g = PerlIONext(f);
4317 while (PerlIOValid(g)) {
4318 PerlIOl *b = PerlIOBase(g);
4319 if (b && b->tab == &PerlIO_crlf) {
4320 if (!(b->flags & PERLIO_F_CRLF))
4321 b->flags |= PERLIO_F_CRLF;
4322 S_inherit_utf8_flag(g);
4323 PerlIO_pop(aTHX_ f);
4329 S_inherit_utf8_flag(f);
4335 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4337 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4338 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4342 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4343 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4345 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4346 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4348 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4353 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4354 b->end = b->ptr = b->buf + b->bufsiz;
4355 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4356 b->posn -= b->bufsiz;
4358 while (count > 0 && b->ptr > b->buf) {
4359 const int ch = *--buf;
4361 if (b->ptr - 2 >= b->buf) {
4368 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4369 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4385 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4387 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4389 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4392 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4393 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4394 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4395 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4397 while (nl < b->end && *nl != 0xd)
4399 if (nl < b->end && *nl == 0xd) {
4401 if (nl + 1 < b->end) {
4408 * Not CR,LF but just CR
4416 * Blast - found CR as last char in buffer
4421 * They may not care, defer work as long as
4425 return (nl - b->ptr);
4429 b->ptr++; /* say we have read it as far as
4430 * flush() is concerned */
4431 b->buf++; /* Leave space in front of buffer */
4432 /* Note as we have moved buf up flush's
4434 will naturally make posn point at CR
4436 b->bufsiz--; /* Buffer is thus smaller */
4437 code = PerlIO_fill(f); /* Fetch some more */
4438 b->bufsiz++; /* Restore size for next time */
4439 b->buf--; /* Point at space */
4440 b->ptr = nl = b->buf; /* Which is what we hand
4442 *nl = 0xd; /* Fill in the CR */
4444 goto test; /* fill() call worked */
4446 * CR at EOF - just fall through
4448 /* Should we clear EOF though ??? */
4453 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4459 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4461 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4462 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4468 if (ptr == b->end && *c->nl == 0xd) {
4469 /* Defered CR at end of buffer case - we lied about count */
4482 * Test code - delete when it works ...
4484 IV flags = PerlIOBase(f)->flags;
4485 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4486 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
4487 /* Defered CR at end of buffer case - we lied about count */
4493 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4494 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4495 flags, c->nl, b->end, cnt);
4502 * They have taken what we lied about
4510 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4514 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4516 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4517 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4519 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4520 const STDCHAR *buf = (const STDCHAR *) vbuf;
4521 const STDCHAR * const ebuf = buf + count;
4524 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4526 while (buf < ebuf) {
4527 const STDCHAR * const eptr = b->buf + b->bufsiz;
4528 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4529 while (buf < ebuf && b->ptr < eptr) {
4531 if ((b->ptr + 2) > eptr) {
4539 *(b->ptr)++ = 0xd; /* CR */
4540 *(b->ptr)++ = 0xa; /* LF */
4542 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4549 *(b->ptr)++ = *buf++;
4551 if (b->ptr >= eptr) {
4557 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4559 return (buf - (STDCHAR *) vbuf);
4564 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4566 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4571 return PerlIOBuf_flush(aTHX_ f);
4575 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4577 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4578 /* In text mode - flush any pending stuff and flip it */
4579 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4580 #ifndef PERLIO_USING_CRLF
4581 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4582 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4583 PerlIO_pop(aTHX_ f);
4590 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4591 sizeof(PerlIO_funcs),
4594 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4596 PerlIOBuf_popped, /* popped */
4598 PerlIOCrlf_binmode, /* binmode */
4602 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4603 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4604 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4612 PerlIOBase_clearerr,
4613 PerlIOBase_setlinebuf,
4618 PerlIOCrlf_set_ptrcnt,
4622 /*--------------------------------------------------------------------------------------*/
4624 * mmap as "buffer" layer
4628 PerlIOBuf base; /* PerlIOBuf stuff */
4629 Mmap_t mptr; /* Mapped address */
4630 Size_t len; /* mapped length */
4631 STDCHAR *bbuf; /* malloced buffer if map fails */
4635 PerlIOMmap_map(pTHX_ PerlIO *f)
4638 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4639 const IV flags = PerlIOBase(f)->flags;
4643 if (flags & PERLIO_F_CANREAD) {
4644 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4645 const int fd = PerlIO_fileno(f);
4647 code = Fstat(fd, &st);
4648 if (code == 0 && S_ISREG(st.st_mode)) {
4649 SSize_t len = st.st_size - b->posn;
4652 if (PL_mmap_page_size <= 0)
4653 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4657 * This is a hack - should never happen - open should
4660 b->posn = PerlIO_tell(PerlIONext(f));
4662 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
4663 len = st.st_size - posn;
4664 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
4665 if (m->mptr && m->mptr != (Mmap_t) - 1) {
4666 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4667 madvise(m->mptr, len, MADV_SEQUENTIAL);
4669 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4670 madvise(m->mptr, len, MADV_WILLNEED);
4672 PerlIOBase(f)->flags =
4673 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4674 b->end = ((STDCHAR *) m->mptr) + len;
4675 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4684 PerlIOBase(f)->flags =
4685 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4687 b->ptr = b->end = b->ptr;
4696 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4698 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4701 PerlIOBuf * const b = &m->base;
4703 /* The munmap address argument is tricky: depending on the
4704 * standard it is either "void *" or "caddr_t" (which is
4705 * usually "char *" (signed or unsigned). If we cast it
4706 * to "void *", those that have it caddr_t and an uptight
4707 * C++ compiler, will freak out. But casting it as char*
4708 * should work. Maybe. (Using Mmap_t figured out by
4709 * Configure doesn't always work, apparently.) */
4710 code = munmap((char*)m->mptr, m->len);
4714 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4717 b->ptr = b->end = b->buf;
4718 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4724 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4726 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4727 PerlIOBuf * const b = &m->base;
4728 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4730 * Already have a readbuffer in progress
4736 * We have a write buffer or flushed PerlIOBuf read buffer
4738 m->bbuf = b->buf; /* save it in case we need it again */
4739 b->buf = NULL; /* Clear to trigger below */
4742 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4745 * Map did not work - recover PerlIOBuf buffer if we have one
4750 b->ptr = b->end = b->buf;
4753 return PerlIOBuf_get_base(aTHX_ f);
4757 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4759 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4760 PerlIOBuf * const b = &m->base;
4761 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4763 if (b->ptr && (b->ptr - count) >= b->buf
4764 && memEQ(b->ptr - count, vbuf, count)) {
4766 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4771 * Loose the unwritable mapped buffer
4775 * If flush took the "buffer" see if we have one from before
4777 if (!b->buf && m->bbuf)
4780 PerlIOBuf_get_base(aTHX_ f);
4784 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4788 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4790 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4791 PerlIOBuf * const b = &m->base;
4793 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4795 * No, or wrong sort of, buffer
4798 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4802 * If unmap took the "buffer" see if we have one from before
4804 if (!b->buf && m->bbuf)
4807 PerlIOBuf_get_base(aTHX_ f);
4811 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4815 PerlIOMmap_flush(pTHX_ PerlIO *f)
4817 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4818 PerlIOBuf * const b = &m->base;
4819 IV code = PerlIOBuf_flush(aTHX_ f);
4821 * Now we are "synced" at PerlIOBuf level
4828 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4833 * We seem to have a PerlIOBuf buffer which was not mapped
4834 * remember it in case we need one later
4843 PerlIOMmap_fill(pTHX_ PerlIO *f)
4845 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4846 IV code = PerlIO_flush(f);
4847 if (code == 0 && !b->buf) {
4848 code = PerlIOMmap_map(aTHX_ f);
4850 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4851 code = PerlIOBuf_fill(aTHX_ f);
4857 PerlIOMmap_close(pTHX_ PerlIO *f)
4859 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4860 PerlIOBuf * const b = &m->base;
4861 IV code = PerlIO_flush(f);
4865 b->ptr = b->end = b->buf;
4867 if (PerlIOBuf_close(aTHX_ f) != 0)
4873 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4875 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4879 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
4880 sizeof(PerlIO_funcs),
4883 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4887 PerlIOBase_binmode, /* binmode */
4901 PerlIOBase_clearerr,
4902 PerlIOBase_setlinebuf,
4903 PerlIOMmap_get_base,
4907 PerlIOBuf_set_ptrcnt,
4910 #endif /* HAS_MMAP */
4913 Perl_PerlIO_stdin(pTHX)
4917 PerlIO_stdstreams(aTHX);
4919 return &PL_perlio[1];
4923 Perl_PerlIO_stdout(pTHX)
4927 PerlIO_stdstreams(aTHX);
4929 return &PL_perlio[2];
4933 Perl_PerlIO_stderr(pTHX)
4937 PerlIO_stdstreams(aTHX);
4939 return &PL_perlio[3];
4942 /*--------------------------------------------------------------------------------------*/
4945 PerlIO_getname(PerlIO *f, char *buf)
4950 bool exported = FALSE;
4951 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4953 stdio = PerlIO_exportFILE(f,0);
4957 name = fgetname(stdio, buf);
4958 if (exported) PerlIO_releaseFILE(f,stdio);
4963 PERL_UNUSED_ARG(buf);
4964 Perl_croak(aTHX_ "Don't know how to get file name");
4970 /*--------------------------------------------------------------------------------------*/
4972 * Functions which can be called on any kind of PerlIO implemented in
4976 #undef PerlIO_fdopen
4978 PerlIO_fdopen(int fd, const char *mode)
4981 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4986 PerlIO_open(const char *path, const char *mode)
4989 SV *name = sv_2mortal(newSVpv(path, 0));
4990 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4993 #undef Perlio_reopen
4995 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4998 SV *name = sv_2mortal(newSVpv(path,0));
4999 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
5004 PerlIO_getc(PerlIO *f)
5008 if ( 1 == PerlIO_read(f, buf, 1) ) {
5009 return (unsigned char) buf[0];
5014 #undef PerlIO_ungetc
5016 PerlIO_ungetc(PerlIO *f, int ch)
5021 if (PerlIO_unread(f, &buf, 1) == 1)
5029 PerlIO_putc(PerlIO *f, int ch)
5033 return PerlIO_write(f, &buf, 1);
5038 PerlIO_puts(PerlIO *f, const char *s)
5041 return PerlIO_write(f, s, strlen(s));
5044 #undef PerlIO_rewind
5046 PerlIO_rewind(PerlIO *f)
5049 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
5053 #undef PerlIO_vprintf
5055 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5064 Perl_va_copy(ap, apc);
5065 sv = vnewSVpvf(fmt, &apc);
5067 sv = vnewSVpvf(fmt, &ap);
5069 s = SvPV_const(sv, len);
5070 wrote = PerlIO_write(f, s, len);
5075 #undef PerlIO_printf
5077 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5082 result = PerlIO_vprintf(f, fmt, ap);
5087 #undef PerlIO_stdoutf
5089 PerlIO_stdoutf(const char *fmt, ...)
5095 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5100 #undef PerlIO_tmpfile
5102 PerlIO_tmpfile(void)
5107 const int fd = win32_tmpfd();
5109 f = PerlIO_fdopen(fd, "w+b");
5111 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
5112 SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
5114 * I have no idea how portable mkstemp() is ... NI-S
5116 const int fd = mkstemp(SvPVX(sv));
5118 f = PerlIO_fdopen(fd, "w+");
5120 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5121 PerlLIO_unlink(SvPVX_const(sv));
5124 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5125 FILE * const stdio = PerlSIO_tmpfile();
5128 f = PerlIO_fdopen(fileno(stdio), "w+");
5130 # endif /* else HAS_MKSTEMP */
5131 #endif /* else WIN32 */
5138 #endif /* USE_SFIO */
5139 #endif /* PERLIO_IS_STDIO */
5141 /*======================================================================================*/
5143 * Now some functions in terms of above which may be needed even if we are
5144 * not in true PerlIO mode
5147 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5150 const char *direction = NULL;
5153 * Need to supply default layer info from open.pm
5159 if (mode && mode[0] != 'r') {
5160 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5161 direction = "open>";
5163 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5164 direction = "open<";
5169 layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
5170 0, direction, 5, 0, 0);
5173 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5178 #undef PerlIO_setpos
5180 PerlIO_setpos(PerlIO *f, SV *pos)
5185 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5186 if (f && len == sizeof(Off_t))
5187 return PerlIO_seek(f, *posn, SEEK_SET);
5189 SETERRNO(EINVAL, SS_IVCHAN);
5193 #undef PerlIO_setpos
5195 PerlIO_setpos(PerlIO *f, SV *pos)
5200 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5201 if (f && len == sizeof(Fpos_t)) {
5202 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5203 return fsetpos64(f, fpos);
5205 return fsetpos(f, fpos);
5209 SETERRNO(EINVAL, SS_IVCHAN);
5215 #undef PerlIO_getpos
5217 PerlIO_getpos(PerlIO *f, SV *pos)
5220 Off_t posn = PerlIO_tell(f);
5221 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5222 return (posn == (Off_t) - 1) ? -1 : 0;
5225 #undef PerlIO_getpos
5227 PerlIO_getpos(PerlIO *f, SV *pos)
5232 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5233 code = fgetpos64(f, &fpos);
5235 code = fgetpos(f, &fpos);
5237 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5242 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5245 vprintf(char *pat, char *args)
5247 _doprnt(pat, args, stdout);
5248 return 0; /* wrong, but perl doesn't use the return
5253 vfprintf(FILE *fd, char *pat, char *args)
5255 _doprnt(pat, args, fd);
5256 return 0; /* wrong, but perl doesn't use the return
5262 #ifndef PerlIO_vsprintf
5264 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
5267 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
5268 PERL_UNUSED_CONTEXT;
5270 #ifndef PERL_MY_VSNPRINTF_GUARDED
5271 if (val < 0 || (n > 0 ? val >= n : 0)) {
5272 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
5279 #ifndef PerlIO_sprintf
5281 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
5286 result = PerlIO_vsprintf(s, n, fmt, ap);
5294 * c-indentation-style: bsd
5296 * indent-tabs-mode: t
5299 * ex: set ts=8 sts=4 sw=4 noet: