2 * perlio.c Copyright (c) 1996-2002, Nick Ing-Simmons You may distribute
3 * under the terms of either the GNU General Public License or the
4 * Artistic License, as specified in the README file.
8 * Hour after hour for nearly three weary days he had jogged up and down,
9 * over passes, and through long dales, and across many streams.
13 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
14 * at the dispatch tables, even when we do not need it for other reasons.
15 * Invent a dSYS macro to abstract this out
17 #ifdef PERL_IMPLICIT_SYS
30 #define PERLIO_NOT_STDIO 0
31 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
37 * This file provides those parts of PerlIO abstraction
38 * which are not #defined in perlio.h.
39 * Which these are depends on various Configure #ifdef's
43 #define PERL_IN_PERLIO_C
46 #ifdef PERL_IMPLICIT_CONTEXT
54 perlsio_binmode(FILE *fp, int iotype, int mode)
57 * This used to be contents of do_binmode in doio.c
60 # if defined(atarist) || defined(__MINT__)
63 ((FILE *) fp)->_flag |= _IOBIN;
65 ((FILE *) fp)->_flag &= ~_IOBIN;
72 if (PerlLIO_setmode(fp, mode) != -1) {
74 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
76 # if defined(WIN32) && defined(__BORLANDC__)
78 * The translation mode of the stream is maintained independent of
79 * the translation mode of the fd in the Borland RTL (heavy
80 * digging through their runtime sources reveal). User has to set
81 * the mode explicitly for the stream (though they don't document
82 * this anywhere). GSAR 97-5-24
96 # if defined(USEMYBINMODE)
98 if (my_binmode(fp, iotype, mode) != FALSE)
109 #define O_ACCMODE 3 /* Assume traditional implementation */
113 PerlIO_intmode2str(int rawmode, char *mode, int *writing)
115 int result = rawmode & O_ACCMODE;
120 ptype = IoTYPE_RDONLY;
123 ptype = IoTYPE_WRONLY;
131 *writing = (result != O_RDONLY);
133 if (result == O_RDONLY) {
137 else if (rawmode & O_APPEND) {
139 if (result != O_WRONLY)
144 if (result == O_WRONLY)
151 if (rawmode & O_BINARY)
157 #ifndef PERLIO_LAYERS
159 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
161 if (!names || !*names || strEQ(names, ":crlf") || strEQ(names, ":raw")) {
164 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
172 PerlIO_destruct(pTHX)
177 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
182 return perlsio_binmode(fp, iotype, mode);
187 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
191 int fd = PerlLIO_dup(PerlIO_fileno(f));
194 int omode = fcntl(fd, F_GETFL);
196 omode = djgpp_get_stream_mode(f);
198 PerlIO_intmode2str(omode,mode,NULL);
199 /* the r+ is a hack */
200 return PerlIO_fdopen(fd, mode);
205 SETERRNO(EBADF, SS$_IVCHAN);
213 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
217 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
218 int imode, int perm, PerlIO *old, int narg, SV **args)
222 Perl_croak(aTHX_ "More than one argument to open");
224 if (*args == &PL_sv_undef)
225 return PerlIO_tmpfile();
227 char *name = SvPV_nolen(*args);
229 fd = PerlLIO_open3(name, imode, perm);
231 return PerlIO_fdopen(fd, (char *) mode + 1);
234 return PerlIO_reopen(name, mode, old);
237 return PerlIO_open(name, mode);
242 return PerlIO_fdopen(fd, (char *) mode);
247 XS(XS_PerlIO__Layer__find)
251 Perl_croak(aTHX_ "Usage class->find(name[,load])");
253 char *name = SvPV_nolen(ST(1));
254 ST(0) = (strEQ(name, "crlf")
255 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
262 Perl_boot_core_PerlIO(pTHX)
264 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
270 #ifdef PERLIO_IS_STDIO
276 * Does nothing (yet) except force this file to be included in perl
277 * binary. That allows this file to force inclusion of other functions
278 * that may be required by loadable extensions e.g. for
279 * FileHandle::tmpfile
283 #undef PerlIO_tmpfile
290 #else /* PERLIO_IS_STDIO */
298 * This section is just to make sure these functions get pulled in from
302 #undef PerlIO_tmpfile
313 * Force this file to be included in perl binary. Which allows this
314 * file to force inclusion of other functions that may be required by
315 * loadable extensions e.g. for FileHandle::tmpfile
319 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
320 * results in a lot of lseek()s to regular files and lot of small
323 sfset(sfstdout, SF_SHARE, 0);
327 PerlIO_importFILE(FILE *stdio, int fl)
329 int fd = fileno(stdio);
330 PerlIO *r = PerlIO_fdopen(fd, "r+");
335 PerlIO_findFILE(PerlIO *pio)
337 int fd = PerlIO_fileno(pio);
338 FILE *f = fdopen(fd, "r+");
340 if (!f && errno == EINVAL)
342 if (!f && errno == EINVAL)
349 /*======================================================================================*/
351 * Implement all the PerlIO interface ourselves.
357 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
364 #include <sys/mman.h>
368 void PerlIO_debug(const char *fmt, ...)
369 __attribute__ ((format(__printf__, 1, 2)));
372 PerlIO_debug(const char *fmt, ...)
379 char *s = PerlEnv_getenv("PERLIO_DEBUG");
381 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
388 /* Use fixed buffer as sv_catpvf etc. needs SVs */
392 s = CopFILE(PL_curcop);
395 sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
396 len = strlen(buffer);
397 vsprintf(buffer+len, fmt, ap);
398 PerlLIO_write(dbg, buffer, strlen(buffer));
400 SV *sv = newSVpvn("", 0);
403 s = CopFILE(PL_curcop);
406 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
407 (IV) CopLINE(PL_curcop));
408 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
411 PerlLIO_write(dbg, s, len);
418 /*--------------------------------------------------------------------------------------*/
421 * Inner level routines
425 * Table of pointers to the PerlIO structs (malloc'ed)
427 #define PERLIO_TABLE_SIZE 64
430 PerlIO_allocate(pTHX)
433 * Find a free slot in the table, allocating new table as necessary
438 while ((f = *last)) {
440 last = (PerlIO **) (f);
441 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
447 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
455 #undef PerlIO_fdupopen
457 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
459 if (PerlIOValid(f)) {
460 PerlIO_funcs *tab = PerlIOBase(f)->tab;
462 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
463 new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
467 SETERRNO(EBADF, SS$_IVCHAN);
473 PerlIO_cleantable(pTHX_ PerlIO **tablep)
475 PerlIO *table = *tablep;
478 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
479 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
480 PerlIO *f = table + i;
492 PerlIO_list_alloc(pTHX)
495 Newz('L', list, 1, PerlIO_list_t);
501 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
504 if (--list->refcnt == 0) {
507 for (i = 0; i < list->cur; i++) {
508 if (list->array[i].arg)
509 SvREFCNT_dec(list->array[i].arg);
511 Safefree(list->array);
519 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
522 if (list->cur >= list->len) {
525 Renew(list->array, list->len, PerlIO_pair_t);
527 New('l', list->array, list->len, PerlIO_pair_t);
529 p = &(list->array[list->cur++]);
531 if ((p->arg = arg)) {
537 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
539 PerlIO_list_t *list = (PerlIO_list_t *) NULL;
542 list = PerlIO_list_alloc(aTHX);
543 for (i=0; i < proto->cur; i++) {
545 if (proto->array[i].arg)
546 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
547 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
554 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
557 PerlIO **table = &proto->Iperlio;
560 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
561 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
562 PerlIO_allocate(aTHX); /* root slot is never used */
563 PerlIO_debug("Clone %p from %p\n",aTHX,proto);
564 while ((f = *table)) {
566 table = (PerlIO **) (f++);
567 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
569 (void) fp_dup(f, 0, param);
578 PerlIO_destruct(pTHX)
580 PerlIO **table = &PL_perlio;
583 PerlIO_debug("Destruct %p\n",aTHX);
585 while ((f = *table)) {
587 table = (PerlIO **) (f++);
588 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
592 if (l->tab->kind & PERLIO_K_DESTRUCT) {
593 PerlIO_debug("Destruct popping %s\n", l->tab->name);
607 PerlIO_pop(pTHX_ PerlIO *f)
611 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
612 if (l->tab->Popped) {
614 * If popped returns non-zero do not free its layer structure
615 * it has either done so itself, or it is shared and still in
618 if ((*l->tab->Popped) (aTHX_ f) != 0)
626 /*--------------------------------------------------------------------------------------*/
628 * XS Interface for perl code
632 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
635 if ((SSize_t) len <= 0)
637 for (i = 0; i < PL_known_layers->cur; i++) {
638 PerlIO_funcs *f = PL_known_layers->array[i].funcs;
639 if (memEQ(f->name, name, len)) {
640 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
644 if (load && PL_subname && PL_def_layerlist
645 && PL_def_layerlist->cur >= 2) {
646 SV *pkgsv = newSVpvn("PerlIO", 6);
647 SV *layer = newSVpvn(name, len);
650 * The two SVs are magically freed by load_module
652 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
654 return PerlIO_find_layer(aTHX_ name, len, 0);
656 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
660 #ifdef USE_ATTRIBUTES_FOR_PERLIO
663 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
666 IO *io = GvIOn((GV *) SvRV(sv));
667 PerlIO *ifp = IoIFP(io);
668 PerlIO *ofp = IoOFP(io);
669 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
675 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
678 IO *io = GvIOn((GV *) SvRV(sv));
679 PerlIO *ifp = IoIFP(io);
680 PerlIO *ofp = IoOFP(io);
681 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
687 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
689 Perl_warn(aTHX_ "clear %" SVf, sv);
694 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
696 Perl_warn(aTHX_ "free %" SVf, sv);
700 MGVTBL perlio_vtab = {
708 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
711 SV *sv = SvRV(ST(1));
716 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
718 mg = mg_find(sv, PERL_MAGIC_ext);
719 mg->mg_virtual = &perlio_vtab;
721 Perl_warn(aTHX_ "attrib %" SVf, sv);
722 for (i = 2; i < items; i++) {
724 const char *name = SvPV(ST(i), len);
725 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
727 av_push(av, SvREFCNT_inc(layer));
738 #endif /* USE_ATTIBUTES_FOR_PERLIO */
741 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
743 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
744 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
748 XS(XS_PerlIO__Layer__find)
752 Perl_croak(aTHX_ "Usage class->find(name[,load])");
755 char *name = SvPV(ST(1), len);
756 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
757 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
759 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
766 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
768 if (!PL_known_layers)
769 PL_known_layers = PerlIO_list_alloc(aTHX);
770 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
771 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
775 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
778 const char *s = names;
780 while (isSPACE(*s) || *s == ':')
785 const char *as = Nullch;
787 if (!isIDFIRST(*s)) {
789 * Message is consistent with how attribute lists are
790 * passed. Even though this means "foo : : bar" is
791 * seen as an invalid separator character.
793 char q = ((*s == '\'') ? '"' : '\'');
794 if (ckWARN(WARN_LAYER))
795 Perl_warner(aTHX_ packWARN(WARN_LAYER),
796 "perlio: invalid separator character %c%c%c in layer specification list %s",
802 } while (isALNUM(*e));
818 * It's a nul terminated string, not allowed
819 * to \ the terminating null. Anything other
820 * character is passed over.
830 if (ckWARN(WARN_LAYER))
831 Perl_warner(aTHX_ packWARN(WARN_LAYER),
832 "perlio: argument list not closed for layer \"%.*s\"",
844 bool warn_layer = ckWARN(WARN_LAYER);
845 PerlIO_funcs *layer =
846 PerlIO_find_layer(aTHX_ s, llen, 1);
848 PerlIO_list_push(aTHX_ av, layer,
855 Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"",
868 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
870 PerlIO_funcs *tab = &PerlIO_perlio;
871 #ifdef PERLIO_USING_CRLF
874 if (PerlIO_stdio.Set_ptrcnt)
877 PerlIO_debug("Pushing %s\n", tab->name);
878 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
883 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
885 return av->array[n].arg;
889 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
891 if (n >= 0 && n < av->cur) {
892 PerlIO_debug("Layer %" IVdf " is %s\n", n,
893 av->array[n].funcs->name);
894 return av->array[n].funcs;
897 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
902 PerlIO_default_layers(pTHX)
904 if (!PL_def_layerlist) {
905 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
906 PerlIO_funcs *osLayer = &PerlIO_unix;
907 PL_def_layerlist = PerlIO_list_alloc(aTHX);
908 PerlIO_define_layer(aTHX_ & PerlIO_unix);
909 #if defined(WIN32) && !defined(UNDER_CE)
910 PerlIO_define_layer(aTHX_ & PerlIO_win32);
912 osLayer = &PerlIO_win32;
915 PerlIO_define_layer(aTHX_ & PerlIO_raw);
916 PerlIO_define_layer(aTHX_ & PerlIO_perlio);
917 PerlIO_define_layer(aTHX_ & PerlIO_stdio);
918 PerlIO_define_layer(aTHX_ & PerlIO_crlf);
920 PerlIO_define_layer(aTHX_ & PerlIO_mmap);
922 PerlIO_define_layer(aTHX_ & PerlIO_utf8);
923 PerlIO_define_layer(aTHX_ & PerlIO_byte);
924 PerlIO_list_push(aTHX_ PL_def_layerlist,
925 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
928 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
931 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
934 if (PL_def_layerlist->cur < 2) {
935 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
937 return PL_def_layerlist;
941 Perl_boot_core_PerlIO(pTHX)
943 #ifdef USE_ATTRIBUTES_FOR_PERLIO
944 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
947 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
951 PerlIO_default_layer(pTHX_ I32 n)
953 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
956 return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
959 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
960 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
963 PerlIO_stdstreams(pTHX)
966 PerlIO_allocate(aTHX);
967 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
968 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
969 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
974 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
977 Newc('L',l,tab->size,char,PerlIOl);
979 Zero(l, tab->size, char);
983 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
984 (mode) ? mode : "(Null)", (void*)arg);
985 if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
994 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1006 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1009 * Remove the dummy layer
1011 PerlIO_pop(aTHX_ f);
1013 * Pop back to bottom layer
1015 if (PerlIOValid(f)) {
1017 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
1018 if (*PerlIONext(f)) {
1019 PerlIO_pop(aTHX_ f);
1023 * Nothing bellow - push unix on top then remove it
1025 if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
1026 PerlIO_pop(aTHX_ PerlIONext(f));
1031 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1038 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1039 PerlIO_list_t *layers, IV n, IV max)
1043 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1045 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1056 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1060 PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1061 code = PerlIO_parse_layers(aTHX_ layers, names);
1063 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1065 PerlIO_list_free(aTHX_ layers);
1071 /*--------------------------------------------------------------------------------------*/
1073 * Given the abstraction above the public API functions
1077 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1079 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1080 (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1081 (names) ? names : "(Null)");
1083 /* Do not flush etc. if (e.g.) switching encodings.
1084 if a pushed layer knows it needs to flush lower layers
1085 (for example :unix which is never going to call them)
1086 it can do the flush when it is pushed.
1088 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1091 /* FIXME?: Looking down the layer stack seems wrong,
1092 but is a way of reaching past (say) an encoding layer
1093 to flip CRLF-ness of the layer(s) below
1095 #ifdef PERLIO_USING_CRLF
1096 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1097 O_BINARY so we can look for it in mode.
1099 if (!(mode & O_BINARY)) {
1102 /* Perhaps we should turn on bottom-most aware layer
1103 e.g. Ilya's idea that UNIX TTY could serve
1105 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1106 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1107 /* Not in text mode - flush any pending stuff and flip it */
1109 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1111 /* Only need to turn it on in one layer so we are done */
1116 /* Not finding a CRLF aware layer presumably means we are binary
1117 which is not what was requested - so we failed
1118 We _could_ push :crlf layer but so could caller
1123 /* Either asked for BINMODE or that is normal on this platform
1124 see if any CRLF aware layers are present and turn off the flag
1125 and possibly remove layer.
1128 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1129 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1130 /* In text mode - flush any pending stuff and flip it */
1132 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
1133 #ifndef PERLIO_USING_CRLF
1134 /* CRLF is unusual case - if this is just the :crlf layer pop it */
1135 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
1136 PerlIO_pop(aTHX_ f);
1139 /* Normal case is only one layer doing this, so exit on first
1140 abnormal case can always do multiple binmode calls
1152 PerlIO__close(pTHX_ PerlIO *f)
1155 return (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1157 SETERRNO(EBADF, SS$_IVCHAN);
1163 Perl_PerlIO_close(pTHX_ PerlIO *f)
1166 if (PerlIOValid(f)) {
1167 code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1169 PerlIO_pop(aTHX_ f);
1176 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1179 return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
1181 SETERRNO(EBADF, SS$_IVCHAN);
1187 PerlIO_context_layers(pTHX_ const char *mode)
1189 const char *type = NULL;
1191 * Need to supply default layer info from open.pm
1194 SV *layers = PL_curcop->cop_io;
1197 type = SvPV(layers, len);
1198 if (type && mode[0] != 'r') {
1200 * Skip to write part
1202 const char *s = strchr(type, 0);
1203 if (s && (STRLEN)(s - type) < len) {
1212 static PerlIO_funcs *
1213 PerlIO_layer_from_ref(pTHX_ SV *sv)
1216 * For any scalar type load the handler which is bundled with perl
1218 if (SvTYPE(sv) < SVt_PVAV)
1219 return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1222 * For other types allow if layer is known but don't try and load it
1224 switch (SvTYPE(sv)) {
1226 return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1228 return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1230 return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1232 return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1238 PerlIO_resolve_layers(pTHX_ const char *layers,
1239 const char *mode, int narg, SV **args)
1241 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1244 PerlIO_stdstreams(aTHX);
1248 * If it is a reference but not an object see if we have a handler
1251 if (SvROK(arg) && !sv_isobject(arg)) {
1252 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1254 def = PerlIO_list_alloc(aTHX);
1255 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1259 * Don't fail if handler cannot be found :Via(...) etc. may do
1260 * something sensible else we will just stringfy and open
1266 layers = PerlIO_context_layers(aTHX_ mode);
1267 if (layers && *layers) {
1271 av = PerlIO_list_alloc(aTHX);
1272 for (i = 0; i < def->cur; i++) {
1273 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1280 PerlIO_parse_layers(aTHX_ av, layers);
1291 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1292 int imode, int perm, PerlIO *f, int narg, SV **args)
1294 if (!f && narg == 1 && *args == &PL_sv_undef) {
1295 if ((f = PerlIO_tmpfile())) {
1297 layers = PerlIO_context_layers(aTHX_ mode);
1298 if (layers && *layers)
1299 PerlIO_apply_layers(aTHX_ f, mode, layers);
1303 PerlIO_list_t *layera = NULL;
1305 PerlIO_funcs *tab = NULL;
1306 if (PerlIOValid(f)) {
1308 * This is "reopen" - it is not tested as perl does not use it
1312 layera = PerlIO_list_alloc(aTHX);
1314 SV *arg = (l->tab->Getarg)
1315 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1317 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1318 l = *PerlIONext(&l);
1322 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1325 * Start at "top" of layer stack
1327 n = layera->cur - 1;
1329 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1338 * Found that layer 'n' can do opens - call it
1340 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1341 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1343 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1344 tab->name, layers, mode, fd, imode, perm,
1345 (void*)f, narg, (void*)args);
1346 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1349 if (n + 1 < layera->cur) {
1351 * More layers above the one that we used to open -
1354 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1355 /* If pushing layers fails close the file */
1362 PerlIO_list_free(aTHX_ layera);
1369 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1372 return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
1374 SETERRNO(EBADF, SS$_IVCHAN);
1380 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1383 return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
1385 SETERRNO(EBADF, SS$_IVCHAN);
1391 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1394 return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
1396 SETERRNO(EBADF, SS$_IVCHAN);
1402 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1405 return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
1407 SETERRNO(EBADF, SS$_IVCHAN);
1413 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1416 return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
1418 SETERRNO(EBADF, SS$_IVCHAN);
1424 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1428 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1429 if (tab && tab->Flush) {
1430 return (*tab->Flush) (aTHX_ f);
1433 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
1434 SETERRNO(EBADF, SS$_IVCHAN);
1439 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1440 SETERRNO(EBADF, SS$_IVCHAN);
1446 * Is it good API design to do flush-all on NULL, a potentially
1447 * errorneous input? Maybe some magical value (PerlIO*
1448 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1449 * things on fflush(NULL), but should we be bound by their design
1452 PerlIO **table = &PL_perlio;
1454 while ((f = *table)) {
1456 table = (PerlIO **) (f++);
1457 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1458 if (*f && PerlIO_flush(f) != 0)
1468 PerlIOBase_flush_linebuf(pTHX)
1470 PerlIO **table = &PL_perlio;
1472 while ((f = *table)) {
1474 table = (PerlIO **) (f++);
1475 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1478 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1479 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1487 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1490 return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
1492 SETERRNO(EBADF, SS$_IVCHAN);
1498 PerlIO_isutf8(PerlIO *f)
1501 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1503 SETERRNO(EBADF, SS$_IVCHAN);
1509 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1512 return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
1514 SETERRNO(EBADF, SS$_IVCHAN);
1520 Perl_PerlIO_error(pTHX_ PerlIO *f)
1523 return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
1525 SETERRNO(EBADF, SS$_IVCHAN);
1531 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1534 (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
1536 SETERRNO(EBADF, SS$_IVCHAN);
1540 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1543 (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
1545 SETERRNO(EBADF, SS$_IVCHAN);
1549 PerlIO_has_base(PerlIO *f)
1551 if (PerlIOValid(f)) {
1552 return (PerlIOBase(f)->tab->Get_base != NULL);
1558 PerlIO_fast_gets(PerlIO *f)
1560 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1561 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1562 return (tab->Set_ptrcnt != NULL);
1568 PerlIO_has_cntptr(PerlIO *f)
1570 if (PerlIOValid(f)) {
1571 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1572 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1578 PerlIO_canset_cnt(PerlIO *f)
1580 if (PerlIOValid(f)) {
1581 PerlIOl *l = PerlIOBase(f);
1582 return (l->tab->Set_ptrcnt != NULL);
1588 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1591 return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
1596 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1599 return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
1604 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1606 if (PerlIOValid(f)) {
1607 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1608 if (tab->Get_ptr == NULL)
1610 return (*tab->Get_ptr) (aTHX_ f);
1616 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1618 if (PerlIOValid(f)) {
1619 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1620 if (tab->Get_cnt == NULL)
1622 return (*tab->Get_cnt) (aTHX_ f);
1628 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1630 if (PerlIOValid(f)) {
1631 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
1636 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1638 if (PerlIOValid(f)) {
1639 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1640 if (tab->Set_ptrcnt == NULL) {
1641 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1643 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
1647 /*--------------------------------------------------------------------------------------*/
1649 * utf8 and raw dummy layers
1653 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1655 if (*PerlIONext(f)) {
1656 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1657 PerlIO_pop(aTHX_ f);
1658 if (tab->kind & PERLIO_K_UTF8)
1659 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1661 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1667 PerlIO_funcs PerlIO_utf8 = {
1670 PERLIO_K_DUMMY | PERLIO_F_UTF8,
1688 NULL, /* get_base */
1689 NULL, /* get_bufsiz */
1692 NULL, /* set_ptrcnt */
1695 PerlIO_funcs PerlIO_byte = {
1716 NULL, /* get_base */
1717 NULL, /* get_bufsiz */
1720 NULL, /* set_ptrcnt */
1724 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1725 IV n, const char *mode, int fd, int imode, int perm,
1726 PerlIO *old, int narg, SV **args)
1728 PerlIO_funcs *tab = PerlIO_default_btm();
1729 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1733 PerlIO_funcs PerlIO_raw = {
1754 NULL, /* get_base */
1755 NULL, /* get_bufsiz */
1758 NULL, /* set_ptrcnt */
1760 /*--------------------------------------------------------------------------------------*/
1761 /*--------------------------------------------------------------------------------------*/
1763 * "Methods" of the "base class"
1767 PerlIOBase_fileno(pTHX_ PerlIO *f)
1769 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1773 PerlIO_modestr(PerlIO *f, char *buf)
1776 IV flags = PerlIOBase(f)->flags;
1777 if (flags & PERLIO_F_APPEND) {
1779 if (flags & PERLIO_F_CANREAD) {
1783 else if (flags & PERLIO_F_CANREAD) {
1785 if (flags & PERLIO_F_CANWRITE)
1788 else if (flags & PERLIO_F_CANWRITE) {
1790 if (flags & PERLIO_F_CANREAD) {
1794 #ifdef PERLIO_USING_CRLF
1795 if (!(flags & PERLIO_F_CRLF))
1803 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1805 PerlIOl *l = PerlIOBase(f);
1807 const char *omode = mode;
1810 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1811 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1812 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1813 if (tab->Set_ptrcnt != NULL)
1814 l->flags |= PERLIO_F_FASTGETS;
1816 if (*mode == '#' || *mode == 'I')
1820 l->flags |= PERLIO_F_CANREAD;
1823 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1826 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1829 SETERRNO(EINVAL, LIB$_INVARG);
1835 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1838 l->flags &= ~PERLIO_F_CRLF;
1841 l->flags |= PERLIO_F_CRLF;
1844 SETERRNO(EINVAL, LIB$_INVARG);
1851 l->flags |= l->next->flags &
1852 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1857 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1858 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1859 l->flags, PerlIO_modestr(f, temp));
1865 PerlIOBase_popped(pTHX_ PerlIO *f)
1871 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1874 * Save the position as current head considers it
1876 Off_t old = PerlIO_tell(f);
1878 PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1879 PerlIOSelf(f, PerlIOBuf)->posn = old;
1880 done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
1885 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1887 STDCHAR *buf = (STDCHAR *) vbuf;
1889 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1892 SSize_t avail = PerlIO_get_cnt(f);
1895 take = ((SSize_t)count < avail) ? count : avail;
1897 STDCHAR *ptr = PerlIO_get_ptr(f);
1898 Copy(ptr, buf, take, STDCHAR);
1899 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1903 if (count > 0 && avail <= 0) {
1904 if (PerlIO_fill(f) != 0)
1908 return (buf - (STDCHAR *) vbuf);
1914 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
1920 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
1926 PerlIOBase_close(pTHX_ PerlIO *f)
1929 PerlIO *n = PerlIONext(f);
1930 if (PerlIO_flush(f) != 0)
1932 if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0)
1934 PerlIOBase(f)->flags &=
1935 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1940 PerlIOBase_eof(pTHX_ PerlIO *f)
1942 if (PerlIOValid(f)) {
1943 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1949 PerlIOBase_error(pTHX_ PerlIO *f)
1951 if (PerlIOValid(f)) {
1952 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1958 PerlIOBase_clearerr(pTHX_ PerlIO *f)
1960 if (PerlIOValid(f)) {
1961 PerlIO *n = PerlIONext(f);
1962 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
1969 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
1971 if (PerlIOValid(f)) {
1972 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1977 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
1983 return sv_dup(arg, param);
1986 return newSVsv(arg);
1989 return newSVsv(arg);
1994 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1996 PerlIO *nexto = PerlIONext(o);
1997 if (PerlIOValid(nexto)) {
1998 PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
1999 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2002 PerlIO_funcs *self = PerlIOBase(o)->tab;
2005 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2006 self->name, (void*)f, (void*)o, (void*)param);
2008 arg = (*self->Getarg)(aTHX_ o,param,flags);
2010 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2018 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2020 perl_mutex PerlIO_mutex;
2022 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2027 /* Place holder for stdstreams call ??? */
2029 MUTEX_INIT(&PerlIO_mutex);
2034 PerlIOUnix_refcnt_inc(int fd)
2036 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2038 MUTEX_LOCK(&PerlIO_mutex);
2040 PerlIO_fd_refcnt[fd]++;
2041 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2043 MUTEX_UNLOCK(&PerlIO_mutex);
2049 PerlIOUnix_refcnt_dec(int fd)
2052 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2054 MUTEX_LOCK(&PerlIO_mutex);
2056 cnt = --PerlIO_fd_refcnt[fd];
2057 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2059 MUTEX_UNLOCK(&PerlIO_mutex);
2066 PerlIO_cleanup(pTHX)
2070 PerlIO_debug("Cleanup layers for %p\n",aTHX);
2072 PerlIO_debug("Cleanup layers\n");
2074 /* Raise STDIN..STDERR refcount so we don't close them */
2075 for (i=0; i < 3; i++)
2076 PerlIOUnix_refcnt_inc(i);
2077 PerlIO_cleantable(aTHX_ &PL_perlio);
2078 /* Restore STDIN..STDERR refcount */
2079 for (i=0; i < 3; i++)
2080 PerlIOUnix_refcnt_dec(i);
2082 if (PL_known_layers) {
2083 PerlIO_list_free(aTHX_ PL_known_layers);
2084 PL_known_layers = NULL;
2086 if(PL_def_layerlist) {
2087 PerlIO_list_free(aTHX_ PL_def_layerlist);
2088 PL_def_layerlist = NULL;
2094 /*--------------------------------------------------------------------------------------*/
2096 * Bottom-most level for UNIX-like case
2100 struct _PerlIO base; /* The generic part */
2101 int fd; /* UNIX like file descriptor */
2102 int oflags; /* open/fcntl flags */
2106 PerlIOUnix_oflags(const char *mode)
2109 if (*mode == 'I' || *mode == '#')
2114 if (*++mode == '+') {
2121 oflags = O_CREAT | O_TRUNC;
2122 if (*++mode == '+') {
2131 oflags = O_CREAT | O_APPEND;
2132 if (*++mode == '+') {
2145 else if (*mode == 't') {
2147 oflags &= ~O_BINARY;
2151 * Always open in binary mode
2154 if (*mode || oflags == -1) {
2155 SETERRNO(EINVAL, LIB$_INVARG);
2162 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2164 return PerlIOSelf(f, PerlIOUnix)->fd;
2168 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2170 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
2171 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2172 if (*PerlIONext(f)) {
2173 /* We never call down so any pending stuff now */
2174 PerlIO_flush(PerlIONext(f));
2175 s->fd = PerlIO_fileno(PerlIONext(f));
2177 * XXX could (or should) we retrieve the oflags from the open file
2178 * handle rather than believing the "mode" we are passed in? XXX
2179 * Should the value on NULL mode be 0 or -1?
2181 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2183 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2188 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2189 IV n, const char *mode, int fd, int imode,
2190 int perm, PerlIO *f, int narg, SV **args)
2192 if (PerlIOValid(f)) {
2193 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2194 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2197 char *path = SvPV_nolen(*args);
2201 imode = PerlIOUnix_oflags(mode);
2205 fd = PerlLIO_open3(path, imode, perm);
2213 f = PerlIO_allocate(aTHX);
2215 if (!PerlIOValid(f)) {
2216 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
2220 s = PerlIOSelf(f, PerlIOUnix);
2224 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2225 PerlIOUnix_refcnt_inc(fd);
2231 * FIXME: pop layers ???
2239 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2241 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2243 if (flags & PERLIO_DUP_FD) {
2244 fd = PerlLIO_dup(fd);
2246 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2247 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2249 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2250 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2252 PerlIOUnix_refcnt_inc(fd);
2261 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2263 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2264 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2267 SSize_t len = PerlLIO_read(fd, vbuf, count);
2268 if (len >= 0 || errno != EINTR) {
2270 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2271 else if (len == 0 && count != 0)
2272 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2280 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2282 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2284 SSize_t len = PerlLIO_write(fd, vbuf, count);
2285 if (len >= 0 || errno != EINTR) {
2287 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2295 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2298 PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2299 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2300 return (new == (Off_t) - 1) ? -1 : 0;
2304 PerlIOUnix_tell(pTHX_ PerlIO *f)
2306 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2311 PerlIOUnix_close(pTHX_ PerlIO *f)
2313 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2315 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2316 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2317 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2322 SETERRNO(EBADF,SS$_IVCHAN);
2325 while (PerlLIO_close(fd) != 0) {
2326 if (errno != EINTR) {
2333 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2338 PerlIO_funcs PerlIO_unix = {
2354 PerlIOBase_noop_ok, /* flush */
2355 PerlIOBase_noop_fail, /* fill */
2358 PerlIOBase_clearerr,
2359 PerlIOBase_setlinebuf,
2360 NULL, /* get_base */
2361 NULL, /* get_bufsiz */
2364 NULL, /* set_ptrcnt */
2367 /*--------------------------------------------------------------------------------------*/
2373 struct _PerlIO base;
2374 FILE *stdio; /* The stream */
2378 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2380 return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2384 PerlIOStdio_mode(const char *mode, char *tmode)
2390 #ifdef PERLIO_USING_CRLF
2398 * This isn't used yet ...
2401 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2403 if (*PerlIONext(f)) {
2404 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2407 PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2408 PerlIOStdio_mode(mode, tmode));
2411 /* We never call down so any pending stuff now */
2412 PerlIO_flush(PerlIONext(f));
2417 return PerlIOBase_pushed(aTHX_ f, mode, arg);
2421 PerlIO_importFILE(FILE *stdio, int fl)
2427 PerlIOSelf(PerlIO_push
2428 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2429 "r+", Nullsv), PerlIOStdio);
2436 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2437 IV n, const char *mode, int fd, int imode,
2438 int perm, PerlIO *f, int narg, SV **args)
2441 if (PerlIOValid(f)) {
2442 char *path = SvPV_nolen(*args);
2443 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2445 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2446 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2451 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2456 char *path = SvPV_nolen(*args);
2459 fd = PerlLIO_open3(path, imode, perm);
2462 FILE *stdio = PerlSIO_fopen(path, mode);
2466 f = PerlIO_allocate(aTHX);
2468 s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
2469 (mode = PerlIOStdio_mode(mode, tmode)),
2473 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2488 stdio = PerlSIO_stdin;
2491 stdio = PerlSIO_stdout;
2494 stdio = PerlSIO_stderr;
2499 stdio = PerlSIO_fdopen(fd, mode =
2500 PerlIOStdio_mode(mode, tmode));
2505 f = PerlIO_allocate(aTHX);
2507 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio);
2509 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2518 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2520 /* This assumes no layers underneath - which is what
2521 happens, but is not how I remember it. NI-S 2001/10/16
2523 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2524 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2525 if (flags & PERLIO_DUP_FD) {
2526 int fd = PerlLIO_dup(fileno(stdio));
2529 stdio = fdopen(fd, PerlIO_modestr(o,mode));
2532 /* FIXME: To avoid messy error recovery if dup fails
2533 re-use the existing stdio as though flag was not set
2537 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2538 PerlIOUnix_refcnt_inc(fileno(stdio));
2544 PerlIOStdio_close(pTHX_ PerlIO *f)
2546 #ifdef SOCKS5_VERSION_NAME
2548 Sock_size_t optlen = sizeof(int);
2550 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2551 if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2552 /* Do not close it but do flush any buffers */
2553 return PerlIO_flush(f);
2556 #ifdef SOCKS5_VERSION_NAME
2558 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2560 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2562 PerlSIO_fclose(stdio)
2571 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2573 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2576 STDCHAR *buf = (STDCHAR *) vbuf;
2578 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2579 * stdio does not do that for fread()
2581 int ch = PerlSIO_fgetc(s);
2588 got = PerlSIO_fread(vbuf, 1, count, s);
2593 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2595 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2596 STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2599 int ch = *buf-- & 0xff;
2600 if (PerlSIO_ungetc(ch, s) != ch)
2609 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2611 return PerlSIO_fwrite(vbuf, 1, count,
2612 PerlIOSelf(f, PerlIOStdio)->stdio);
2616 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2618 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2619 return PerlSIO_fseek(stdio, offset, whence);
2623 PerlIOStdio_tell(pTHX_ PerlIO *f)
2625 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2626 return PerlSIO_ftell(stdio);
2630 PerlIOStdio_flush(pTHX_ PerlIO *f)
2632 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2633 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2634 return PerlSIO_fflush(stdio);
2639 * FIXME: This discards ungetc() and pre-read stuff which is not
2640 * right if this is just a "sync" from a layer above Suspect right
2641 * design is to do _this_ but not have layer above flush this
2642 * layer read-to-read
2645 * Not writeable - sync by attempting a seek
2648 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2656 PerlIOStdio_fill(pTHX_ PerlIO *f)
2658 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2661 * fflush()ing read-only streams can cause trouble on some stdio-s
2663 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2664 if (PerlSIO_fflush(stdio) != 0)
2667 c = PerlSIO_fgetc(stdio);
2668 if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2674 PerlIOStdio_eof(pTHX_ PerlIO *f)
2676 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2680 PerlIOStdio_error(pTHX_ PerlIO *f)
2682 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2686 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2688 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2692 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2694 #ifdef HAS_SETLINEBUF
2695 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2697 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2703 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2705 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2706 return (STDCHAR*)PerlSIO_get_base(stdio);
2710 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2712 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2713 return PerlSIO_get_bufsiz(stdio);
2717 #ifdef USE_STDIO_PTR
2719 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2721 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2722 return (STDCHAR*)PerlSIO_get_ptr(stdio);
2726 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2728 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2729 return PerlSIO_get_cnt(stdio);
2733 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2735 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2737 #ifdef STDIO_PTR_LVALUE
2738 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2739 #ifdef STDIO_PTR_LVAL_SETS_CNT
2740 if (PerlSIO_get_cnt(stdio) != (cnt)) {
2741 assert(PerlSIO_get_cnt(stdio) == (cnt));
2744 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2746 * Setting ptr _does_ change cnt - we are done
2750 #else /* STDIO_PTR_LVALUE */
2752 #endif /* STDIO_PTR_LVALUE */
2755 * Now (or only) set cnt
2757 #ifdef STDIO_CNT_LVALUE
2758 PerlSIO_set_cnt(stdio, cnt);
2759 #else /* STDIO_CNT_LVALUE */
2760 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2761 PerlSIO_set_ptr(stdio,
2762 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2764 #else /* STDIO_PTR_LVAL_SETS_CNT */
2766 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2767 #endif /* STDIO_CNT_LVALUE */
2772 PerlIO_funcs PerlIO_stdio = {
2774 sizeof(PerlIOStdio),
2792 PerlIOStdio_clearerr,
2793 PerlIOStdio_setlinebuf,
2795 PerlIOStdio_get_base,
2796 PerlIOStdio_get_bufsiz,
2801 #ifdef USE_STDIO_PTR
2802 PerlIOStdio_get_ptr,
2803 PerlIOStdio_get_cnt,
2804 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2805 PerlIOStdio_set_ptrcnt
2806 #else /* STDIO_PTR_LVALUE */
2808 #endif /* STDIO_PTR_LVALUE */
2809 #else /* USE_STDIO_PTR */
2813 #endif /* USE_STDIO_PTR */
2817 PerlIO_exportFILE(PerlIO *f, int fl)
2822 stdio = fdopen(PerlIO_fileno(f), "r+");
2825 PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2833 PerlIO_findFILE(PerlIO *f)
2837 if (l->tab == &PerlIO_stdio) {
2838 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2841 l = *PerlIONext(&l);
2843 return PerlIO_exportFILE(f, 0);
2847 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2851 /*--------------------------------------------------------------------------------------*/
2853 * perlio buffer layer
2857 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2859 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2860 int fd = PerlIO_fileno(f);
2862 if (fd >= 0 && PerlLIO_isatty(fd)) {
2863 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2865 posn = PerlIO_tell(PerlIONext(f));
2866 if (posn != (Off_t) - 1) {
2869 return PerlIOBase_pushed(aTHX_ f, mode, arg);
2873 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2874 IV n, const char *mode, int fd, int imode, int perm,
2875 PerlIO *f, int narg, SV **args)
2877 if (PerlIOValid(f)) {
2878 PerlIO *next = PerlIONext(f);
2879 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2880 next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2882 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
2887 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
2895 f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
2898 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
2900 * if push fails during open, open fails. close will pop us.
2905 fd = PerlIO_fileno(f);
2906 if (init && fd == 2) {
2908 * Initial stderr is unbuffered
2910 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2912 #ifdef PERLIO_USING_CRLF
2913 # ifdef PERLIO_IS_BINMODE_FD
2914 if (PERLIO_IS_BINMODE_FD(fd))
2915 PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch);
2919 * do something about failing setmode()? --jhi
2921 PerlLIO_setmode(fd, O_BINARY);
2930 * This "flush" is akin to sfio's sync in that it handles files in either
2931 * read or write state
2934 PerlIOBuf_flush(pTHX_ PerlIO *f)
2936 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2938 PerlIO *n = PerlIONext(f);
2939 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2941 * write() the buffer
2943 STDCHAR *buf = b->buf;
2945 while (p < b->ptr) {
2946 SSize_t count = PerlIO_write(n, p, b->ptr - p);
2950 else if (count < 0 || PerlIO_error(n)) {
2951 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2956 b->posn += (p - buf);
2958 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2959 STDCHAR *buf = PerlIO_get_base(f);
2961 * Note position change
2963 b->posn += (b->ptr - buf);
2964 if (b->ptr < b->end) {
2966 * We did not consume all of it
2968 if (PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
2969 /* Reload n as some layers may pop themselves on seek */
2970 b->posn = PerlIO_tell(n = PerlIONext(f));
2974 b->ptr = b->end = b->buf;
2975 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
2976 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
2977 /* FIXME: Doing downstream flush may be sub-optimal see PerlIOBuf_fill() below */
2978 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
2984 PerlIOBuf_fill(pTHX_ PerlIO *f)
2986 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2987 PerlIO *n = PerlIONext(f);
2990 * FIXME: doing the down-stream flush maybe sub-optimal if it causes
2991 * pre-read data in stdio buffer to be discarded.
2992 * However, skipping the flush also skips _our_ hosekeeping
2993 * and breaks tell tests. So we do the flush.
2995 if (PerlIO_flush(f) != 0)
2997 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2998 PerlIOBase_flush_linebuf(aTHX);
3001 PerlIO_get_base(f); /* allocate via vtable */
3003 b->ptr = b->end = b->buf;
3004 if (PerlIO_fast_gets(n)) {
3006 * Layer below is also buffered. We do _NOT_ want to call its
3007 * ->Read() because that will loop till it gets what we asked for
3008 * which may hang on a pipe etc. Instead take anything it has to
3009 * hand, or ask it to fill _once_.
3011 avail = PerlIO_get_cnt(n);
3013 avail = PerlIO_fill(n);
3015 avail = PerlIO_get_cnt(n);
3017 if (!PerlIO_error(n) && PerlIO_eof(n))
3022 STDCHAR *ptr = PerlIO_get_ptr(n);
3023 SSize_t cnt = avail;
3024 if (avail > (SSize_t)b->bufsiz)
3026 Copy(ptr, b->buf, avail, STDCHAR);
3027 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3031 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3035 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3037 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3040 b->end = b->buf + avail;
3041 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3046 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3048 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3049 if (PerlIOValid(f)) {
3052 return PerlIOBase_read(aTHX_ f, vbuf, count);
3058 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3060 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3061 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3064 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3069 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3071 * Buffer is already a read buffer, we can overwrite any chars
3072 * which have been read back to buffer start
3074 avail = (b->ptr - b->buf);
3078 * Buffer is idle, set it up so whole buffer is available for
3082 b->end = b->buf + avail;
3084 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3086 * Buffer extends _back_ from where we are now
3088 b->posn -= b->bufsiz;
3090 if (avail > (SSize_t) count) {
3092 * If we have space for more than count, just move count
3100 * In simple stdio-like ungetc() case chars will be already
3103 if (buf != b->ptr) {
3104 Copy(buf, b->ptr, avail, STDCHAR);
3108 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3115 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3117 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3118 const STDCHAR *buf = (const STDCHAR *) vbuf;
3122 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3125 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3126 if ((SSize_t) count < avail)
3128 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3129 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3144 Copy(buf, b->ptr, avail, STDCHAR);
3151 if (b->ptr >= (b->buf + b->bufsiz))
3154 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3160 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3163 if ((code = PerlIO_flush(f)) == 0) {
3164 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3165 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3166 code = PerlIO_seek(PerlIONext(f), offset, whence);
3168 b->posn = PerlIO_tell(PerlIONext(f));
3175 PerlIOBuf_tell(pTHX_ PerlIO *f)
3177 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3179 * b->posn is file position where b->buf was read, or will be written
3181 Off_t posn = b->posn;
3184 * If buffer is valid adjust position by amount in buffer
3186 posn += (b->ptr - b->buf);
3192 PerlIOBuf_close(pTHX_ PerlIO *f)
3194 IV code = PerlIOBase_close(aTHX_ f);
3195 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3196 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3200 b->ptr = b->end = b->buf;
3201 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3206 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3208 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3215 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3217 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3220 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3221 return (b->end - b->ptr);
3226 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3228 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3233 Newz('B',b->buf,b->bufsiz, STDCHAR);
3235 b->buf = (STDCHAR *) & b->oneword;
3236 b->bufsiz = sizeof(b->oneword);
3245 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3247 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3250 return (b->end - b->buf);
3254 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3256 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3260 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3261 assert(PerlIO_get_cnt(f) == cnt);
3262 assert(b->ptr >= b->buf);
3264 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3268 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3270 return PerlIOBase_dup(aTHX_ f, o, param, flags);
3275 PerlIO_funcs PerlIO_perlio = {
3295 PerlIOBase_clearerr,
3296 PerlIOBase_setlinebuf,
3301 PerlIOBuf_set_ptrcnt,
3304 /*--------------------------------------------------------------------------------------*/
3306 * Temp layer to hold unread chars when cannot do it any other way
3310 PerlIOPending_fill(pTHX_ PerlIO *f)
3313 * Should never happen
3320 PerlIOPending_close(pTHX_ PerlIO *f)
3323 * A tad tricky - flush pops us, then we close new top
3326 return PerlIO_close(f);
3330 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3333 * A tad tricky - flush pops us, then we seek new top
3336 return PerlIO_seek(f, offset, whence);
3341 PerlIOPending_flush(pTHX_ PerlIO *f)
3343 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3344 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3348 PerlIO_pop(aTHX_ f);
3353 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3359 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3364 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3366 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3367 PerlIOl *l = PerlIOBase(f);
3369 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3370 * etc. get muddled when it changes mid-string when we auto-pop.
3372 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3373 (PerlIOBase(PerlIONext(f))->
3374 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3379 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3381 SSize_t avail = PerlIO_get_cnt(f);
3383 if ((SSize_t)count < avail)
3386 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3387 if (got >= 0 && got < (SSize_t)count) {
3389 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3390 if (more >= 0 || got == 0)
3396 PerlIO_funcs PerlIO_pending = {
3400 PerlIOPending_pushed,
3411 PerlIOPending_close,
3412 PerlIOPending_flush,
3416 PerlIOBase_clearerr,
3417 PerlIOBase_setlinebuf,
3422 PerlIOPending_set_ptrcnt,
3427 /*--------------------------------------------------------------------------------------*/
3429 * crlf - translation On read translate CR,LF to "\n" we do this by
3430 * overriding ptr/cnt entries to hand back a line at a time and keeping a
3431 * record of which nl we "lied" about. On write translate "\n" to CR,LF
3435 PerlIOBuf base; /* PerlIOBuf stuff */
3436 STDCHAR *nl; /* Position of crlf we "lied" about in the
3441 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3444 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3445 code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3447 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3448 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3449 PerlIOBase(f)->flags);
3456 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3458 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3463 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3464 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3466 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3467 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3469 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3474 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3475 b->end = b->ptr = b->buf + b->bufsiz;
3476 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3477 b->posn -= b->bufsiz;
3479 while (count > 0 && b->ptr > b->buf) {
3482 if (b->ptr - 2 >= b->buf) {
3505 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3507 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3510 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3511 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3512 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3513 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3515 while (nl < b->end && *nl != 0xd)
3517 if (nl < b->end && *nl == 0xd) {
3519 if (nl + 1 < b->end) {
3526 * Not CR,LF but just CR
3534 * Blast - found CR as last char in buffer
3539 * They may not care, defer work as long as
3543 return (nl - b->ptr);
3547 b->ptr++; /* say we have read it as far as
3548 * flush() is concerned */
3549 b->buf++; /* Leave space in front of buffer */
3550 b->bufsiz--; /* Buffer is thus smaller */
3551 code = PerlIO_fill(f); /* Fetch some more */
3552 b->bufsiz++; /* Restore size for next time */
3553 b->buf--; /* Point at space */
3554 b->ptr = nl = b->buf; /* Which is what we hand
3556 b->posn--; /* Buffer starts here */
3557 *nl = 0xd; /* Fill in the CR */
3559 goto test; /* fill() call worked */
3561 * CR at EOF - just fall through
3563 /* Should we clear EOF though ??? */
3568 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3574 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3576 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3577 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3583 if (ptr == b->end && *c->nl == 0xd) {
3584 /* Defered CR at end of buffer case - we lied about count */
3596 * Test code - delete when it works ...
3598 IV flags = PerlIOBase(f)->flags;
3599 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3600 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3601 /* Defered CR at end of buffer case - we lied about count */
3607 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3608 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3616 * They have taken what we lied about
3624 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3628 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3630 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3631 return PerlIOBuf_write(aTHX_ f, vbuf, count);
3633 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3634 const STDCHAR *buf = (const STDCHAR *) vbuf;
3635 const STDCHAR *ebuf = buf + count;
3638 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3640 while (buf < ebuf) {
3641 STDCHAR *eptr = b->buf + b->bufsiz;
3642 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3643 while (buf < ebuf && b->ptr < eptr) {
3645 if ((b->ptr + 2) > eptr) {
3653 *(b->ptr)++ = 0xd; /* CR */
3654 *(b->ptr)++ = 0xa; /* LF */
3656 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3666 if (b->ptr >= eptr) {
3672 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3674 return (buf - (STDCHAR *) vbuf);
3679 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3681 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3686 return PerlIOBuf_flush(aTHX_ f);
3689 PerlIO_funcs PerlIO_crlf = {
3692 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3694 PerlIOBase_noop_ok, /* popped */
3699 PerlIOBuf_read, /* generic read works with ptr/cnt lies
3701 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3702 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3710 PerlIOBase_clearerr,
3711 PerlIOBase_setlinebuf,
3716 PerlIOCrlf_set_ptrcnt,
3720 /*--------------------------------------------------------------------------------------*/
3722 * mmap as "buffer" layer
3726 PerlIOBuf base; /* PerlIOBuf stuff */
3727 Mmap_t mptr; /* Mapped address */
3728 Size_t len; /* mapped length */
3729 STDCHAR *bbuf; /* malloced buffer if map fails */
3732 static size_t page_size = 0;
3735 PerlIOMmap_map(pTHX_ PerlIO *f)
3737 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3738 IV flags = PerlIOBase(f)->flags;
3742 if (flags & PERLIO_F_CANREAD) {
3743 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3744 int fd = PerlIO_fileno(f);
3746 code = Fstat(fd, &st);
3747 if (code == 0 && S_ISREG(st.st_mode)) {
3748 SSize_t len = st.st_size - b->posn;
3752 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3754 SETERRNO(0, SS$_NORMAL);
3755 # ifdef _SC_PAGESIZE
3756 page_size = sysconf(_SC_PAGESIZE);
3758 page_size = sysconf(_SC_PAGE_SIZE);
3760 if ((long) page_size < 0) {
3765 (void) SvUPGRADE(error, SVt_PV);
3766 msg = SvPVx(error, n_a);
3767 Perl_croak(aTHX_ "panic: sysconf: %s",
3772 "panic: sysconf: pagesize unknown");
3776 # ifdef HAS_GETPAGESIZE
3777 page_size = getpagesize();
3779 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3780 page_size = PAGESIZE; /* compiletime, bad */
3784 if ((IV) page_size <= 0)
3785 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3790 * This is a hack - should never happen - open should
3793 b->posn = PerlIO_tell(PerlIONext(f));
3795 posn = (b->posn / page_size) * page_size;
3796 len = st.st_size - posn;
3797 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3798 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3799 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3800 madvise(m->mptr, len, MADV_SEQUENTIAL);
3802 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3803 madvise(m->mptr, len, MADV_WILLNEED);
3805 PerlIOBase(f)->flags =
3806 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3807 b->end = ((STDCHAR *) m->mptr) + len;
3808 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3817 PerlIOBase(f)->flags =
3818 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3820 b->ptr = b->end = b->ptr;
3829 PerlIOMmap_unmap(pTHX_ PerlIO *f)
3831 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3832 PerlIOBuf *b = &m->base;
3836 code = munmap(m->mptr, m->len);
3840 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3843 b->ptr = b->end = b->buf;
3844 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3850 PerlIOMmap_get_base(pTHX_ PerlIO *f)
3852 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3853 PerlIOBuf *b = &m->base;
3854 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3856 * Already have a readbuffer in progress
3862 * We have a write buffer or flushed PerlIOBuf read buffer
3864 m->bbuf = b->buf; /* save it in case we need it again */
3865 b->buf = NULL; /* Clear to trigger below */
3868 PerlIOMmap_map(aTHX_ f); /* Try and map it */
3871 * Map did not work - recover PerlIOBuf buffer if we have one
3876 b->ptr = b->end = b->buf;
3879 return PerlIOBuf_get_base(aTHX_ f);
3883 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3885 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3886 PerlIOBuf *b = &m->base;
3887 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3889 if (b->ptr && (b->ptr - count) >= b->buf
3890 && memEQ(b->ptr - count, vbuf, count)) {
3892 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3897 * Loose the unwritable mapped buffer
3901 * If flush took the "buffer" see if we have one from before
3903 if (!b->buf && m->bbuf)
3906 PerlIOBuf_get_base(aTHX_ f);
3910 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3914 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3916 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3917 PerlIOBuf *b = &m->base;
3918 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3920 * No, or wrong sort of, buffer
3923 if (PerlIOMmap_unmap(aTHX_ f) != 0)
3927 * If unmap took the "buffer" see if we have one from before
3929 if (!b->buf && m->bbuf)
3932 PerlIOBuf_get_base(aTHX_ f);
3936 return PerlIOBuf_write(aTHX_ f, vbuf, count);
3940 PerlIOMmap_flush(pTHX_ PerlIO *f)
3942 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3943 PerlIOBuf *b = &m->base;
3944 IV code = PerlIOBuf_flush(aTHX_ f);
3946 * Now we are "synced" at PerlIOBuf level
3953 if (PerlIOMmap_unmap(aTHX_ f) != 0)
3958 * We seem to have a PerlIOBuf buffer which was not mapped
3959 * remember it in case we need one later
3968 PerlIOMmap_fill(pTHX_ PerlIO *f)
3970 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3971 IV code = PerlIO_flush(f);
3972 if (code == 0 && !b->buf) {
3973 code = PerlIOMmap_map(aTHX_ f);
3975 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3976 code = PerlIOBuf_fill(aTHX_ f);
3982 PerlIOMmap_close(pTHX_ PerlIO *f)
3984 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3985 PerlIOBuf *b = &m->base;
3986 IV code = PerlIO_flush(f);
3990 b->ptr = b->end = b->buf;
3992 if (PerlIOBuf_close(aTHX_ f) != 0)
3998 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4000 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4004 PerlIO_funcs PerlIO_mmap = {
4024 PerlIOBase_clearerr,
4025 PerlIOBase_setlinebuf,
4026 PerlIOMmap_get_base,
4030 PerlIOBuf_set_ptrcnt,
4033 #endif /* HAS_MMAP */
4036 Perl_PerlIO_stdin(pTHX)
4039 PerlIO_stdstreams(aTHX);
4041 return &PL_perlio[1];
4045 Perl_PerlIO_stdout(pTHX)
4048 PerlIO_stdstreams(aTHX);
4050 return &PL_perlio[2];
4054 Perl_PerlIO_stderr(pTHX)
4057 PerlIO_stdstreams(aTHX);
4059 return &PL_perlio[3];
4062 /*--------------------------------------------------------------------------------------*/
4065 PerlIO_getname(PerlIO *f, char *buf)
4070 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4072 name = fgetname(stdio, buf);
4074 Perl_croak(aTHX_ "Don't know how to get file name");
4080 /*--------------------------------------------------------------------------------------*/
4082 * Functions which can be called on any kind of PerlIO implemented in
4086 #undef PerlIO_fdopen
4088 PerlIO_fdopen(int fd, const char *mode)
4091 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4096 PerlIO_open(const char *path, const char *mode)
4099 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4100 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4103 #undef Perlio_reopen
4105 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4108 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4109 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4114 PerlIO_getc(PerlIO *f)
4118 SSize_t count = PerlIO_read(f, buf, 1);
4120 return (unsigned char) buf[0];
4125 #undef PerlIO_ungetc
4127 PerlIO_ungetc(PerlIO *f, int ch)
4132 if (PerlIO_unread(f, &buf, 1) == 1)
4140 PerlIO_putc(PerlIO *f, int ch)
4144 return PerlIO_write(f, &buf, 1);
4149 PerlIO_puts(PerlIO *f, const char *s)
4152 STRLEN len = strlen(s);
4153 return PerlIO_write(f, s, len);
4156 #undef PerlIO_rewind
4158 PerlIO_rewind(PerlIO *f)
4161 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4165 #undef PerlIO_vprintf
4167 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4170 SV *sv = newSVpvn("", 0);
4176 Perl_va_copy(ap, apc);
4177 sv_vcatpvf(sv, fmt, &apc);
4179 sv_vcatpvf(sv, fmt, &ap);
4182 wrote = PerlIO_write(f, s, len);
4187 #undef PerlIO_printf
4189 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4194 result = PerlIO_vprintf(f, fmt, ap);
4199 #undef PerlIO_stdoutf
4201 PerlIO_stdoutf(const char *fmt, ...)
4207 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4212 #undef PerlIO_tmpfile
4214 PerlIO_tmpfile(void)
4217 * I have no idea how portable mkstemp() is ...
4219 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4222 FILE *stdio = PerlSIO_tmpfile();
4225 PerlIOSelf(PerlIO_push
4226 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4227 "w+", Nullsv), PerlIOStdio);
4233 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4234 int fd = mkstemp(SvPVX(sv));
4237 f = PerlIO_fdopen(fd, "w+");
4239 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4241 PerlLIO_unlink(SvPVX(sv));
4251 #endif /* USE_SFIO */
4252 #endif /* PERLIO_IS_STDIO */
4254 /*======================================================================================*/
4256 * Now some functions in terms of above which may be needed even if we are
4257 * not in true PerlIO mode
4261 #undef PerlIO_setpos
4263 PerlIO_setpos(PerlIO *f, SV *pos)
4268 Off_t *posn = (Off_t *) SvPV(pos, len);
4269 if (f && len == sizeof(Off_t))
4270 return PerlIO_seek(f, *posn, SEEK_SET);
4272 SETERRNO(EINVAL, SS$_IVCHAN);
4276 #undef PerlIO_setpos
4278 PerlIO_setpos(PerlIO *f, SV *pos)
4283 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4284 if (f && len == sizeof(Fpos_t)) {
4285 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4286 return fsetpos64(f, fpos);
4288 return fsetpos(f, fpos);
4292 SETERRNO(EINVAL, SS$_IVCHAN);
4298 #undef PerlIO_getpos
4300 PerlIO_getpos(PerlIO *f, SV *pos)
4303 Off_t posn = PerlIO_tell(f);
4304 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4305 return (posn == (Off_t) - 1) ? -1 : 0;
4308 #undef PerlIO_getpos
4310 PerlIO_getpos(PerlIO *f, SV *pos)
4315 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4316 code = fgetpos64(f, &fpos);
4318 code = fgetpos(f, &fpos);
4320 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4325 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4328 vprintf(char *pat, char *args)
4330 _doprnt(pat, args, stdout);
4331 return 0; /* wrong, but perl doesn't use the return
4336 vfprintf(FILE *fd, char *pat, char *args)
4338 _doprnt(pat, args, fd);
4339 return 0; /* wrong, but perl doesn't use the return
4345 #ifndef PerlIO_vsprintf
4347 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4349 int val = vsprintf(s, fmt, ap);
4351 if (strlen(s) >= (STRLEN) n) {
4353 (void) PerlIO_puts(Perl_error_log,
4354 "panic: sprintf overflow - memory corrupted!\n");
4362 #ifndef PerlIO_sprintf
4364 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4369 result = PerlIO_vsprintf(s, n, fmt, ap);