3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
17 /* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
28 #ifdef PERL_IMPLICIT_SYS
34 #define PERLIO_NOT_STDIO 0
36 * This file provides those parts of PerlIO abstraction
37 * which are not #defined in perlio.h.
38 * Which these are depends on various Configure #ifdef's
42 #define PERL_IN_PERLIO_C
45 #ifdef PERL_IMPLICIT_CONTEXT
53 /* Missing proto on LynxOS */
61 #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
63 /* Call the callback or PerlIOBase, and return failure. */
64 #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
65 if (PerlIOValid(f)) { \
66 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
67 if (tab && tab->callback) \
68 return (*tab->callback) args; \
70 return PerlIOBase_ ## base args; \
73 SETERRNO(EBADF, SS_IVCHAN); \
76 /* Call the callback or fail, and return failure. */
77 #define Perl_PerlIO_or_fail(f, callback, failure, args) \
78 if (PerlIOValid(f)) { \
79 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
80 if (tab && tab->callback) \
81 return (*tab->callback) args; \
82 SETERRNO(EINVAL, LIB_INVARG); \
85 SETERRNO(EBADF, SS_IVCHAN); \
88 /* Call the callback or PerlIOBase, and be void. */
89 #define Perl_PerlIO_or_Base_void(f, callback, base, args) \
90 if (PerlIOValid(f)) { \
91 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
92 if (tab && tab->callback) \
93 (*tab->callback) args; \
95 PerlIOBase_ ## base args; \
98 SETERRNO(EBADF, SS_IVCHAN)
100 /* Call the callback or fail, and be void. */
101 #define Perl_PerlIO_or_fail_void(f, callback, args) \
102 if (PerlIOValid(f)) { \
103 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
104 if (tab && tab->callback) \
105 (*tab->callback) args; \
107 SETERRNO(EINVAL, LIB_INVARG); \
110 SETERRNO(EBADF, SS_IVCHAN)
112 #if defined(__osf__) && _XOPEN_SOURCE < 500
113 extern int fseeko(FILE *, off_t, int);
114 extern off_t ftello(FILE *);
117 #define NATIVE_0xd CR_NATIVE
118 #define NATIVE_0xa LF_NATIVE
120 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
123 perlsio_binmode(FILE *fp, int iotype, int mode)
126 * This used to be contents of do_binmode in doio.c
130 PERL_UNUSED_ARG(iotype);
132 if (PerlLIO_setmode(fp, mode) != -1) {
134 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
141 # if defined(USEMYBINMODE)
143 # if defined(__CYGWIN__)
144 PERL_UNUSED_ARG(iotype);
146 if (my_binmode(fp, iotype, mode) != FALSE)
152 PERL_UNUSED_ARG(iotype);
153 PERL_UNUSED_ARG(mode);
160 #define O_ACCMODE 3 /* Assume traditional implementation */
164 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
166 const int result = rawmode & O_ACCMODE;
171 ptype = IoTYPE_RDONLY;
174 ptype = IoTYPE_WRONLY;
182 *writing = (result != O_RDONLY);
184 if (result == O_RDONLY) {
188 else if (rawmode & O_APPEND) {
190 if (result != O_WRONLY)
195 if (result == O_WRONLY)
202 #ifdef PERLIO_BINARY_AND_TEXT_DIFFERENT_AND_EFFECTIVE
203 if (rawmode & O_BINARY)
210 #ifndef PERLIO_LAYERS
212 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
214 if (!names || !*names
215 || strEQ(names, ":crlf")
216 || strEQ(names, ":raw")
217 || strEQ(names, ":bytes")
221 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
229 PerlIO_destruct(pTHX)
234 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
236 return perlsio_binmode(fp, iotype, mode);
240 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
242 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
245 #ifdef PERL_IMPLICIT_SYS
246 return PerlSIO_fdupopen(f);
249 return win32_fdupopen(f);
252 const int fd = PerlLIO_dup(PerlIO_fileno(f));
256 const int omode = djgpp_get_stream_mode(f);
258 const int omode = fcntl(fd, F_GETFL);
260 PerlIO_intmode2str(omode,mode,NULL);
261 /* the r+ is a hack */
262 return PerlIO_fdopen(fd, mode);
267 SETERRNO(EBADF, SS_IVCHAN);
277 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
281 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
282 int imode, int perm, PerlIO *old, int narg, SV **args)
286 Perl_croak(aTHX_ "More than one argument to open");
288 if (*args == &PL_sv_undef)
289 return PerlIO_tmpfile();
292 const char *name = SvPV_const(*args, len);
293 if (!IS_SAFE_PATHNAME(name, len, "open"))
296 if (*mode == IoTYPE_NUMERIC) {
297 fd = PerlLIO_open3(name, imode, perm);
299 return PerlIO_fdopen(fd, mode + 1);
302 return PerlIO_reopen(name, mode, old);
305 return PerlIO_open(name, mode);
310 return PerlIO_fdopen(fd, (char *) mode);
315 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
316 XS(XS_PerlIO__Layer__find)
320 Perl_croak(aTHX_ "Usage class->find(name[,load])");
322 const char * const name = SvPV_nolen_const(ST(1));
323 ST(0) = (strEQ(name, "crlf")
324 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
331 Perl_boot_core_PerlIO(pTHX)
333 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
339 #ifdef PERLIO_IS_STDIO
346 * Does nothing (yet) except force this file to be included in perl
347 * binary. That allows this file to force inclusion of other functions
348 * that may be required by loadable extensions e.g. for
349 * FileHandle::tmpfile
353 #undef PerlIO_tmpfile
360 #else /* PERLIO_IS_STDIO */
362 /*======================================================================================*/
364 * Implement all the PerlIO interface ourselves.
370 PerlIO_debug(const char *fmt, ...)
375 if (!PL_perlio_debug_fd) {
377 PerlProc_getuid() == PerlProc_geteuid() &&
378 PerlProc_getgid() == PerlProc_getegid()) {
379 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
382 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
384 PL_perlio_debug_fd = -1;
386 /* tainting or set*id, so ignore the environment, and ensure we
387 skip these tests next time through. */
388 PL_perlio_debug_fd = -1;
391 if (PL_perlio_debug_fd > 0) {
394 const char * const s = CopFILE(PL_curcop);
395 /* Use fixed buffer as sv_catpvf etc. needs SVs */
397 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
398 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
399 rc = PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2);
401 const char *s = CopFILE(PL_curcop);
403 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
404 (IV) CopLINE(PL_curcop));
405 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
407 s = SvPV_const(sv, len);
408 rc = PerlLIO_write(PL_perlio_debug_fd, s, len);
411 /* silently ignore failures */
417 /*--------------------------------------------------------------------------------------*/
420 * Inner level routines
423 /* check that the head field of each layer points back to the head */
426 # define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
428 PerlIO_verify_head(pTHX_ PerlIO *f)
434 p = head = PerlIOBase(f)->head;
437 assert(p->head == head);
438 if (p == (PerlIOl*)f)
445 # define VERIFY_HEAD(f)
450 * Table of pointers to the PerlIO structs (malloc'ed)
452 #define PERLIO_TABLE_SIZE 64
455 PerlIO_init_table(pTHX)
459 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
465 PerlIO_allocate(pTHX)
469 * Find a free slot in the table, allocating new table as necessary
474 while ((f = *last)) {
476 last = (PerlIOl **) (f);
477 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
478 if (!((++f)->next)) {
479 f->flags = 0; /* lockcnt */
486 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
490 *last = (PerlIOl*) f++;
491 f->flags = 0; /* lockcnt */
497 #undef PerlIO_fdupopen
499 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
501 if (PerlIOValid(f)) {
502 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
503 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
505 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
507 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
511 SETERRNO(EBADF, SS_IVCHAN);
517 PerlIO_cleantable(pTHX_ PerlIOl **tablep)
519 PerlIOl * const table = *tablep;
522 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
523 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
524 PerlIOl * const f = table + i;
526 PerlIO_close(&(f->next));
536 PerlIO_list_alloc(pTHX)
540 Newxz(list, 1, PerlIO_list_t);
546 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
549 if (--list->refcnt == 0) {
552 for (i = 0; i < list->cur; i++)
553 SvREFCNT_dec(list->array[i].arg);
554 Safefree(list->array);
562 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
568 if (list->cur >= list->len) {
571 Renew(list->array, list->len, PerlIO_pair_t);
573 Newx(list->array, list->len, PerlIO_pair_t);
575 p = &(list->array[list->cur++]);
577 if ((p->arg = arg)) {
578 SvREFCNT_inc_simple_void_NN(arg);
583 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
585 PerlIO_list_t *list = NULL;
588 list = PerlIO_list_alloc(aTHX);
589 for (i=0; i < proto->cur; i++) {
590 SV *arg = proto->array[i].arg;
593 arg = sv_dup(arg, param);
595 PERL_UNUSED_ARG(param);
597 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
604 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
607 PerlIOl **table = &proto->Iperlio;
610 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
611 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
612 PerlIO_init_table(aTHX);
613 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
614 while ((f = *table)) {
616 table = (PerlIOl **) (f++);
617 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
619 (void) fp_dup(&(f->next), 0, param);
626 PERL_UNUSED_ARG(proto);
627 PERL_UNUSED_ARG(param);
632 PerlIO_destruct(pTHX)
635 PerlIOl **table = &PL_perlio;
638 PerlIO_debug("Destruct %p\n",(void*)aTHX);
640 while ((f = *table)) {
642 table = (PerlIOl **) (f++);
643 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
644 PerlIO *x = &(f->next);
647 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
648 PerlIO_debug("Destruct popping %s\n", l->tab->name);
662 PerlIO_pop(pTHX_ PerlIO *f)
664 const PerlIOl *l = *f;
667 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
668 l->tab ? l->tab->name : "(Null)");
669 if (l->tab && l->tab->Popped) {
671 * If popped returns non-zero do not free its layer structure
672 * it has either done so itself, or it is shared and still in
675 if ((*l->tab->Popped) (aTHX_ f) != 0)
678 if (PerlIO_lockcnt(f)) {
679 /* we're in use; defer freeing the structure */
680 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
681 PerlIOBase(f)->tab = NULL;
691 /* Return as an array the stack of layers on a filehandle. Note that
692 * the stack is returned top-first in the array, and there are three
693 * times as many array elements as there are layers in the stack: the
694 * first element of a layer triplet is the name, the second one is the
695 * arguments, and the third one is the flags. */
698 PerlIO_get_layers(pTHX_ PerlIO *f)
701 AV * const av = newAV();
703 if (PerlIOValid(f)) {
704 PerlIOl *l = PerlIOBase(f);
707 /* There is some collusion in the implementation of
708 XS_PerlIO_get_layers - it knows that name and flags are
709 generated as fresh SVs here, and takes advantage of that to
710 "copy" them by taking a reference. If it changes here, it needs
711 to change there too. */
712 SV * const name = l->tab && l->tab->name ?
713 newSVpv(l->tab->name, 0) : &PL_sv_undef;
714 SV * const arg = l->tab && l->tab->Getarg ?
715 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
718 av_push(av, newSViv((IV)l->flags));
726 /*--------------------------------------------------------------------------------------*/
728 * XS Interface for perl code
732 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
736 if ((SSize_t) len <= 0)
738 for (i = 0; i < PL_known_layers->cur; i++) {
739 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
740 const STRLEN this_len = strlen(f->name);
741 if (this_len == len && memEQ(f->name, name, len)) {
742 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
746 if (load && PL_subname && PL_def_layerlist
747 && PL_def_layerlist->cur >= 2) {
748 if (PL_in_load_module) {
749 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
752 SV * const pkgsv = newSVpvs("PerlIO");
753 SV * const layer = newSVpvn(name, len);
754 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
756 SAVEBOOL(PL_in_load_module);
758 SAVEGENERICSV(PL_warnhook);
759 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
761 PL_in_load_module = TRUE;
763 * The two SVs are magically freed by load_module
765 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
767 return PerlIO_find_layer(aTHX_ name, len, 0);
770 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
774 #ifdef USE_ATTRIBUTES_FOR_PERLIO
777 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
780 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
781 PerlIO * const ifp = IoIFP(io);
782 PerlIO * const ofp = IoOFP(io);
783 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
784 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
790 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
793 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
794 PerlIO * const ifp = IoIFP(io);
795 PerlIO * const ofp = IoOFP(io);
796 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
797 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
803 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
805 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
810 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
812 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
816 MGVTBL perlio_vtab = {
824 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
825 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
828 SV * const sv = SvRV(ST(1));
829 AV * const av = newAV();
833 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
835 mg = mg_find(sv, PERL_MAGIC_ext);
836 mg->mg_virtual = &perlio_vtab;
838 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
839 for (i = 2; i < items; i++) {
841 const char * const name = SvPV_const(ST(i), len);
842 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
844 av_push(av, SvREFCNT_inc_simple_NN(layer));
855 #endif /* USE_ATTIBUTES_FOR_PERLIO */
858 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
860 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
861 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
865 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
866 XS(XS_PerlIO__Layer__NoWarnings)
868 /* This is used as a %SIG{__WARN__} handler to suppress warnings
869 during loading of layers.
875 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
879 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
880 XS(XS_PerlIO__Layer__find)
886 Perl_croak(aTHX_ "Usage class->find(name[,load])");
889 const char * const name = SvPV_const(ST(1), len);
890 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
891 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
893 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
900 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
903 if (!PL_known_layers)
904 PL_known_layers = PerlIO_list_alloc(aTHX);
905 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
906 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
910 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
914 const char *s = names;
916 while (isSPACE(*s) || *s == ':')
921 const char *as = NULL;
923 if (!isIDFIRST(*s)) {
925 * Message is consistent with how attribute lists are
926 * passed. Even though this means "foo : : bar" is
927 * seen as an invalid separator character.
929 const char q = ((*s == '\'') ? '"' : '\'');
930 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
931 "Invalid separator character %c%c%c in PerlIO layer specification %s",
933 SETERRNO(EINVAL, LIB_INVARG);
938 } while (isWORDCHAR(*e));
954 * It's a nul terminated string, not allowed
955 * to \ the terminating null. Anything other
956 * character is passed over.
966 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
967 "Argument list not closed for PerlIO layer \"%.*s\"",
979 PerlIO_funcs * const layer =
980 PerlIO_find_layer(aTHX_ s, llen, 1);
984 arg = newSVpvn(as, alen);
985 PerlIO_list_push(aTHX_ av, layer,
986 (arg) ? arg : &PL_sv_undef);
990 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
1003 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
1006 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
1007 #ifdef PERLIO_USING_CRLF
1010 if (PerlIO_stdio.Set_ptrcnt)
1011 tab = &PerlIO_stdio;
1013 PerlIO_debug("Pushing %s\n", tab->name);
1014 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
1019 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
1021 return av->array[n].arg;
1025 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1027 if (n >= 0 && n < av->cur) {
1028 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1029 av->array[n].funcs->name);
1030 return av->array[n].funcs;
1033 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1038 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1040 PERL_UNUSED_ARG(mode);
1041 PERL_UNUSED_ARG(arg);
1042 PERL_UNUSED_ARG(tab);
1043 if (PerlIOValid(f)) {
1045 PerlIO_pop(aTHX_ f);
1051 PERLIO_FUNCS_DECL(PerlIO_remove) = {
1052 sizeof(PerlIO_funcs),
1055 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1075 NULL, /* get_base */
1076 NULL, /* get_bufsiz */
1079 NULL, /* set_ptrcnt */
1083 PerlIO_default_layers(pTHX)
1086 if (!PL_def_layerlist) {
1087 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1088 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1089 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1090 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1092 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1094 osLayer = &PerlIO_win32;
1097 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1098 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1099 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1100 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1101 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1102 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1103 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1104 PerlIO_list_push(aTHX_ PL_def_layerlist,
1105 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1108 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1111 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1114 if (PL_def_layerlist->cur < 2) {
1115 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1117 return PL_def_layerlist;
1121 Perl_boot_core_PerlIO(pTHX)
1123 #ifdef USE_ATTRIBUTES_FOR_PERLIO
1124 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1127 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1128 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1132 PerlIO_default_layer(pTHX_ I32 n)
1135 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1138 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1141 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1142 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1145 PerlIO_stdstreams(pTHX)
1149 PerlIO_init_table(aTHX);
1150 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1151 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1152 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1157 PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1160 if (tab->fsize != sizeof(PerlIO_funcs)) {
1162 "%s (%"UVuf") does not match %s (%"UVuf")",
1163 "PerlIO layer function table size", (UV)tab->fsize,
1164 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1168 if (tab->size < sizeof(PerlIOl)) {
1170 "%s (%"UVuf") smaller than %s (%"UVuf")",
1171 "PerlIO layer instance size", (UV)tab->size,
1172 "size expected by this perl", (UV)sizeof(PerlIOl) );
1174 /* Real layer with a data area */
1177 Newxz(temp, tab->size, char);
1181 l->tab = (PerlIO_funcs*) tab;
1182 l->head = ((PerlIOl*)f)->head;
1184 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1185 (void*)f, tab->name,
1186 (mode) ? mode : "(Null)", (void*)arg);
1187 if (*l->tab->Pushed &&
1189 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1190 PerlIO_pop(aTHX_ f);
1199 /* Pseudo-layer where push does its own stack adjust */
1200 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1201 (mode) ? mode : "(Null)", (void*)arg);
1203 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1211 PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1212 IV n, const char *mode, int fd, int imode, int perm,
1213 PerlIO *old, int narg, SV **args)
1215 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1216 if (tab && tab->Open) {
1217 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1218 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1224 SETERRNO(EINVAL, LIB_INVARG);
1229 PerlIOBase_binmode(pTHX_ PerlIO *f)
1231 if (PerlIOValid(f)) {
1232 /* Is layer suitable for raw stream ? */
1233 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1234 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1235 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1238 /* Not suitable - pop it */
1239 PerlIO_pop(aTHX_ f);
1247 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1249 PERL_UNUSED_ARG(mode);
1250 PERL_UNUSED_ARG(arg);
1251 PERL_UNUSED_ARG(tab);
1253 if (PerlIOValid(f)) {
1258 * Strip all layers that are not suitable for a raw stream
1261 while (t && (l = *t)) {
1262 if (l->tab && l->tab->Binmode) {
1263 /* Has a handler - normal case */
1264 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1266 /* Layer still there - move down a layer */
1275 /* No handler - pop it */
1276 PerlIO_pop(aTHX_ t);
1279 if (PerlIOValid(f)) {
1280 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1281 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
1289 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1290 PerlIO_list_t *layers, IV n, IV max)
1294 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1296 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1307 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1311 save_scalar(PL_errgv);
1313 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1314 code = PerlIO_parse_layers(aTHX_ layers, names);
1316 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1318 PerlIO_list_free(aTHX_ layers);
1325 /*--------------------------------------------------------------------------------------*/
1327 * Given the abstraction above the public API functions
1331 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1333 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1334 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1335 PerlIOBase(f)->tab->name : "(Null)",
1336 iotype, mode, (names) ? names : "(Null)");
1339 /* Do not flush etc. if (e.g.) switching encodings.
1340 if a pushed layer knows it needs to flush lower layers
1341 (for example :unix which is never going to call them)
1342 it can do the flush when it is pushed.
1344 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1347 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1348 #ifdef PERLIO_USING_CRLF
1349 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1350 O_BINARY so we can look for it in mode.
1352 if (!(mode & O_BINARY)) {
1354 /* FIXME?: Looking down the layer stack seems wrong,
1355 but is a way of reaching past (say) an encoding layer
1356 to flip CRLF-ness of the layer(s) below
1359 /* Perhaps we should turn on bottom-most aware layer
1360 e.g. Ilya's idea that UNIX TTY could serve
1362 if (PerlIOBase(f)->tab &&
1363 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1365 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1366 /* Not in text mode - flush any pending stuff and flip it */
1368 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1370 /* Only need to turn it on in one layer so we are done */
1375 /* Not finding a CRLF aware layer presumably means we are binary
1376 which is not what was requested - so we failed
1377 We _could_ push :crlf layer but so could caller
1382 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1383 So code that used to be here is now in PerlIORaw_pushed().
1385 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
1390 PerlIO__close(pTHX_ PerlIO *f)
1392 if (PerlIOValid(f)) {
1393 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1394 if (tab && tab->Close)
1395 return (*tab->Close)(aTHX_ f);
1397 return PerlIOBase_close(aTHX_ f);
1400 SETERRNO(EBADF, SS_IVCHAN);
1406 Perl_PerlIO_close(pTHX_ PerlIO *f)
1408 const int code = PerlIO__close(aTHX_ f);
1409 while (PerlIOValid(f)) {
1410 PerlIO_pop(aTHX_ f);
1411 if (PerlIO_lockcnt(f))
1412 /* we're in use; the 'pop' deferred freeing the structure */
1419 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1422 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1426 static PerlIO_funcs *
1427 PerlIO_layer_from_ref(pTHX_ SV *sv)
1431 * For any scalar type load the handler which is bundled with perl
1433 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1434 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1435 /* This isn't supposed to happen, since PerlIO::scalar is core,
1436 * but could happen anyway in smaller installs or with PAR */
1438 /* diag_listed_as: Unknown PerlIO layer "%s" */
1439 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1444 * For other types allow if layer is known but don't try and load it
1446 switch (SvTYPE(sv)) {
1448 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1450 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1452 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1454 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1461 PerlIO_resolve_layers(pTHX_ const char *layers,
1462 const char *mode, int narg, SV **args)
1465 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1468 PerlIO_stdstreams(aTHX);
1470 SV * const arg = *args;
1472 * If it is a reference but not an object see if we have a handler
1475 if (SvROK(arg) && !sv_isobject(arg)) {
1476 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1478 def = PerlIO_list_alloc(aTHX);
1479 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1483 * Don't fail if handler cannot be found :via(...) etc. may do
1484 * something sensible else we will just stringfy and open
1489 if (!layers || !*layers)
1490 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1491 if (layers && *layers) {
1494 av = PerlIO_clone_list(aTHX_ def, NULL);
1499 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1503 PerlIO_list_free(aTHX_ av);
1515 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1516 int imode, int perm, PerlIO *f, int narg, SV **args)
1519 if (!f && narg == 1 && *args == &PL_sv_undef) {
1520 if ((f = PerlIO_tmpfile())) {
1521 if (!layers || !*layers)
1522 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1523 if (layers && *layers)
1524 PerlIO_apply_layers(aTHX_ f, mode, layers);
1528 PerlIO_list_t *layera;
1530 PerlIO_funcs *tab = NULL;
1531 if (PerlIOValid(f)) {
1533 * This is "reopen" - it is not tested as perl does not use it
1537 layera = PerlIO_list_alloc(aTHX);
1540 if (l->tab && l->tab->Getarg)
1541 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1542 PerlIO_list_push(aTHX_ layera, l->tab,
1543 (arg) ? arg : &PL_sv_undef);
1545 l = *PerlIONext(&l);
1549 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1555 * Start at "top" of layer stack
1557 n = layera->cur - 1;
1559 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1568 * Found that layer 'n' can do opens - call it
1570 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1571 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1573 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1574 tab->name, layers ? layers : "(Null)", mode, fd,
1575 imode, perm, (void*)f, narg, (void*)args);
1577 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1580 SETERRNO(EINVAL, LIB_INVARG);
1584 if (n + 1 < layera->cur) {
1586 * More layers above the one that we used to open -
1589 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1590 /* If pushing layers fails close the file */
1597 PerlIO_list_free(aTHX_ layera);
1604 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1606 PERL_ARGS_ASSERT_PERLIO_READ;
1608 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1612 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1614 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1616 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1620 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1622 PERL_ARGS_ASSERT_PERLIO_WRITE;
1624 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1628 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1630 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1634 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1636 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1640 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1645 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1647 if (tab && tab->Flush)
1648 return (*tab->Flush) (aTHX_ f);
1650 return 0; /* If no Flush defined, silently succeed. */
1653 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1654 SETERRNO(EBADF, SS_IVCHAN);
1660 * Is it good API design to do flush-all on NULL, a potentially
1661 * erroneous input? Maybe some magical value (PerlIO*
1662 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1663 * things on fflush(NULL), but should we be bound by their design
1666 PerlIOl **table = &PL_perlio;
1669 while ((ff = *table)) {
1671 table = (PerlIOl **) (ff++);
1672 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1673 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1683 PerlIOBase_flush_linebuf(pTHX)
1686 PerlIOl **table = &PL_perlio;
1688 while ((f = *table)) {
1690 table = (PerlIOl **) (f++);
1691 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1693 && (PerlIOBase(&(f->next))->
1694 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1695 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1696 PerlIO_flush(&(f->next));
1703 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1705 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1709 PerlIO_isutf8(PerlIO *f)
1712 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1714 SETERRNO(EBADF, SS_IVCHAN);
1720 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1722 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1726 Perl_PerlIO_error(pTHX_ PerlIO *f)
1728 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1732 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1734 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1738 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1740 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1744 PerlIO_has_base(PerlIO *f)
1746 if (PerlIOValid(f)) {
1747 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1750 return (tab->Get_base != NULL);
1757 PerlIO_fast_gets(PerlIO *f)
1759 if (PerlIOValid(f)) {
1760 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1761 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1764 return (tab->Set_ptrcnt != NULL);
1772 PerlIO_has_cntptr(PerlIO *f)
1774 if (PerlIOValid(f)) {
1775 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1778 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1785 PerlIO_canset_cnt(PerlIO *f)
1787 if (PerlIOValid(f)) {
1788 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1791 return (tab->Set_ptrcnt != NULL);
1798 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1800 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1804 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1806 /* Note that Get_bufsiz returns a Size_t */
1807 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1811 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1813 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1817 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1819 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1823 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1825 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1829 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1831 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1835 /*--------------------------------------------------------------------------------------*/
1837 * utf8 and raw dummy layers
1841 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1843 PERL_UNUSED_CONTEXT;
1844 PERL_UNUSED_ARG(mode);
1845 PERL_UNUSED_ARG(arg);
1846 if (PerlIOValid(f)) {
1847 if (tab && tab->kind & PERLIO_K_UTF8)
1848 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1850 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1856 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1857 sizeof(PerlIO_funcs),
1860 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1880 NULL, /* get_base */
1881 NULL, /* get_bufsiz */
1884 NULL, /* set_ptrcnt */
1887 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1888 sizeof(PerlIO_funcs),
1891 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1911 NULL, /* get_base */
1912 NULL, /* get_bufsiz */
1915 NULL, /* set_ptrcnt */
1918 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1919 sizeof(PerlIO_funcs),
1942 NULL, /* get_base */
1943 NULL, /* get_bufsiz */
1946 NULL, /* set_ptrcnt */
1948 /*--------------------------------------------------------------------------------------*/
1949 /*--------------------------------------------------------------------------------------*/
1951 * "Methods" of the "base class"
1955 PerlIOBase_fileno(pTHX_ PerlIO *f)
1957 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1961 PerlIO_modestr(PerlIO * f, char *buf)
1964 if (PerlIOValid(f)) {
1965 const IV flags = PerlIOBase(f)->flags;
1966 if (flags & PERLIO_F_APPEND) {
1968 if (flags & PERLIO_F_CANREAD) {
1972 else if (flags & PERLIO_F_CANREAD) {
1974 if (flags & PERLIO_F_CANWRITE)
1977 else if (flags & PERLIO_F_CANWRITE) {
1979 if (flags & PERLIO_F_CANREAD) {
1983 #ifdef PERLIO_USING_CRLF
1984 if (!(flags & PERLIO_F_CRLF))
1994 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1996 PerlIOl * const l = PerlIOBase(f);
1997 PERL_UNUSED_CONTEXT;
1998 PERL_UNUSED_ARG(arg);
2000 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2001 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2002 if (tab && tab->Set_ptrcnt != NULL)
2003 l->flags |= PERLIO_F_FASTGETS;
2005 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
2009 l->flags |= PERLIO_F_CANREAD;
2012 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2015 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2018 SETERRNO(EINVAL, LIB_INVARG);
2024 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2027 l->flags &= ~PERLIO_F_CRLF;
2030 l->flags |= PERLIO_F_CRLF;
2033 SETERRNO(EINVAL, LIB_INVARG);
2040 l->flags |= l->next->flags &
2041 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2046 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2047 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2048 l->flags, PerlIO_modestr(f, temp));
2054 PerlIOBase_popped(pTHX_ PerlIO *f)
2056 PERL_UNUSED_CONTEXT;
2062 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2065 * Save the position as current head considers it
2067 const Off_t old = PerlIO_tell(f);
2068 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2069 PerlIOSelf(f, PerlIOBuf)->posn = old;
2070 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2074 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2076 STDCHAR *buf = (STDCHAR *) vbuf;
2078 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2079 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2080 SETERRNO(EBADF, SS_IVCHAN);
2086 SSize_t avail = PerlIO_get_cnt(f);
2089 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2091 STDCHAR *ptr = PerlIO_get_ptr(f);
2092 Copy(ptr, buf, take, STDCHAR);
2093 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2096 if (avail == 0) /* set_ptrcnt could have reset avail */
2099 if (count > 0 && avail <= 0) {
2100 if (PerlIO_fill(f) != 0)
2105 return (buf - (STDCHAR *) vbuf);
2111 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2113 PERL_UNUSED_CONTEXT;
2119 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2121 PERL_UNUSED_CONTEXT;
2127 PerlIOBase_close(pTHX_ PerlIO *f)
2130 if (PerlIOValid(f)) {
2131 PerlIO *n = PerlIONext(f);
2132 code = PerlIO_flush(f);
2133 PerlIOBase(f)->flags &=
2134 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2135 while (PerlIOValid(n)) {
2136 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2137 if (tab && tab->Close) {
2138 if ((*tab->Close)(aTHX_ n) != 0)
2143 PerlIOBase(n)->flags &=
2144 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2150 SETERRNO(EBADF, SS_IVCHAN);
2156 PerlIOBase_eof(pTHX_ PerlIO *f)
2158 PERL_UNUSED_CONTEXT;
2159 if (PerlIOValid(f)) {
2160 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2166 PerlIOBase_error(pTHX_ PerlIO *f)
2168 PERL_UNUSED_CONTEXT;
2169 if (PerlIOValid(f)) {
2170 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2176 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2178 if (PerlIOValid(f)) {
2179 PerlIO * const n = PerlIONext(f);
2180 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2187 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2189 PERL_UNUSED_CONTEXT;
2190 if (PerlIOValid(f)) {
2191 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2196 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2202 arg = sv_dup(arg, param);
2203 SvREFCNT_inc_simple_void_NN(arg);
2207 return newSVsv(arg);
2210 PERL_UNUSED_ARG(param);
2211 return newSVsv(arg);
2216 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2218 PerlIO * const nexto = PerlIONext(o);
2219 if (PerlIOValid(nexto)) {
2220 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2221 if (tab && tab->Dup)
2222 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2224 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2227 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2231 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2232 self ? self->name : "(Null)",
2233 (void*)f, (void*)o, (void*)param);
2234 if (self && self->Getarg)
2235 arg = (*self->Getarg)(aTHX_ o, param, flags);
2236 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2237 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2238 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2244 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2246 /* Must be called with PL_perlio_mutex locked. */
2248 S_more_refcounted_fds(pTHX_ const int new_fd) {
2250 const int old_max = PL_perlio_fd_refcnt_size;
2251 const int new_max = 16 + (new_fd & ~15);
2254 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2255 old_max, new_fd, new_max);
2257 if (new_fd < old_max) {
2261 assert (new_max > new_fd);
2263 /* Use plain realloc() since we need this memory to be really
2264 * global and visible to all the interpreters and/or threads. */
2265 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2269 MUTEX_UNLOCK(&PL_perlio_mutex);
2274 PL_perlio_fd_refcnt_size = new_max;
2275 PL_perlio_fd_refcnt = new_array;
2277 PerlIO_debug("Zeroing %p, %d\n",
2278 (void*)(new_array + old_max),
2281 Zero(new_array + old_max, new_max - old_max, int);
2288 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2289 PERL_UNUSED_CONTEXT;
2293 PerlIOUnix_refcnt_inc(int fd)
2300 MUTEX_LOCK(&PL_perlio_mutex);
2302 if (fd >= PL_perlio_fd_refcnt_size)
2303 S_more_refcounted_fds(aTHX_ fd);
2305 PL_perlio_fd_refcnt[fd]++;
2306 if (PL_perlio_fd_refcnt[fd] <= 0) {
2307 /* diag_listed_as: refcnt_inc: fd %d%s */
2308 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2309 fd, PL_perlio_fd_refcnt[fd]);
2311 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2312 fd, PL_perlio_fd_refcnt[fd]);
2315 MUTEX_UNLOCK(&PL_perlio_mutex);
2318 /* diag_listed_as: refcnt_inc: fd %d%s */
2319 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2324 PerlIOUnix_refcnt_dec(int fd)
2330 MUTEX_LOCK(&PL_perlio_mutex);
2332 if (fd >= PL_perlio_fd_refcnt_size) {
2333 /* diag_listed_as: refcnt_dec: fd %d%s */
2334 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2335 fd, PL_perlio_fd_refcnt_size);
2337 if (PL_perlio_fd_refcnt[fd] <= 0) {
2338 /* diag_listed_as: refcnt_dec: fd %d%s */
2339 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2340 fd, PL_perlio_fd_refcnt[fd]);
2342 cnt = --PL_perlio_fd_refcnt[fd];
2343 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2345 MUTEX_UNLOCK(&PL_perlio_mutex);
2348 /* diag_listed_as: refcnt_dec: fd %d%s */
2349 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2355 PerlIOUnix_refcnt(int fd)
2362 MUTEX_LOCK(&PL_perlio_mutex);
2364 if (fd >= PL_perlio_fd_refcnt_size) {
2365 /* diag_listed_as: refcnt: fd %d%s */
2366 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2367 fd, PL_perlio_fd_refcnt_size);
2369 if (PL_perlio_fd_refcnt[fd] <= 0) {
2370 /* diag_listed_as: refcnt: fd %d%s */
2371 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2372 fd, PL_perlio_fd_refcnt[fd]);
2374 cnt = PL_perlio_fd_refcnt[fd];
2376 MUTEX_UNLOCK(&PL_perlio_mutex);
2379 /* diag_listed_as: refcnt: fd %d%s */
2380 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2386 PerlIO_cleanup(pTHX)
2391 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
2393 PerlIO_debug("Cleanup layers\n");
2396 /* Raise STDIN..STDERR refcount so we don't close them */
2397 for (i=0; i < 3; i++)
2398 PerlIOUnix_refcnt_inc(i);
2399 PerlIO_cleantable(aTHX_ &PL_perlio);
2400 /* Restore STDIN..STDERR refcount */
2401 for (i=0; i < 3; i++)
2402 PerlIOUnix_refcnt_dec(i);
2404 if (PL_known_layers) {
2405 PerlIO_list_free(aTHX_ PL_known_layers);
2406 PL_known_layers = NULL;
2408 if (PL_def_layerlist) {
2409 PerlIO_list_free(aTHX_ PL_def_layerlist);
2410 PL_def_layerlist = NULL;
2414 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2418 /* XXX we can't rely on an interpreter being present at this late stage,
2419 XXX so we can't use a function like PerlLIO_write that relies on one
2420 being present (at least in win32) :-(.
2425 /* By now all filehandles should have been closed, so any
2426 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2428 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2429 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2430 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2432 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2433 if (PL_perlio_fd_refcnt[i]) {
2435 my_snprintf(buf, sizeof(buf),
2436 "PerlIO_teardown: fd %d refcnt=%d\n",
2437 i, PL_perlio_fd_refcnt[i]);
2438 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2444 /* Not bothering with PL_perlio_mutex since by now
2445 * all the interpreters are gone. */
2446 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2447 && PL_perlio_fd_refcnt) {
2448 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2449 PL_perlio_fd_refcnt = NULL;
2450 PL_perlio_fd_refcnt_size = 0;
2454 /*--------------------------------------------------------------------------------------*/
2456 * Bottom-most level for UNIX-like case
2460 struct _PerlIO base; /* The generic part */
2461 int fd; /* UNIX like file descriptor */
2462 int oflags; /* open/fcntl flags */
2466 S_lockcnt_dec(pTHX_ const void* f)
2468 PerlIO_lockcnt((PerlIO*)f)--;
2472 /* call the signal handler, and if that handler happens to clear
2473 * this handle, free what we can and return true */
2476 S_perlio_async_run(pTHX_ PerlIO* f) {
2478 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2479 PerlIO_lockcnt(f)++;
2481 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2485 /* we've just run some perl-level code that could have done
2486 * anything, including closing the file or clearing this layer.
2487 * If so, free any lower layers that have already been
2488 * cleared, then return an error. */
2489 while (PerlIOValid(f) &&
2490 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2492 const PerlIOl *l = *f;
2501 PerlIOUnix_oflags(const char *mode)
2504 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2509 if (*++mode == '+') {
2516 oflags = O_CREAT | O_TRUNC;
2517 if (*++mode == '+') {
2526 oflags = O_CREAT | O_APPEND;
2527 if (*++mode == '+') {
2535 #ifdef PERLIO_BINARY_AND_TEXT_DIFFERENT_AND_EFFECTIVE
2541 else if (*mode == 't') {
2543 oflags &= ~O_BINARY;
2548 * If neither "t" nor "b" was specified, open the file
2554 if (*mode || oflags == -1) {
2555 SETERRNO(EINVAL, LIB_INVARG);
2562 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2564 PERL_UNUSED_CONTEXT;
2565 return PerlIOSelf(f, PerlIOUnix)->fd;
2569 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2571 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2574 if (PerlLIO_fstat(fd, &st) == 0) {
2575 if (!S_ISREG(st.st_mode)) {
2576 PerlIO_debug("%d is not regular file\n",fd);
2577 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2580 PerlIO_debug("%d _is_ a regular file\n",fd);
2586 PerlIOUnix_refcnt_inc(fd);
2587 PERL_UNUSED_CONTEXT;
2591 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2593 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2594 if (*PerlIONext(f)) {
2595 /* We never call down so do any pending stuff now */
2596 PerlIO_flush(PerlIONext(f));
2598 * XXX could (or should) we retrieve the oflags from the open file
2599 * handle rather than believing the "mode" we are passed in? XXX
2600 * Should the value on NULL mode be 0 or -1?
2602 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2603 mode ? PerlIOUnix_oflags(mode) : -1);
2605 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2611 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2613 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2615 PERL_UNUSED_CONTEXT;
2616 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2618 SETERRNO(ESPIPE, LIB_INVARG);
2620 SETERRNO(EINVAL, LIB_INVARG);
2624 new_loc = PerlLIO_lseek(fd, offset, whence);
2625 if (new_loc == (Off_t) - 1)
2627 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2632 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2633 IV n, const char *mode, int fd, int imode,
2634 int perm, PerlIO *f, int narg, SV **args)
2636 if (PerlIOValid(f)) {
2637 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2638 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2641 if (*mode == IoTYPE_NUMERIC)
2644 imode = PerlIOUnix_oflags(mode);
2646 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2653 const char *path = SvPV_const(*args, len);
2654 if (!IS_SAFE_PATHNAME(path, len, "open"))
2656 fd = PerlLIO_open3(path, imode, perm);
2660 if (*mode == IoTYPE_IMPLICIT)
2663 f = PerlIO_allocate(aTHX);
2665 if (!PerlIOValid(f)) {
2666 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2671 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2672 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2673 if (*mode == IoTYPE_APPEND)
2674 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2681 * FIXME: pop layers ???
2689 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2691 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2693 if (flags & PERLIO_DUP_FD) {
2694 fd = PerlLIO_dup(fd);
2697 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2699 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2700 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2710 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2714 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2716 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2717 #ifdef PERLIO_STD_SPECIAL
2719 return PERLIO_STD_IN(fd, vbuf, count);
2721 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2722 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2726 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2727 if (len >= 0 || errno != EINTR) {
2729 if (errno != EAGAIN) {
2730 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2733 else if (len == 0 && count != 0) {
2734 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2740 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2747 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2751 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2753 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2754 #ifdef PERLIO_STD_SPECIAL
2755 if (fd == 1 || fd == 2)
2756 return PERLIO_STD_OUT(fd, vbuf, count);
2759 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2760 if (len >= 0 || errno != EINTR) {
2762 if (errno != EAGAIN) {
2763 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2769 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2776 PerlIOUnix_tell(pTHX_ PerlIO *f)
2778 PERL_UNUSED_CONTEXT;
2780 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2785 PerlIOUnix_close(pTHX_ PerlIO *f)
2788 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2790 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2791 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2792 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2797 SETERRNO(EBADF,SS_IVCHAN);
2800 while (PerlLIO_close(fd) != 0) {
2801 if (errno != EINTR) {
2806 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2810 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2815 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2816 sizeof(PerlIO_funcs),
2823 PerlIOBase_binmode, /* binmode */
2833 PerlIOBase_noop_ok, /* flush */
2834 PerlIOBase_noop_fail, /* fill */
2837 PerlIOBase_clearerr,
2838 PerlIOBase_setlinebuf,
2839 NULL, /* get_base */
2840 NULL, /* get_bufsiz */
2843 NULL, /* set_ptrcnt */
2846 /*--------------------------------------------------------------------------------------*/
2851 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2852 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2853 broken by the last second glibc 2.3 fix
2855 #define STDIO_BUFFER_WRITABLE
2860 struct _PerlIO base;
2861 FILE *stdio; /* The stream */
2865 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2867 PERL_UNUSED_CONTEXT;
2869 if (PerlIOValid(f)) {
2870 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2872 return PerlSIO_fileno(s);
2879 PerlIOStdio_mode(const char *mode, char *tmode)
2881 char * const ret = tmode;
2887 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2895 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2898 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2899 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2900 if (toptab == tab) {
2901 /* Top is already stdio - pop self (duplicate) and use original */
2902 PerlIO_pop(aTHX_ f);
2905 const int fd = PerlIO_fileno(n);
2908 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2909 mode = PerlIOStdio_mode(mode, tmode)))) {
2910 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2911 /* We never call down so do any pending stuff now */
2912 PerlIO_flush(PerlIONext(f));
2913 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2920 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2925 PerlIO_importFILE(FILE *stdio, const char *mode)
2931 int fd0 = fileno(stdio);
2935 if (!mode || !*mode) {
2936 /* We need to probe to see how we can open the stream
2937 so start with read/write and then try write and read
2938 we dup() so that we can fclose without loosing the fd.
2940 Note that the errno value set by a failing fdopen
2941 varies between stdio implementations.
2943 const int fd = PerlLIO_dup(fd0);
2948 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2950 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2953 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2956 /* Don't seem to be able to open */
2962 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2963 s = PerlIOSelf(f, PerlIOStdio);
2965 PerlIOUnix_refcnt_inc(fileno(stdio));
2972 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2973 IV n, const char *mode, int fd, int imode,
2974 int perm, PerlIO *f, int narg, SV **args)
2977 if (PerlIOValid(f)) {
2979 const char * const path = SvPV_const(*args, len);
2980 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
2982 if (!IS_SAFE_PATHNAME(path, len, "open"))
2984 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2985 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
2990 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2996 const char * const path = SvPV_const(*args, len);
2997 if (!IS_SAFE_PATHNAME(path, len, "open"))
2999 if (*mode == IoTYPE_NUMERIC) {
3001 fd = PerlLIO_open3(path, imode, perm);
3005 bool appended = FALSE;
3007 /* Cygwin wants its 'b' early. */
3009 mode = PerlIOStdio_mode(mode, tmode);
3011 stdio = PerlSIO_fopen(path, mode);
3014 f = PerlIO_allocate(aTHX);
3017 mode = PerlIOStdio_mode(mode, tmode);
3018 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3020 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3021 PerlIOUnix_refcnt_inc(fileno(stdio));
3023 PerlSIO_fclose(stdio);
3035 if (*mode == IoTYPE_IMPLICIT) {
3042 stdio = PerlSIO_stdin;
3045 stdio = PerlSIO_stdout;
3048 stdio = PerlSIO_stderr;
3053 stdio = PerlSIO_fdopen(fd, mode =
3054 PerlIOStdio_mode(mode, tmode));
3058 f = PerlIO_allocate(aTHX);
3060 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3061 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3062 PerlIOUnix_refcnt_inc(fileno(stdio));
3073 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3075 /* This assumes no layers underneath - which is what
3076 happens, but is not how I remember it. NI-S 2001/10/16
3078 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3079 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3080 const int fd = fileno(stdio);
3082 if (flags & PERLIO_DUP_FD) {
3083 const int dfd = PerlLIO_dup(fileno(stdio));
3085 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3090 /* FIXME: To avoid messy error recovery if dup fails
3091 re-use the existing stdio as though flag was not set
3095 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3097 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3099 PerlIOUnix_refcnt_inc(fileno(stdio));
3106 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3108 PERL_UNUSED_CONTEXT;
3110 /* XXX this could use PerlIO_canset_fileno() and
3111 * PerlIO_set_fileno() support from Configure
3113 # if defined(__UCLIBC__)
3114 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3117 # elif defined(__GLIBC__)
3118 /* There may be a better way for GLIBC:
3119 - libio.h defines a flag to not close() on cleanup
3123 # elif defined(__sun)
3126 # elif defined(__hpux)
3130 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3131 your platform does not have special entry try this one.
3132 [For OSF only have confirmation for Tru64 (alpha)
3133 but assume other OSFs will be similar.]
3135 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3138 # elif defined(__FreeBSD__)
3139 /* There may be a better way on FreeBSD:
3140 - we could insert a dummy func in the _close function entry
3141 f->_close = (int (*)(void *)) dummy_close;
3145 # elif defined(__OpenBSD__)
3146 /* There may be a better way on OpenBSD:
3147 - we could insert a dummy func in the _close function entry
3148 f->_close = (int (*)(void *)) dummy_close;
3152 # elif defined(__EMX__)
3153 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3156 # elif defined(__CYGWIN__)
3157 /* There may be a better way on CYGWIN:
3158 - we could insert a dummy func in the _close function entry
3159 f->_close = (int (*)(void *)) dummy_close;
3163 # elif defined(WIN32)
3164 # if defined(UNDER_CE)
3165 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3174 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3175 (which isn't thread safe) instead
3177 # error "Don't know how to set FILE.fileno on your platform"
3185 PerlIOStdio_close(pTHX_ PerlIO *f)
3187 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3193 const int fd = fileno(stdio);
3201 #ifdef SOCKS5_VERSION_NAME
3202 /* Socks lib overrides close() but stdio isn't linked to
3203 that library (though we are) - so we must call close()
3204 on sockets on stdio's behalf.
3207 Sock_size_t optlen = sizeof(int);
3208 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3211 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3212 that a subsequent fileno() on it returns -1. Don't want to croak()
3213 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3214 trying to close an already closed handle which somehow it still has
3215 a reference to. (via.xs, I'm looking at you). */
3216 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3217 /* File descriptor still in use */
3221 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3222 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3224 if (stdio == stdout || stdio == stderr)
3225 return PerlIO_flush(f);
3226 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3227 Use Sarathy's trick from maint-5.6 to invalidate the
3228 fileno slot of the FILE *
3230 result = PerlIO_flush(f);
3232 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3235 MUTEX_LOCK(&PL_perlio_mutex);
3236 /* Right. We need a mutex here because for a brief while we
3237 will have the situation that fd is actually closed. Hence if
3238 a second thread were to get into this block, its dup() would
3239 likely return our fd as its dupfd. (after all, it is closed)
3240 Then if we get to the dup2() first, we blat the fd back
3241 (messing up its temporary as a side effect) only for it to
3242 then close its dupfd (== our fd) in its close(dupfd) */
3244 /* There is, of course, a race condition, that any other thread
3245 trying to input/output/whatever on this fd will be stuffed
3246 for the duration of this little manoeuvrer. Perhaps we
3247 should hold an IO mutex for the duration of every IO
3248 operation if we know that invalidate doesn't work on this
3249 platform, but that would suck, and could kill performance.
3251 Except that correctness trumps speed.
3252 Advice from klortho #11912. */
3254 dupfd = PerlLIO_dup(fd);
3257 MUTEX_UNLOCK(&PL_perlio_mutex);
3258 /* Oh cXap. This isn't going to go well. Not sure if we can
3259 recover from here, or if closing this particular FILE *
3260 is a good idea now. */
3265 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3267 result = PerlSIO_fclose(stdio);
3268 /* We treat error from stdio as success if we invalidated
3269 errno may NOT be expected EBADF
3271 if (invalidate && result != 0) {
3275 #ifdef SOCKS5_VERSION_NAME
3276 /* in SOCKS' case, let close() determine return value */
3280 PerlLIO_dup2(dupfd,fd);
3281 PerlLIO_close(dupfd);
3283 MUTEX_UNLOCK(&PL_perlio_mutex);
3291 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3296 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3298 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3301 STDCHAR *buf = (STDCHAR *) vbuf;
3303 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3304 * stdio does not do that for fread()
3306 const int ch = PerlSIO_fgetc(s);
3313 got = PerlSIO_fread(vbuf, 1, count, s);
3314 if (got == 0 && PerlSIO_ferror(s))
3316 if (got >= 0 || errno != EINTR)
3318 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3320 SETERRNO(0,0); /* just in case */
3326 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3329 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3331 #ifdef STDIO_BUFFER_WRITABLE
3332 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3333 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3334 STDCHAR *base = PerlIO_get_base(f);
3335 SSize_t cnt = PerlIO_get_cnt(f);
3336 STDCHAR *ptr = PerlIO_get_ptr(f);
3337 SSize_t avail = ptr - base;
3339 if (avail > count) {
3343 Move(buf-avail,ptr,avail,STDCHAR);
3346 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3347 if (PerlSIO_feof(s) && unread >= 0)
3348 PerlSIO_clearerr(s);
3353 if (PerlIO_has_cntptr(f)) {
3354 /* We can get pointer to buffer but not its base
3355 Do ungetc() but check chars are ending up in the
3358 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3359 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3361 const int ch = *--buf & 0xFF;
3362 if (ungetc(ch,s) != ch) {
3363 /* ungetc did not work */
3366 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3367 /* Did not change pointer as expected */
3368 if (fgetc(s) != EOF) /* get char back again */
3378 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3384 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3388 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3391 got = PerlSIO_fwrite(vbuf, 1, count,
3392 PerlIOSelf(f, PerlIOStdio)->stdio);
3393 if (got >= 0 || errno != EINTR)
3395 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3397 SETERRNO(0,0); /* just in case */
3403 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3405 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3406 PERL_UNUSED_CONTEXT;
3408 return PerlSIO_fseek(stdio, offset, whence);
3412 PerlIOStdio_tell(pTHX_ PerlIO *f)
3414 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3415 PERL_UNUSED_CONTEXT;
3417 return PerlSIO_ftell(stdio);
3421 PerlIOStdio_flush(pTHX_ PerlIO *f)
3423 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3424 PERL_UNUSED_CONTEXT;
3426 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3427 return PerlSIO_fflush(stdio);
3433 * FIXME: This discards ungetc() and pre-read stuff which is not
3434 * right if this is just a "sync" from a layer above Suspect right
3435 * design is to do _this_ but not have layer above flush this
3436 * layer read-to-read
3439 * Not writeable - sync by attempting a seek
3442 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3450 PerlIOStdio_eof(pTHX_ PerlIO *f)
3452 PERL_UNUSED_CONTEXT;
3454 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3458 PerlIOStdio_error(pTHX_ PerlIO *f)
3460 PERL_UNUSED_CONTEXT;
3462 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3466 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3468 PERL_UNUSED_CONTEXT;
3470 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3474 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3476 PERL_UNUSED_CONTEXT;
3478 #ifdef HAS_SETLINEBUF
3479 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3481 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3487 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3489 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3490 return (STDCHAR*)PerlSIO_get_base(stdio);
3494 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3496 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3497 return PerlSIO_get_bufsiz(stdio);
3501 #ifdef USE_STDIO_PTR
3503 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3505 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3506 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3510 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3512 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3513 return PerlSIO_get_cnt(stdio);
3517 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3519 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3521 #ifdef STDIO_PTR_LVALUE
3522 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3523 #ifdef STDIO_PTR_LVAL_SETS_CNT
3524 assert(PerlSIO_get_cnt(stdio) == (cnt));
3526 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3528 * Setting ptr _does_ change cnt - we are done
3532 #else /* STDIO_PTR_LVALUE */
3534 #endif /* STDIO_PTR_LVALUE */
3537 * Now (or only) set cnt
3539 #ifdef STDIO_CNT_LVALUE
3540 PerlSIO_set_cnt(stdio, cnt);
3541 #else /* STDIO_CNT_LVALUE */
3542 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3543 PerlSIO_set_ptr(stdio,
3544 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3546 #else /* STDIO_PTR_LVAL_SETS_CNT */
3548 #endif /* STDIO_PTR_LVAL_SETS_CNT */
3549 #endif /* STDIO_CNT_LVALUE */
3556 PerlIOStdio_fill(pTHX_ PerlIO *f)
3560 PERL_UNUSED_CONTEXT;
3561 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3563 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3566 * fflush()ing read-only streams can cause trouble on some stdio-s
3568 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3569 if (PerlSIO_fflush(stdio) != 0)
3573 c = PerlSIO_fgetc(stdio);
3576 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3578 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3583 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3585 #ifdef STDIO_BUFFER_WRITABLE
3586 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3587 /* Fake ungetc() to the real buffer in case system's ungetc
3590 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3591 SSize_t cnt = PerlSIO_get_cnt(stdio);
3592 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3593 if (ptr == base+1) {
3594 *--ptr = (STDCHAR) c;
3595 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3596 if (PerlSIO_feof(stdio))
3597 PerlSIO_clearerr(stdio);
3603 if (PerlIO_has_cntptr(f)) {
3605 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3612 /* An ungetc()d char is handled separately from the regular
3613 * buffer, so we stuff it in the buffer ourselves.
3614 * Should never get called as should hit code above
3616 *(--((*stdio)->_ptr)) = (unsigned char) c;
3619 /* If buffer snoop scheme above fails fall back to
3622 if (PerlSIO_ungetc(c, stdio) != c)
3630 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3631 sizeof(PerlIO_funcs),
3633 sizeof(PerlIOStdio),
3634 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3638 PerlIOBase_binmode, /* binmode */
3652 PerlIOStdio_clearerr,
3653 PerlIOStdio_setlinebuf,
3655 PerlIOStdio_get_base,
3656 PerlIOStdio_get_bufsiz,
3661 #ifdef USE_STDIO_PTR
3662 PerlIOStdio_get_ptr,
3663 PerlIOStdio_get_cnt,
3664 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3665 PerlIOStdio_set_ptrcnt,
3668 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3673 #endif /* USE_STDIO_PTR */
3676 /* Note that calls to PerlIO_exportFILE() are reversed using
3677 * PerlIO_releaseFILE(), not importFILE. */
3679 PerlIO_exportFILE(PerlIO * f, const char *mode)
3683 if (PerlIOValid(f)) {
3685 int fd = PerlIO_fileno(f);
3690 if (!mode || !*mode) {
3691 mode = PerlIO_modestr(f, buf);
3693 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3697 /* De-link any lower layers so new :stdio sticks */
3699 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3700 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3702 PerlIOUnix_refcnt_inc(fileno(stdio));
3703 /* Link previous lower layers under new one */
3707 /* restore layers list */
3717 PerlIO_findFILE(PerlIO *f)
3722 if (l->tab == &PerlIO_stdio) {
3723 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3726 l = *PerlIONext(&l);
3728 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3729 /* However, we're not really exporting a FILE * to someone else (who
3730 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3731 So we need to undo its reference count increase on the underlying file
3732 descriptor. We have to do this, because if the loop above returns you
3733 the FILE *, then *it* didn't increase any reference count. So there's
3734 only one way to be consistent. */
3735 stdio = PerlIO_exportFILE(f, NULL);
3737 const int fd = fileno(stdio);
3739 PerlIOUnix_refcnt_dec(fd);
3744 /* Use this to reverse PerlIO_exportFILE calls. */
3746 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3751 if (l->tab == &PerlIO_stdio) {
3752 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3753 if (s->stdio == f) { /* not in a loop */
3754 const int fd = fileno(f);
3756 PerlIOUnix_refcnt_dec(fd);
3759 PerlIO_pop(aTHX_ p);
3769 /*--------------------------------------------------------------------------------------*/
3771 * perlio buffer layer
3775 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3777 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3778 const int fd = PerlIO_fileno(f);
3779 if (fd >= 0 && PerlLIO_isatty(fd)) {
3780 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3782 if (*PerlIONext(f)) {
3783 const Off_t posn = PerlIO_tell(PerlIONext(f));
3784 if (posn != (Off_t) - 1) {
3788 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3792 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3793 IV n, const char *mode, int fd, int imode, int perm,
3794 PerlIO *f, int narg, SV **args)
3796 if (PerlIOValid(f)) {
3797 PerlIO *next = PerlIONext(f);
3799 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3800 if (tab && tab->Open)
3802 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3804 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3809 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3811 if (*mode == IoTYPE_IMPLICIT) {
3817 if (tab && tab->Open)
3818 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3821 SETERRNO(EINVAL, LIB_INVARG);
3823 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3825 * if push fails during open, open fails. close will pop us.
3830 fd = PerlIO_fileno(f);
3831 if (init && fd == 2) {
3833 * Initial stderr is unbuffered
3835 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3837 #ifdef PERLIO_USING_CRLF
3838 # ifdef PERLIO_IS_BINMODE_FD
3839 if (PERLIO_IS_BINMODE_FD(fd))
3840 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3844 * do something about failing setmode()? --jhi
3846 PerlLIO_setmode(fd, O_BINARY);
3849 /* Enable line buffering with record-oriented regular files
3850 * so we don't introduce an extraneous record boundary when
3851 * the buffer fills up.
3853 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3855 if (PerlLIO_fstat(fd, &st) == 0
3856 && S_ISREG(st.st_mode)
3857 && (st.st_fab_rfm == FAB$C_VAR
3858 || st.st_fab_rfm == FAB$C_VFC)) {
3859 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3870 * This "flush" is akin to sfio's sync in that it handles files in either
3871 * read or write state. For write state, we put the postponed data through
3872 * the next layers. For read state, we seek() the next layers to the
3873 * offset given by current position in the buffer, and discard the buffer
3874 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3875 * in any case?). Then the pass the stick further in chain.
3878 PerlIOBuf_flush(pTHX_ PerlIO *f)
3880 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3882 PerlIO *n = PerlIONext(f);
3883 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3885 * write() the buffer
3887 const STDCHAR *buf = b->buf;
3888 const STDCHAR *p = buf;
3889 while (p < b->ptr) {
3890 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3894 else if (count < 0 || PerlIO_error(n)) {
3895 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3900 b->posn += (p - buf);
3902 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3903 STDCHAR *buf = PerlIO_get_base(f);
3905 * Note position change
3907 b->posn += (b->ptr - buf);
3908 if (b->ptr < b->end) {
3909 /* We did not consume all of it - try and seek downstream to
3910 our logical position
3912 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3913 /* Reload n as some layers may pop themselves on seek */
3914 b->posn = PerlIO_tell(n = PerlIONext(f));
3917 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3918 data is lost for good - so return saying "ok" having undone
3921 b->posn -= (b->ptr - buf);
3926 b->ptr = b->end = b->buf;
3927 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3928 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3929 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3934 /* This discards the content of the buffer after b->ptr, and rereads
3935 * the buffer from the position off in the layer downstream; here off
3936 * is at offset corresponding to b->ptr - b->buf.
3939 PerlIOBuf_fill(pTHX_ PerlIO *f)
3941 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3942 PerlIO *n = PerlIONext(f);
3945 * Down-stream flush is defined not to loose read data so is harmless.
3946 * we would not normally be fill'ing if there was data left in anycase.
3948 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
3950 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3951 PerlIOBase_flush_linebuf(aTHX);
3954 PerlIO_get_base(f); /* allocate via vtable */
3956 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3958 b->ptr = b->end = b->buf;
3960 if (!PerlIOValid(n)) {
3961 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3965 if (PerlIO_fast_gets(n)) {
3967 * Layer below is also buffered. We do _NOT_ want to call its
3968 * ->Read() because that will loop till it gets what we asked for
3969 * which may hang on a pipe etc. Instead take anything it has to
3970 * hand, or ask it to fill _once_.
3972 avail = PerlIO_get_cnt(n);
3974 avail = PerlIO_fill(n);
3976 avail = PerlIO_get_cnt(n);
3978 if (!PerlIO_error(n) && PerlIO_eof(n))
3983 STDCHAR *ptr = PerlIO_get_ptr(n);
3984 const SSize_t cnt = avail;
3985 if (avail > (SSize_t)b->bufsiz)
3987 Copy(ptr, b->buf, avail, STDCHAR);
3988 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3992 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3996 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3998 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4001 b->end = b->buf + avail;
4002 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4007 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4009 if (PerlIOValid(f)) {
4010 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4013 return PerlIOBase_read(aTHX_ f, vbuf, count);
4019 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4021 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4022 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4025 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4030 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4032 * Buffer is already a read buffer, we can overwrite any chars
4033 * which have been read back to buffer start
4035 avail = (b->ptr - b->buf);
4039 * Buffer is idle, set it up so whole buffer is available for
4043 b->end = b->buf + avail;
4045 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4047 * Buffer extends _back_ from where we are now
4049 b->posn -= b->bufsiz;
4051 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4053 * If we have space for more than count, just move count
4061 * In simple stdio-like ungetc() case chars will be already
4064 if (buf != b->ptr) {
4065 Copy(buf, b->ptr, avail, STDCHAR);
4069 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4073 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4079 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4081 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4082 const STDCHAR *buf = (const STDCHAR *) vbuf;
4083 const STDCHAR *flushptr = buf;
4087 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4089 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4090 if (PerlIO_flush(f) != 0) {
4094 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4095 flushptr = buf + count;
4096 while (flushptr > buf && *(flushptr - 1) != '\n')
4100 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4101 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4103 if (flushptr > buf && flushptr <= buf + avail)
4104 avail = flushptr - buf;
4105 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4107 Copy(buf, b->ptr, avail, STDCHAR);
4112 if (buf == flushptr)
4115 if (b->ptr >= (b->buf + b->bufsiz))
4116 if (PerlIO_flush(f) == -1)
4119 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4125 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4128 if ((code = PerlIO_flush(f)) == 0) {
4129 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4130 code = PerlIO_seek(PerlIONext(f), offset, whence);
4132 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4133 b->posn = PerlIO_tell(PerlIONext(f));
4140 PerlIOBuf_tell(pTHX_ PerlIO *f)
4142 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4144 * b->posn is file position where b->buf was read, or will be written
4146 Off_t posn = b->posn;
4147 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4148 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4150 /* As O_APPEND files are normally shared in some sense it is better
4155 /* when file is NOT shared then this is sufficient */
4156 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4158 posn = b->posn = PerlIO_tell(PerlIONext(f));
4162 * If buffer is valid adjust position by amount in buffer
4164 posn += (b->ptr - b->buf);
4170 PerlIOBuf_popped(pTHX_ PerlIO *f)
4172 const IV code = PerlIOBase_popped(aTHX_ f);
4173 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4174 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4177 b->ptr = b->end = b->buf = NULL;
4178 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4183 PerlIOBuf_close(pTHX_ PerlIO *f)
4185 const IV code = PerlIOBase_close(aTHX_ f);
4186 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4187 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4190 b->ptr = b->end = b->buf = NULL;
4191 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4196 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4198 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4205 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4207 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4210 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4211 return (b->end - b->ptr);
4216 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4218 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4219 PERL_UNUSED_CONTEXT;
4223 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4224 Newxz(b->buf,b->bufsiz, STDCHAR);
4226 b->buf = (STDCHAR *) & b->oneword;
4227 b->bufsiz = sizeof(b->oneword);
4229 b->end = b->ptr = b->buf;
4235 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4237 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4240 return (b->end - b->buf);
4244 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4246 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4248 PERL_UNUSED_ARG(cnt);
4253 assert(PerlIO_get_cnt(f) == cnt);
4254 assert(b->ptr >= b->buf);
4255 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4259 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4261 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4266 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4267 sizeof(PerlIO_funcs),
4270 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4274 PerlIOBase_binmode, /* binmode */
4288 PerlIOBase_clearerr,
4289 PerlIOBase_setlinebuf,
4294 PerlIOBuf_set_ptrcnt,
4297 /*--------------------------------------------------------------------------------------*/
4299 * Temp layer to hold unread chars when cannot do it any other way
4303 PerlIOPending_fill(pTHX_ PerlIO *f)
4306 * Should never happen
4313 PerlIOPending_close(pTHX_ PerlIO *f)
4316 * A tad tricky - flush pops us, then we close new top
4319 return PerlIO_close(f);
4323 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4326 * A tad tricky - flush pops us, then we seek new top
4329 return PerlIO_seek(f, offset, whence);
4334 PerlIOPending_flush(pTHX_ PerlIO *f)
4336 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4337 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4341 PerlIO_pop(aTHX_ f);
4346 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4352 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4357 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4359 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4360 PerlIOl * const l = PerlIOBase(f);
4362 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4363 * etc. get muddled when it changes mid-string when we auto-pop.
4365 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4366 (PerlIOBase(PerlIONext(f))->
4367 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4372 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4374 SSize_t avail = PerlIO_get_cnt(f);
4376 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4379 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4380 if (got >= 0 && got < (SSize_t)count) {
4381 const SSize_t more =
4382 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4383 if (more >= 0 || got == 0)
4389 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4390 sizeof(PerlIO_funcs),
4393 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4394 PerlIOPending_pushed,
4397 PerlIOBase_binmode, /* binmode */
4406 PerlIOPending_close,
4407 PerlIOPending_flush,
4411 PerlIOBase_clearerr,
4412 PerlIOBase_setlinebuf,
4417 PerlIOPending_set_ptrcnt,
4422 /*--------------------------------------------------------------------------------------*/
4424 * crlf - translation On read translate CR,LF to "\n" we do this by
4425 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4426 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4428 * c->nl points on the first byte of CR LF pair when it is temporarily
4429 * replaced by LF, or to the last CR of the buffer. In the former case
4430 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4431 * that it ends at c->nl; these two cases can be distinguished by
4432 * *c->nl. c->nl is set during _getcnt() call, and unset during
4433 * _unread() and _flush() calls.
4434 * It only matters for read operations.
4438 PerlIOBuf base; /* PerlIOBuf stuff */
4439 STDCHAR *nl; /* Position of crlf we "lied" about in the
4443 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4444 * Otherwise the :crlf layer would always revert back to
4448 S_inherit_utf8_flag(PerlIO *f)
4450 PerlIO *g = PerlIONext(f);
4451 if (PerlIOValid(g)) {
4452 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4453 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4459 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4462 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4463 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4465 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4466 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4467 PerlIOBase(f)->flags);
4470 /* If the old top layer is a CRLF layer, reactivate it (if
4471 * necessary) and remove this new layer from the stack */
4472 PerlIO *g = PerlIONext(f);
4473 if (PerlIOValid(g)) {
4474 PerlIOl *b = PerlIOBase(g);
4475 if (b && b->tab == &PerlIO_crlf) {
4476 if (!(b->flags & PERLIO_F_CRLF))
4477 b->flags |= PERLIO_F_CRLF;
4478 S_inherit_utf8_flag(g);
4479 PerlIO_pop(aTHX_ f);
4484 S_inherit_utf8_flag(f);
4490 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4492 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4493 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4494 *(c->nl) = NATIVE_0xd;
4497 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4498 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4500 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4501 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4503 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4508 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4509 b->end = b->ptr = b->buf + b->bufsiz;
4510 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4511 b->posn -= b->bufsiz;
4513 while (count > 0 && b->ptr > b->buf) {
4514 const int ch = *--buf;
4516 if (b->ptr - 2 >= b->buf) {
4517 *--(b->ptr) = NATIVE_0xa;
4518 *--(b->ptr) = NATIVE_0xd;
4523 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4524 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4538 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4543 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4545 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4547 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4550 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4551 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4552 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4553 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4555 while (nl < b->end && *nl != NATIVE_0xd)
4557 if (nl < b->end && *nl == NATIVE_0xd) {
4559 if (nl + 1 < b->end) {
4560 if (nl[1] == NATIVE_0xa) {
4566 * Not CR,LF but just CR
4574 * Blast - found CR as last char in buffer
4579 * They may not care, defer work as long as
4583 return (nl - b->ptr);
4587 b->ptr++; /* say we have read it as far as
4588 * flush() is concerned */
4589 b->buf++; /* Leave space in front of buffer */
4590 /* Note as we have moved buf up flush's
4592 will naturally make posn point at CR
4594 b->bufsiz--; /* Buffer is thus smaller */
4595 code = PerlIO_fill(f); /* Fetch some more */
4596 b->bufsiz++; /* Restore size for next time */
4597 b->buf--; /* Point at space */
4598 b->ptr = nl = b->buf; /* Which is what we hand
4600 *nl = NATIVE_0xd; /* Fill in the CR */
4602 goto test; /* fill() call worked */
4604 * CR at EOF - just fall through
4606 /* Should we clear EOF though ??? */
4611 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4617 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4619 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4620 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4626 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4627 /* Deferred CR at end of buffer case - we lied about count */
4640 * Test code - delete when it works ...
4642 IV flags = PerlIOBase(f)->flags;
4643 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4644 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4645 /* Deferred CR at end of buffer case - we lied about count */
4651 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4652 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4653 flags, c->nl, b->end, cnt);
4660 * They have taken what we lied about
4662 *(c->nl) = NATIVE_0xd;
4668 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4672 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4674 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4675 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4677 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4678 const STDCHAR *buf = (const STDCHAR *) vbuf;
4679 const STDCHAR * const ebuf = buf + count;
4682 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4684 while (buf < ebuf) {
4685 const STDCHAR * const eptr = b->buf + b->bufsiz;
4686 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4687 while (buf < ebuf && b->ptr < eptr) {
4689 if ((b->ptr + 2) > eptr) {
4697 *(b->ptr)++ = NATIVE_0xd; /* CR */
4698 *(b->ptr)++ = NATIVE_0xa; /* LF */
4700 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4707 *(b->ptr)++ = *buf++;
4709 if (b->ptr >= eptr) {
4715 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4717 return (buf - (STDCHAR *) vbuf);
4722 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4724 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4726 *(c->nl) = NATIVE_0xd;
4729 return PerlIOBuf_flush(aTHX_ f);
4733 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4735 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4736 /* In text mode - flush any pending stuff and flip it */
4737 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4738 #ifndef PERLIO_USING_CRLF
4739 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4740 PerlIO_pop(aTHX_ f);
4746 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4747 sizeof(PerlIO_funcs),
4750 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4752 PerlIOBuf_popped, /* popped */
4754 PerlIOCrlf_binmode, /* binmode */
4758 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4759 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4760 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4768 PerlIOBase_clearerr,
4769 PerlIOBase_setlinebuf,
4774 PerlIOCrlf_set_ptrcnt,
4778 Perl_PerlIO_stdin(pTHX)
4782 PerlIO_stdstreams(aTHX);
4784 return (PerlIO*)&PL_perlio[1];
4788 Perl_PerlIO_stdout(pTHX)
4792 PerlIO_stdstreams(aTHX);
4794 return (PerlIO*)&PL_perlio[2];
4798 Perl_PerlIO_stderr(pTHX)
4802 PerlIO_stdstreams(aTHX);
4804 return (PerlIO*)&PL_perlio[3];
4807 /*--------------------------------------------------------------------------------------*/
4810 PerlIO_getname(PerlIO *f, char *buf)
4815 bool exported = FALSE;
4816 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4818 stdio = PerlIO_exportFILE(f,0);
4822 name = fgetname(stdio, buf);
4823 if (exported) PerlIO_releaseFILE(f,stdio);
4828 PERL_UNUSED_ARG(buf);
4829 Perl_croak_nocontext("Don't know how to get file name");
4835 /*--------------------------------------------------------------------------------------*/
4837 * Functions which can be called on any kind of PerlIO implemented in
4841 #undef PerlIO_fdopen
4843 PerlIO_fdopen(int fd, const char *mode)
4846 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4851 PerlIO_open(const char *path, const char *mode)
4854 SV *name = sv_2mortal(newSVpv(path, 0));
4855 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4858 #undef Perlio_reopen
4860 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4863 SV *name = sv_2mortal(newSVpv(path,0));
4864 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4869 PerlIO_getc(PerlIO *f)
4873 if ( 1 == PerlIO_read(f, buf, 1) ) {
4874 return (unsigned char) buf[0];
4879 #undef PerlIO_ungetc
4881 PerlIO_ungetc(PerlIO *f, int ch)
4886 if (PerlIO_unread(f, &buf, 1) == 1)
4894 PerlIO_putc(PerlIO *f, int ch)
4898 return PerlIO_write(f, &buf, 1);
4903 PerlIO_puts(PerlIO *f, const char *s)
4906 return PerlIO_write(f, s, strlen(s));
4909 #undef PerlIO_rewind
4911 PerlIO_rewind(PerlIO *f)
4914 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4918 #undef PerlIO_vprintf
4920 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4929 Perl_va_copy(ap, apc);
4930 sv = vnewSVpvf(fmt, &apc);
4933 sv = vnewSVpvf(fmt, &ap);
4935 s = SvPV_const(sv, len);
4936 wrote = PerlIO_write(f, s, len);
4941 #undef PerlIO_printf
4943 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4948 result = PerlIO_vprintf(f, fmt, ap);
4953 #undef PerlIO_stdoutf
4955 PerlIO_stdoutf(const char *fmt, ...)
4961 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4966 #undef PerlIO_tmpfile
4968 PerlIO_tmpfile(void)
4975 const int fd = win32_tmpfd();
4977 f = PerlIO_fdopen(fd, "w+b");
4979 # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
4981 char tempname[] = "/tmp/PerlIO_XXXXXX";
4982 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
4984 int old_umask = umask(0600);
4986 * I have no idea how portable mkstemp() is ... NI-S
4988 if (tmpdir && *tmpdir) {
4989 /* if TMPDIR is set and not empty, we try that first */
4990 sv = newSVpv(tmpdir, 0);
4991 sv_catpv(sv, tempname + 4);
4992 fd = mkstemp(SvPVX(sv));
4997 /* else we try /tmp */
4998 fd = mkstemp(tempname);
5003 sv_catpv(sv, tempname + 4);
5004 fd = mkstemp(SvPVX(sv));
5008 f = PerlIO_fdopen(fd, "w+");
5010 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5011 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5014 # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5015 FILE * const stdio = PerlSIO_tmpfile();
5018 f = PerlIO_fdopen(fileno(stdio), "w+");
5020 # endif /* else HAS_MKSTEMP */
5021 #endif /* else WIN32 */
5028 #endif /* PERLIO_IS_STDIO */
5030 /*======================================================================================*/
5032 * Now some functions in terms of above which may be needed even if we are
5033 * not in true PerlIO mode
5036 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5039 const char *direction = NULL;
5042 * Need to supply default layer info from open.pm
5048 if (mode && mode[0] != 'r') {
5049 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5050 direction = "open>";
5052 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5053 direction = "open<";
5058 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5061 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5066 #undef PerlIO_setpos
5068 PerlIO_setpos(PerlIO *f, SV *pos)
5073 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5074 if (f && len == sizeof(Off_t))
5075 return PerlIO_seek(f, *posn, SEEK_SET);
5077 SETERRNO(EINVAL, SS_IVCHAN);
5081 #undef PerlIO_setpos
5083 PerlIO_setpos(PerlIO *f, SV *pos)
5088 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5089 if (f && len == sizeof(Fpos_t)) {
5090 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5091 return fsetpos64(f, fpos);
5093 return fsetpos(f, fpos);
5097 SETERRNO(EINVAL, SS_IVCHAN);
5103 #undef PerlIO_getpos
5105 PerlIO_getpos(PerlIO *f, SV *pos)
5108 Off_t posn = PerlIO_tell(f);
5109 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5110 return (posn == (Off_t) - 1) ? -1 : 0;
5113 #undef PerlIO_getpos
5115 PerlIO_getpos(PerlIO *f, SV *pos)
5120 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5121 code = fgetpos64(f, &fpos);
5123 code = fgetpos(f, &fpos);
5125 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5130 #if !defined(HAS_VPRINTF)
5133 vprintf(char *pat, char *args)
5135 _doprnt(pat, args, stdout);
5136 return 0; /* wrong, but perl doesn't use the return
5141 vfprintf(FILE *fd, char *pat, char *args)
5143 _doprnt(pat, args, fd);
5144 return 0; /* wrong, but perl doesn't use the return
5152 * c-indentation-style: bsd
5154 * indent-tabs-mode: nil
5157 * ex: set ts=8 sts=4 sw=4 et: