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)
192 #ifdef PERL_IMPLICIT_SYS
193 return PerlSIO_fdupopen(f);
196 return win32_fdupopen(f);
199 int fd = PerlLIO_dup(PerlIO_fileno(f));
202 int omode = fcntl(fd, F_GETFL);
204 omode = djgpp_get_stream_mode(f);
206 PerlIO_intmode2str(omode,mode,NULL);
207 /* the r+ is a hack */
208 return PerlIO_fdopen(fd, mode);
213 SETERRNO(EBADF, SS$_IVCHAN);
223 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
227 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
228 int imode, int perm, PerlIO *old, int narg, SV **args)
232 Perl_croak(aTHX_ "More than one argument to open");
234 if (*args == &PL_sv_undef)
235 return PerlIO_tmpfile();
237 char *name = SvPV_nolen(*args);
239 fd = PerlLIO_open3(name, imode, perm);
241 return PerlIO_fdopen(fd, (char *) mode + 1);
244 return PerlIO_reopen(name, mode, old);
247 return PerlIO_open(name, mode);
252 return PerlIO_fdopen(fd, (char *) mode);
257 XS(XS_PerlIO__Layer__find)
261 Perl_croak(aTHX_ "Usage class->find(name[,load])");
263 char *name = SvPV_nolen(ST(1));
264 ST(0) = (strEQ(name, "crlf")
265 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
272 Perl_boot_core_PerlIO(pTHX)
274 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
280 #ifdef PERLIO_IS_STDIO
286 * Does nothing (yet) except force this file to be included in perl
287 * binary. That allows this file to force inclusion of other functions
288 * that may be required by loadable extensions e.g. for
289 * FileHandle::tmpfile
293 #undef PerlIO_tmpfile
300 #else /* PERLIO_IS_STDIO */
308 * This section is just to make sure these functions get pulled in from
312 #undef PerlIO_tmpfile
323 * Force this file to be included in perl binary. Which allows this
324 * file to force inclusion of other functions that may be required by
325 * loadable extensions e.g. for FileHandle::tmpfile
329 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
330 * results in a lot of lseek()s to regular files and lot of small
333 sfset(sfstdout, SF_SHARE, 0);
337 PerlIO_importFILE(FILE *stdio, int fl)
339 int fd = fileno(stdio);
340 PerlIO *r = PerlIO_fdopen(fd, "r+");
345 PerlIO_findFILE(PerlIO *pio)
347 int fd = PerlIO_fileno(pio);
348 FILE *f = fdopen(fd, "r+");
350 if (!f && errno == EINVAL)
352 if (!f && errno == EINVAL)
359 /*======================================================================================*/
361 * Implement all the PerlIO interface ourselves.
367 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
374 #include <sys/mman.h>
378 void PerlIO_debug(const char *fmt, ...)
379 __attribute__ ((format(__printf__, 1, 2)));
382 PerlIO_debug(const char *fmt, ...)
389 char *s = PerlEnv_getenv("PERLIO_DEBUG");
391 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
398 /* Use fixed buffer as sv_catpvf etc. needs SVs */
402 s = CopFILE(PL_curcop);
405 sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
406 len = strlen(buffer);
407 vsprintf(buffer+len, fmt, ap);
408 PerlLIO_write(dbg, buffer, strlen(buffer));
410 SV *sv = newSVpvn("", 0);
413 s = CopFILE(PL_curcop);
416 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
417 (IV) CopLINE(PL_curcop));
418 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
421 PerlLIO_write(dbg, s, len);
428 /*--------------------------------------------------------------------------------------*/
431 * Inner level routines
435 * Table of pointers to the PerlIO structs (malloc'ed)
437 #define PERLIO_TABLE_SIZE 64
440 PerlIO_allocate(pTHX)
443 * Find a free slot in the table, allocating new table as necessary
448 while ((f = *last)) {
450 last = (PerlIO **) (f);
451 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
457 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
465 #undef PerlIO_fdupopen
467 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
469 if (PerlIOValid(f)) {
470 PerlIO_funcs *tab = PerlIOBase(f)->tab;
472 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
473 new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
477 SETERRNO(EBADF, SS$_IVCHAN);
483 PerlIO_cleantable(pTHX_ PerlIO **tablep)
485 PerlIO *table = *tablep;
488 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
489 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
490 PerlIO *f = table + i;
502 PerlIO_list_alloc(pTHX)
505 Newz('L', list, 1, PerlIO_list_t);
511 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
514 if (--list->refcnt == 0) {
517 for (i = 0; i < list->cur; i++) {
518 if (list->array[i].arg)
519 SvREFCNT_dec(list->array[i].arg);
521 Safefree(list->array);
529 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
532 if (list->cur >= list->len) {
535 Renew(list->array, list->len, PerlIO_pair_t);
537 New('l', list->array, list->len, PerlIO_pair_t);
539 p = &(list->array[list->cur++]);
541 if ((p->arg = arg)) {
547 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
549 PerlIO_list_t *list = (PerlIO_list_t *) NULL;
552 list = PerlIO_list_alloc(aTHX);
553 for (i=0; i < proto->cur; i++) {
555 if (proto->array[i].arg)
556 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
557 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
564 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
567 PerlIO **table = &proto->Iperlio;
570 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
571 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
572 PerlIO_allocate(aTHX); /* root slot is never used */
573 PerlIO_debug("Clone %p from %p\n",aTHX,proto);
574 while ((f = *table)) {
576 table = (PerlIO **) (f++);
577 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
579 (void) fp_dup(f, 0, param);
588 PerlIO_destruct(pTHX)
590 PerlIO **table = &PL_perlio;
593 PerlIO_debug("Destruct %p\n",aTHX);
595 while ((f = *table)) {
597 table = (PerlIO **) (f++);
598 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
602 if (l->tab->kind & PERLIO_K_DESTRUCT) {
603 PerlIO_debug("Destruct popping %s\n", l->tab->name);
617 PerlIO_pop(pTHX_ PerlIO *f)
621 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
622 if (l->tab->Popped) {
624 * If popped returns non-zero do not free its layer structure
625 * it has either done so itself, or it is shared and still in
628 if ((*l->tab->Popped) (aTHX_ f) != 0)
636 /*--------------------------------------------------------------------------------------*/
638 * XS Interface for perl code
642 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
645 if ((SSize_t) len <= 0)
647 for (i = 0; i < PL_known_layers->cur; i++) {
648 PerlIO_funcs *f = PL_known_layers->array[i].funcs;
649 if (memEQ(f->name, name, len)) {
650 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
654 if (load && PL_subname && PL_def_layerlist
655 && PL_def_layerlist->cur >= 2) {
656 SV *pkgsv = newSVpvn("PerlIO", 6);
657 SV *layer = newSVpvn(name, len);
660 * The two SVs are magically freed by load_module
662 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
664 return PerlIO_find_layer(aTHX_ name, len, 0);
666 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
670 #ifdef USE_ATTRIBUTES_FOR_PERLIO
673 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
676 IO *io = GvIOn((GV *) SvRV(sv));
677 PerlIO *ifp = IoIFP(io);
678 PerlIO *ofp = IoOFP(io);
679 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
685 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
688 IO *io = GvIOn((GV *) SvRV(sv));
689 PerlIO *ifp = IoIFP(io);
690 PerlIO *ofp = IoOFP(io);
691 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
697 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
699 Perl_warn(aTHX_ "clear %" SVf, sv);
704 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
706 Perl_warn(aTHX_ "free %" SVf, sv);
710 MGVTBL perlio_vtab = {
718 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
721 SV *sv = SvRV(ST(1));
726 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
728 mg = mg_find(sv, PERL_MAGIC_ext);
729 mg->mg_virtual = &perlio_vtab;
731 Perl_warn(aTHX_ "attrib %" SVf, sv);
732 for (i = 2; i < items; i++) {
734 const char *name = SvPV(ST(i), len);
735 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
737 av_push(av, SvREFCNT_inc(layer));
748 #endif /* USE_ATTIBUTES_FOR_PERLIO */
751 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
753 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
754 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
758 XS(XS_PerlIO__Layer__find)
762 Perl_croak(aTHX_ "Usage class->find(name[,load])");
765 char *name = SvPV(ST(1), len);
766 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
767 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
769 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
776 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
778 if (!PL_known_layers)
779 PL_known_layers = PerlIO_list_alloc(aTHX);
780 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
781 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
785 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
788 const char *s = names;
790 while (isSPACE(*s) || *s == ':')
795 const char *as = Nullch;
797 if (!isIDFIRST(*s)) {
799 * Message is consistent with how attribute lists are
800 * passed. Even though this means "foo : : bar" is
801 * seen as an invalid separator character.
803 char q = ((*s == '\'') ? '"' : '\'');
804 if (ckWARN(WARN_LAYER))
805 Perl_warner(aTHX_ packWARN(WARN_LAYER),
806 "perlio: invalid separator character %c%c%c in layer specification list %s",
808 SETERRNO(EINVAL, LIB$_INVARG);
813 } while (isALNUM(*e));
829 * It's a nul terminated string, not allowed
830 * to \ the terminating null. Anything other
831 * character is passed over.
841 if (ckWARN(WARN_LAYER))
842 Perl_warner(aTHX_ packWARN(WARN_LAYER),
843 "perlio: argument list not closed for layer \"%.*s\"",
855 bool warn_layer = ckWARN(WARN_LAYER);
856 PerlIO_funcs *layer =
857 PerlIO_find_layer(aTHX_ s, llen, 1);
859 PerlIO_list_push(aTHX_ av, layer,
866 Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"",
879 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
881 PerlIO_funcs *tab = &PerlIO_perlio;
882 #ifdef PERLIO_USING_CRLF
885 if (PerlIO_stdio.Set_ptrcnt)
888 PerlIO_debug("Pushing %s\n", tab->name);
889 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
894 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
896 return av->array[n].arg;
900 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
902 if (n >= 0 && n < av->cur) {
903 PerlIO_debug("Layer %" IVdf " is %s\n", n,
904 av->array[n].funcs->name);
905 return av->array[n].funcs;
908 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
913 PerlIO_default_layers(pTHX)
915 if (!PL_def_layerlist) {
916 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
917 PerlIO_funcs *osLayer = &PerlIO_unix;
918 PL_def_layerlist = PerlIO_list_alloc(aTHX);
919 PerlIO_define_layer(aTHX_ & PerlIO_unix);
920 #if defined(WIN32) && !defined(UNDER_CE)
921 PerlIO_define_layer(aTHX_ & PerlIO_win32);
923 osLayer = &PerlIO_win32;
926 PerlIO_define_layer(aTHX_ & PerlIO_raw);
927 PerlIO_define_layer(aTHX_ & PerlIO_perlio);
928 PerlIO_define_layer(aTHX_ & PerlIO_stdio);
929 PerlIO_define_layer(aTHX_ & PerlIO_crlf);
931 PerlIO_define_layer(aTHX_ & PerlIO_mmap);
933 PerlIO_define_layer(aTHX_ & PerlIO_utf8);
934 PerlIO_define_layer(aTHX_ & PerlIO_byte);
935 PerlIO_list_push(aTHX_ PL_def_layerlist,
936 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
939 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
942 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
945 if (PL_def_layerlist->cur < 2) {
946 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
948 return PL_def_layerlist;
952 Perl_boot_core_PerlIO(pTHX)
954 #ifdef USE_ATTRIBUTES_FOR_PERLIO
955 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
958 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
962 PerlIO_default_layer(pTHX_ I32 n)
964 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
967 return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
970 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
971 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
974 PerlIO_stdstreams(pTHX)
977 PerlIO_allocate(aTHX);
978 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
979 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
980 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
985 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
988 Newc('L',l,tab->size,char,PerlIOl);
990 Zero(l, tab->size, char);
994 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
995 (mode) ? mode : "(Null)", (void*)arg);
996 if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
1005 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1007 PerlIO_pop(aTHX_ f);
1010 PerlIO_pop(aTHX_ f);
1017 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1020 * Remove the dummy layer
1022 PerlIO_pop(aTHX_ f);
1024 * Pop back to bottom layer
1026 if (PerlIOValid(f)) {
1028 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
1029 if (*PerlIONext(f)) {
1030 PerlIO_pop(aTHX_ f);
1034 * Nothing bellow - push unix on top then remove it
1036 if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
1037 PerlIO_pop(aTHX_ PerlIONext(f));
1042 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1049 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1050 PerlIO_list_t *layers, IV n, IV max)
1054 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1056 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1067 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1071 PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1072 code = PerlIO_parse_layers(aTHX_ layers, names);
1074 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1076 PerlIO_list_free(aTHX_ layers);
1082 /*--------------------------------------------------------------------------------------*/
1084 * Given the abstraction above the public API functions
1088 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1090 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1091 (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1092 (names) ? names : "(Null)");
1094 /* Do not flush etc. if (e.g.) switching encodings.
1095 if a pushed layer knows it needs to flush lower layers
1096 (for example :unix which is never going to call them)
1097 it can do the flush when it is pushed.
1099 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1102 /* FIXME?: Looking down the layer stack seems wrong,
1103 but is a way of reaching past (say) an encoding layer
1104 to flip CRLF-ness of the layer(s) below
1106 #ifdef PERLIO_USING_CRLF
1107 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1108 O_BINARY so we can look for it in mode.
1110 if (!(mode & O_BINARY)) {
1113 /* Perhaps we should turn on bottom-most aware layer
1114 e.g. Ilya's idea that UNIX TTY could serve
1116 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1117 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1118 /* Not in text mode - flush any pending stuff and flip it */
1120 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1122 /* Only need to turn it on in one layer so we are done */
1127 /* Not finding a CRLF aware layer presumably means we are binary
1128 which is not what was requested - so we failed
1129 We _could_ push :crlf layer but so could caller
1134 /* Either asked for BINMODE or that is normal on this platform
1135 see if any CRLF aware layers are present and turn off the flag
1136 and possibly remove layer.
1139 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1140 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1141 /* In text mode - flush any pending stuff and flip it */
1143 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
1144 #ifndef PERLIO_USING_CRLF
1145 /* CRLF is unusual case - if this is just the :crlf layer pop it */
1146 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
1147 PerlIO_pop(aTHX_ f);
1150 /* Normal case is only one layer doing this, so exit on first
1151 abnormal case can always do multiple binmode calls
1163 PerlIO__close(pTHX_ PerlIO *f)
1166 return (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1168 SETERRNO(EBADF, SS$_IVCHAN);
1174 Perl_PerlIO_close(pTHX_ PerlIO *f)
1177 if (PerlIOValid(f)) {
1178 code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1180 PerlIO_pop(aTHX_ f);
1187 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1190 return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
1192 SETERRNO(EBADF, SS$_IVCHAN);
1198 PerlIO_context_layers(pTHX_ const char *mode)
1200 const char *type = NULL;
1202 * Need to supply default layer info from open.pm
1205 SV *layers = PL_curcop->cop_io;
1208 type = SvPV(layers, len);
1209 if (type && mode[0] != 'r') {
1211 * Skip to write part
1213 const char *s = strchr(type, 0);
1214 if (s && (STRLEN)(s - type) < len) {
1223 static PerlIO_funcs *
1224 PerlIO_layer_from_ref(pTHX_ SV *sv)
1227 * For any scalar type load the handler which is bundled with perl
1229 if (SvTYPE(sv) < SVt_PVAV)
1230 return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1233 * For other types allow if layer is known but don't try and load it
1235 switch (SvTYPE(sv)) {
1237 return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1239 return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1241 return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1243 return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1249 PerlIO_resolve_layers(pTHX_ const char *layers,
1250 const char *mode, int narg, SV **args)
1252 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1255 PerlIO_stdstreams(aTHX);
1259 * If it is a reference but not an object see if we have a handler
1262 if (SvROK(arg) && !sv_isobject(arg)) {
1263 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1265 def = PerlIO_list_alloc(aTHX);
1266 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1270 * Don't fail if handler cannot be found :Via(...) etc. may do
1271 * something sensible else we will just stringfy and open
1277 layers = PerlIO_context_layers(aTHX_ mode);
1278 if (layers && *layers) {
1282 av = PerlIO_list_alloc(aTHX);
1283 for (i = 0; i < def->cur; i++) {
1284 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1291 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1295 PerlIO_list_free(aTHX_ av);
1296 return (PerlIO_list_t *) NULL;
1307 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1308 int imode, int perm, PerlIO *f, int narg, SV **args)
1310 if (!f && narg == 1 && *args == &PL_sv_undef) {
1311 if ((f = PerlIO_tmpfile())) {
1313 layers = PerlIO_context_layers(aTHX_ mode);
1314 if (layers && *layers)
1315 PerlIO_apply_layers(aTHX_ f, mode, layers);
1319 PerlIO_list_t *layera = NULL;
1321 PerlIO_funcs *tab = NULL;
1322 if (PerlIOValid(f)) {
1324 * This is "reopen" - it is not tested as perl does not use it
1328 layera = PerlIO_list_alloc(aTHX);
1330 SV *arg = (l->tab->Getarg)
1331 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1333 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1334 l = *PerlIONext(&l);
1338 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1344 * Start at "top" of layer stack
1346 n = layera->cur - 1;
1348 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1357 * Found that layer 'n' can do opens - call it
1359 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1360 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1362 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1363 tab->name, layers, mode, fd, imode, perm,
1364 (void*)f, narg, (void*)args);
1365 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1368 if (n + 1 < layera->cur) {
1370 * More layers above the one that we used to open -
1373 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1374 /* If pushing layers fails close the file */
1381 PerlIO_list_free(aTHX_ layera);
1388 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1391 return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
1393 SETERRNO(EBADF, SS$_IVCHAN);
1399 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1402 return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
1404 SETERRNO(EBADF, SS$_IVCHAN);
1410 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1413 return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
1415 SETERRNO(EBADF, SS$_IVCHAN);
1421 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1424 return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
1426 SETERRNO(EBADF, SS$_IVCHAN);
1432 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1435 return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
1437 SETERRNO(EBADF, SS$_IVCHAN);
1443 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1447 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1448 if (tab && tab->Flush) {
1449 return (*tab->Flush) (aTHX_ f);
1452 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
1453 SETERRNO(EBADF, SS$_IVCHAN);
1458 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1459 SETERRNO(EBADF, SS$_IVCHAN);
1465 * Is it good API design to do flush-all on NULL, a potentially
1466 * errorneous input? Maybe some magical value (PerlIO*
1467 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1468 * things on fflush(NULL), but should we be bound by their design
1471 PerlIO **table = &PL_perlio;
1473 while ((f = *table)) {
1475 table = (PerlIO **) (f++);
1476 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1477 if (*f && PerlIO_flush(f) != 0)
1487 PerlIOBase_flush_linebuf(pTHX)
1489 PerlIO **table = &PL_perlio;
1491 while ((f = *table)) {
1493 table = (PerlIO **) (f++);
1494 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1497 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1498 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1506 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1509 return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
1511 SETERRNO(EBADF, SS$_IVCHAN);
1517 PerlIO_isutf8(PerlIO *f)
1520 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1522 SETERRNO(EBADF, SS$_IVCHAN);
1528 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1531 return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
1533 SETERRNO(EBADF, SS$_IVCHAN);
1539 Perl_PerlIO_error(pTHX_ PerlIO *f)
1542 return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
1544 SETERRNO(EBADF, SS$_IVCHAN);
1550 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1553 (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
1555 SETERRNO(EBADF, SS$_IVCHAN);
1559 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1562 (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
1564 SETERRNO(EBADF, SS$_IVCHAN);
1568 PerlIO_has_base(PerlIO *f)
1570 if (PerlIOValid(f)) {
1571 return (PerlIOBase(f)->tab->Get_base != NULL);
1577 PerlIO_fast_gets(PerlIO *f)
1579 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1580 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1581 return (tab->Set_ptrcnt != NULL);
1587 PerlIO_has_cntptr(PerlIO *f)
1589 if (PerlIOValid(f)) {
1590 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1591 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1597 PerlIO_canset_cnt(PerlIO *f)
1599 if (PerlIOValid(f)) {
1600 PerlIOl *l = PerlIOBase(f);
1601 return (l->tab->Set_ptrcnt != NULL);
1607 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1610 return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
1615 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1618 return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
1623 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1625 if (PerlIOValid(f)) {
1626 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1627 if (tab->Get_ptr == NULL)
1629 return (*tab->Get_ptr) (aTHX_ f);
1635 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1637 if (PerlIOValid(f)) {
1638 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1639 if (tab->Get_cnt == NULL)
1641 return (*tab->Get_cnt) (aTHX_ f);
1647 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1649 if (PerlIOValid(f)) {
1650 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
1655 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1657 if (PerlIOValid(f)) {
1658 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1659 if (tab->Set_ptrcnt == NULL) {
1660 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1662 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
1666 /*--------------------------------------------------------------------------------------*/
1668 * utf8 and raw dummy layers
1672 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1674 if (*PerlIONext(f)) {
1675 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1676 PerlIO_pop(aTHX_ f);
1677 if (tab->kind & PERLIO_K_UTF8)
1678 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1680 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1686 PerlIO_funcs PerlIO_utf8 = {
1689 PERLIO_K_DUMMY | PERLIO_F_UTF8,
1707 NULL, /* get_base */
1708 NULL, /* get_bufsiz */
1711 NULL, /* set_ptrcnt */
1714 PerlIO_funcs PerlIO_byte = {
1735 NULL, /* get_base */
1736 NULL, /* get_bufsiz */
1739 NULL, /* set_ptrcnt */
1743 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1744 IV n, const char *mode, int fd, int imode, int perm,
1745 PerlIO *old, int narg, SV **args)
1747 PerlIO_funcs *tab = PerlIO_default_btm();
1748 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1752 PerlIO_funcs PerlIO_raw = {
1773 NULL, /* get_base */
1774 NULL, /* get_bufsiz */
1777 NULL, /* set_ptrcnt */
1779 /*--------------------------------------------------------------------------------------*/
1780 /*--------------------------------------------------------------------------------------*/
1782 * "Methods" of the "base class"
1786 PerlIOBase_fileno(pTHX_ PerlIO *f)
1788 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1792 PerlIO_modestr(PerlIO *f, char *buf)
1795 IV flags = PerlIOBase(f)->flags;
1796 if (flags & PERLIO_F_APPEND) {
1798 if (flags & PERLIO_F_CANREAD) {
1802 else if (flags & PERLIO_F_CANREAD) {
1804 if (flags & PERLIO_F_CANWRITE)
1807 else if (flags & PERLIO_F_CANWRITE) {
1809 if (flags & PERLIO_F_CANREAD) {
1813 #ifdef PERLIO_USING_CRLF
1814 if (!(flags & PERLIO_F_CRLF))
1822 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1824 PerlIOl *l = PerlIOBase(f);
1826 const char *omode = mode;
1829 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1830 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1831 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1832 if (tab->Set_ptrcnt != NULL)
1833 l->flags |= PERLIO_F_FASTGETS;
1835 if (*mode == '#' || *mode == 'I')
1839 l->flags |= PERLIO_F_CANREAD;
1842 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1845 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1848 SETERRNO(EINVAL, LIB$_INVARG);
1854 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1857 l->flags &= ~PERLIO_F_CRLF;
1860 l->flags |= PERLIO_F_CRLF;
1863 SETERRNO(EINVAL, LIB$_INVARG);
1870 l->flags |= l->next->flags &
1871 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1876 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1877 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1878 l->flags, PerlIO_modestr(f, temp));
1884 PerlIOBase_popped(pTHX_ PerlIO *f)
1890 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1893 * Save the position as current head considers it
1895 Off_t old = PerlIO_tell(f);
1897 PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1898 PerlIOSelf(f, PerlIOBuf)->posn = old;
1899 done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
1904 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1906 STDCHAR *buf = (STDCHAR *) vbuf;
1908 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1911 SSize_t avail = PerlIO_get_cnt(f);
1914 take = ((SSize_t)count < avail) ? count : avail;
1916 STDCHAR *ptr = PerlIO_get_ptr(f);
1917 Copy(ptr, buf, take, STDCHAR);
1918 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1922 if (count > 0 && avail <= 0) {
1923 if (PerlIO_fill(f) != 0)
1927 return (buf - (STDCHAR *) vbuf);
1933 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
1939 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
1945 PerlIOBase_close(pTHX_ PerlIO *f)
1948 PerlIO *n = PerlIONext(f);
1949 if (PerlIO_flush(f) != 0)
1951 if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0)
1953 PerlIOBase(f)->flags &=
1954 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1959 PerlIOBase_eof(pTHX_ PerlIO *f)
1961 if (PerlIOValid(f)) {
1962 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1968 PerlIOBase_error(pTHX_ PerlIO *f)
1970 if (PerlIOValid(f)) {
1971 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1977 PerlIOBase_clearerr(pTHX_ PerlIO *f)
1979 if (PerlIOValid(f)) {
1980 PerlIO *n = PerlIONext(f);
1981 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
1988 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
1990 if (PerlIOValid(f)) {
1991 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
1996 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2002 return sv_dup(arg, param);
2005 return newSVsv(arg);
2008 return newSVsv(arg);
2013 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2015 PerlIO *nexto = PerlIONext(o);
2016 if (PerlIOValid(nexto)) {
2017 PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
2018 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2021 PerlIO_funcs *self = PerlIOBase(o)->tab;
2024 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2025 self->name, (void*)f, (void*)o, (void*)param);
2027 arg = (*self->Getarg)(aTHX_ o,param,flags);
2029 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2037 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2039 perl_mutex PerlIO_mutex;
2041 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2046 /* Place holder for stdstreams call ??? */
2048 MUTEX_INIT(&PerlIO_mutex);
2053 PerlIOUnix_refcnt_inc(int fd)
2055 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2057 MUTEX_LOCK(&PerlIO_mutex);
2059 PerlIO_fd_refcnt[fd]++;
2060 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2062 MUTEX_UNLOCK(&PerlIO_mutex);
2068 PerlIOUnix_refcnt_dec(int fd)
2071 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2073 MUTEX_LOCK(&PerlIO_mutex);
2075 cnt = --PerlIO_fd_refcnt[fd];
2076 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2078 MUTEX_UNLOCK(&PerlIO_mutex);
2085 PerlIO_cleanup(pTHX)
2089 PerlIO_debug("Cleanup layers for %p\n",aTHX);
2091 PerlIO_debug("Cleanup layers\n");
2093 /* Raise STDIN..STDERR refcount so we don't close them */
2094 for (i=0; i < 3; i++)
2095 PerlIOUnix_refcnt_inc(i);
2096 PerlIO_cleantable(aTHX_ &PL_perlio);
2097 /* Restore STDIN..STDERR refcount */
2098 for (i=0; i < 3; i++)
2099 PerlIOUnix_refcnt_dec(i);
2101 if (PL_known_layers) {
2102 PerlIO_list_free(aTHX_ PL_known_layers);
2103 PL_known_layers = NULL;
2105 if(PL_def_layerlist) {
2106 PerlIO_list_free(aTHX_ PL_def_layerlist);
2107 PL_def_layerlist = NULL;
2113 /*--------------------------------------------------------------------------------------*/
2115 * Bottom-most level for UNIX-like case
2119 struct _PerlIO base; /* The generic part */
2120 int fd; /* UNIX like file descriptor */
2121 int oflags; /* open/fcntl flags */
2125 PerlIOUnix_oflags(const char *mode)
2128 if (*mode == 'I' || *mode == '#')
2133 if (*++mode == '+') {
2140 oflags = O_CREAT | O_TRUNC;
2141 if (*++mode == '+') {
2150 oflags = O_CREAT | O_APPEND;
2151 if (*++mode == '+') {
2164 else if (*mode == 't') {
2166 oflags &= ~O_BINARY;
2170 * Always open in binary mode
2173 if (*mode || oflags == -1) {
2174 SETERRNO(EINVAL, LIB$_INVARG);
2181 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2183 return PerlIOSelf(f, PerlIOUnix)->fd;
2187 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2189 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
2190 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2191 if (*PerlIONext(f)) {
2192 /* We never call down so any pending stuff now */
2193 PerlIO_flush(PerlIONext(f));
2194 s->fd = PerlIO_fileno(PerlIONext(f));
2196 * XXX could (or should) we retrieve the oflags from the open file
2197 * handle rather than believing the "mode" we are passed in? XXX
2198 * Should the value on NULL mode be 0 or -1?
2200 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2202 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2207 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2208 IV n, const char *mode, int fd, int imode,
2209 int perm, PerlIO *f, int narg, SV **args)
2211 if (PerlIOValid(f)) {
2212 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2213 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2216 char *path = SvPV_nolen(*args);
2220 imode = PerlIOUnix_oflags(mode);
2224 fd = PerlLIO_open3(path, imode, perm);
2232 f = PerlIO_allocate(aTHX);
2234 if (!PerlIOValid(f)) {
2235 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
2239 s = PerlIOSelf(f, PerlIOUnix);
2243 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2244 PerlIOUnix_refcnt_inc(fd);
2250 * FIXME: pop layers ???
2258 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2260 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2262 if (flags & PERLIO_DUP_FD) {
2263 fd = PerlLIO_dup(fd);
2265 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2266 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2268 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2269 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2271 PerlIOUnix_refcnt_inc(fd);
2280 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2282 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2283 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2286 SSize_t len = PerlLIO_read(fd, vbuf, count);
2287 if (len >= 0 || errno != EINTR) {
2289 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2290 else if (len == 0 && count != 0)
2291 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2299 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2301 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2303 SSize_t len = PerlLIO_write(fd, vbuf, count);
2304 if (len >= 0 || errno != EINTR) {
2306 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2314 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2317 PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2318 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2319 return (new == (Off_t) - 1) ? -1 : 0;
2323 PerlIOUnix_tell(pTHX_ PerlIO *f)
2325 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2330 PerlIOUnix_close(pTHX_ PerlIO *f)
2332 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2334 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2335 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2336 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2341 SETERRNO(EBADF,SS$_IVCHAN);
2344 while (PerlLIO_close(fd) != 0) {
2345 if (errno != EINTR) {
2352 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2357 PerlIO_funcs PerlIO_unix = {
2373 PerlIOBase_noop_ok, /* flush */
2374 PerlIOBase_noop_fail, /* fill */
2377 PerlIOBase_clearerr,
2378 PerlIOBase_setlinebuf,
2379 NULL, /* get_base */
2380 NULL, /* get_bufsiz */
2383 NULL, /* set_ptrcnt */
2386 /*--------------------------------------------------------------------------------------*/
2391 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2392 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2393 broken by the last second glibc 2.3 fix
2395 #define STDIO_BUFFER_WRITABLE
2400 struct _PerlIO base;
2401 FILE *stdio; /* The stream */
2405 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2407 return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2411 PerlIOStdio_mode(const char *mode, char *tmode)
2417 #ifdef PERLIO_USING_CRLF
2425 * This isn't used yet ...
2428 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2430 if (*PerlIONext(f)) {
2431 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2434 PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2435 PerlIOStdio_mode(mode, tmode));
2438 /* We never call down so any pending stuff now */
2439 PerlIO_flush(PerlIONext(f));
2444 return PerlIOBase_pushed(aTHX_ f, mode, arg);
2449 PerlIO_importFILE(FILE *stdio, int fl)
2454 /* We need to probe to see how we can open the stream
2455 so start with read/write and then try write and read
2456 we dup() so that we can fclose without loosing the fd.
2458 Note that the errno value set by a failing fdopen
2459 varies between stdio implementations.
2461 int fd = PerlLIO_dup(fileno(stdio));
2463 FILE *f2 = fdopen(fd, mode);
2467 f2 = fdopen(fd, mode);
2471 f2 = fdopen(fd, mode);
2474 /* Don't seem to be able to open */
2479 s = PerlIOSelf(PerlIO_push
2480 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2481 mode, Nullsv), PerlIOStdio);
2488 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2489 IV n, const char *mode, int fd, int imode,
2490 int perm, PerlIO *f, int narg, SV **args)
2493 if (PerlIOValid(f)) {
2494 char *path = SvPV_nolen(*args);
2495 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2497 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2498 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2503 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2508 char *path = SvPV_nolen(*args);
2511 fd = PerlLIO_open3(path, imode, perm);
2514 FILE *stdio = PerlSIO_fopen(path, mode);
2518 f = PerlIO_allocate(aTHX);
2520 s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
2521 (mode = PerlIOStdio_mode(mode, tmode)),
2525 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2540 stdio = PerlSIO_stdin;
2543 stdio = PerlSIO_stdout;
2546 stdio = PerlSIO_stderr;
2551 stdio = PerlSIO_fdopen(fd, mode =
2552 PerlIOStdio_mode(mode, tmode));
2557 f = PerlIO_allocate(aTHX);
2559 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio);
2561 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2570 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2572 /* This assumes no layers underneath - which is what
2573 happens, but is not how I remember it. NI-S 2001/10/16
2575 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2576 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2577 if (flags & PERLIO_DUP_FD) {
2578 int fd = PerlLIO_dup(fileno(stdio));
2581 stdio = fdopen(fd, PerlIO_modestr(o,mode));
2584 /* FIXME: To avoid messy error recovery if dup fails
2585 re-use the existing stdio as though flag was not set
2589 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2590 PerlIOUnix_refcnt_inc(fileno(stdio));
2596 PerlIOStdio_close(pTHX_ PerlIO *f)
2598 #ifdef SOCKS5_VERSION_NAME
2600 Sock_size_t optlen = sizeof(int);
2602 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2603 if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2604 /* Do not close it but do flush any buffers */
2605 return PerlIO_flush(f);
2608 #ifdef SOCKS5_VERSION_NAME
2610 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2612 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2614 PerlSIO_fclose(stdio)
2623 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2625 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2628 STDCHAR *buf = (STDCHAR *) vbuf;
2630 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2631 * stdio does not do that for fread()
2633 int ch = PerlSIO_fgetc(s);
2640 got = PerlSIO_fread(vbuf, 1, count, s);
2645 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2648 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2650 #ifdef STDIO_BUFFER_WRITABLE
2651 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2652 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2653 STDCHAR *base = PerlIO_get_base(f);
2654 SSize_t cnt = PerlIO_get_cnt(f);
2655 STDCHAR *ptr = PerlIO_get_ptr(f);
2656 SSize_t avail = ptr - base;
2658 if (avail > count) {
2662 Move(buf-avail,ptr,avail,STDCHAR);
2665 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
2666 if (PerlSIO_feof(s) && unread >= 0)
2667 PerlSIO_clearerr(s);
2672 if (PerlIO_has_cntptr(f)) {
2673 /* We can get pointer to buffer but not its base
2674 Do ungetc() but check chars are ending up in the
2677 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
2678 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2680 int ch = *--buf & 0xFF;
2681 if (ungetc(ch,s) != ch) {
2682 /* ungetc did not work */
2685 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
2686 /* Did not change pointer as expected */
2687 fgetc(s); /* get char back again */
2697 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
2703 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2705 return PerlSIO_fwrite(vbuf, 1, count,
2706 PerlIOSelf(f, PerlIOStdio)->stdio);
2710 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2712 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2713 return PerlSIO_fseek(stdio, offset, whence);
2717 PerlIOStdio_tell(pTHX_ PerlIO *f)
2719 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2720 return PerlSIO_ftell(stdio);
2724 PerlIOStdio_flush(pTHX_ PerlIO *f)
2726 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2727 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2728 return PerlSIO_fflush(stdio);
2733 * FIXME: This discards ungetc() and pre-read stuff which is not
2734 * right if this is just a "sync" from a layer above Suspect right
2735 * design is to do _this_ but not have layer above flush this
2736 * layer read-to-read
2739 * Not writeable - sync by attempting a seek
2742 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2750 PerlIOStdio_eof(pTHX_ PerlIO *f)
2752 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2756 PerlIOStdio_error(pTHX_ PerlIO *f)
2758 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2762 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2764 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2768 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2770 #ifdef HAS_SETLINEBUF
2771 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2773 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2779 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2781 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2782 return (STDCHAR*)PerlSIO_get_base(stdio);
2786 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2788 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2789 return PerlSIO_get_bufsiz(stdio);
2793 #ifdef USE_STDIO_PTR
2795 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2797 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2798 return (STDCHAR*)PerlSIO_get_ptr(stdio);
2802 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2804 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2805 return PerlSIO_get_cnt(stdio);
2809 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2811 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2813 #ifdef STDIO_PTR_LVALUE
2814 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2815 #ifdef STDIO_PTR_LVAL_SETS_CNT
2816 if (PerlSIO_get_cnt(stdio) != (cnt)) {
2817 assert(PerlSIO_get_cnt(stdio) == (cnt));
2820 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2822 * Setting ptr _does_ change cnt - we are done
2826 #else /* STDIO_PTR_LVALUE */
2828 #endif /* STDIO_PTR_LVALUE */
2831 * Now (or only) set cnt
2833 #ifdef STDIO_CNT_LVALUE
2834 PerlSIO_set_cnt(stdio, cnt);
2835 #else /* STDIO_CNT_LVALUE */
2836 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2837 PerlSIO_set_ptr(stdio,
2838 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2840 #else /* STDIO_PTR_LVAL_SETS_CNT */
2842 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2843 #endif /* STDIO_CNT_LVALUE */
2850 PerlIOStdio_fill(pTHX_ PerlIO *f)
2852 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2855 * fflush()ing read-only streams can cause trouble on some stdio-s
2857 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2858 if (PerlSIO_fflush(stdio) != 0)
2861 c = PerlSIO_fgetc(stdio);
2865 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2867 #ifdef STDIO_BUFFER_WRITABLE
2868 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2869 /* Fake ungetc() to the real buffer in case system's ungetc
2872 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
2873 SSize_t cnt = PerlSIO_get_cnt(stdio);
2874 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
2875 if (ptr == base+1) {
2876 *--ptr = (STDCHAR) c;
2877 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
2878 if (PerlSIO_feof(stdio))
2879 PerlSIO_clearerr(stdio);
2885 if (PerlIO_has_cntptr(f)) {
2887 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
2894 /* An ungetc()d char is handled separately from the regular
2895 * buffer, so we stuff it in the buffer ourselves.
2896 * Should never get called as should hit code above
2898 *(--((*stdio)->_ptr)) = (unsigned char) c;
2901 /* If buffer snoop scheme above fails fall back to
2904 if (PerlSIO_ungetc(c, stdio) != c)
2912 PerlIO_funcs PerlIO_stdio = {
2914 sizeof(PerlIOStdio),
2932 PerlIOStdio_clearerr,
2933 PerlIOStdio_setlinebuf,
2935 PerlIOStdio_get_base,
2936 PerlIOStdio_get_bufsiz,
2941 #ifdef USE_STDIO_PTR
2942 PerlIOStdio_get_ptr,
2943 PerlIOStdio_get_cnt,
2944 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2945 PerlIOStdio_set_ptrcnt
2946 #else /* STDIO_PTR_LVALUE */
2948 #endif /* STDIO_PTR_LVALUE */
2949 #else /* USE_STDIO_PTR */
2953 #endif /* USE_STDIO_PTR */
2957 PerlIO_exportFILE(PerlIO *f, int fl)
2963 stdio = fdopen(PerlIO_fileno(f), PerlIO_modestr(f,buf));
2966 PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv),
2974 PerlIO_findFILE(PerlIO *f)
2978 if (l->tab == &PerlIO_stdio) {
2979 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2982 l = *PerlIONext(&l);
2984 return PerlIO_exportFILE(f, 0);
2988 PerlIO_releaseFILE(PerlIO *p, FILE *f)
2992 if (l->tab == &PerlIO_stdio) {
2993 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2994 if (s->stdio == f) {
2996 PerlIO_pop(aTHX_ p);
3005 /*--------------------------------------------------------------------------------------*/
3007 * perlio buffer layer
3011 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3013 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3014 int fd = PerlIO_fileno(f);
3016 if (fd >= 0 && PerlLIO_isatty(fd)) {
3017 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3019 posn = PerlIO_tell(PerlIONext(f));
3020 if (posn != (Off_t) - 1) {
3023 return PerlIOBase_pushed(aTHX_ f, mode, arg);
3027 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3028 IV n, const char *mode, int fd, int imode, int perm,
3029 PerlIO *f, int narg, SV **args)
3031 if (PerlIOValid(f)) {
3032 PerlIO *next = PerlIONext(f);
3033 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3034 next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3036 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
3041 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3049 f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3052 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3054 * if push fails during open, open fails. close will pop us.
3059 fd = PerlIO_fileno(f);
3060 if (init && fd == 2) {
3062 * Initial stderr is unbuffered
3064 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3066 #ifdef PERLIO_USING_CRLF
3067 # ifdef PERLIO_IS_BINMODE_FD
3068 if (PERLIO_IS_BINMODE_FD(fd))
3069 PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch);
3073 * do something about failing setmode()? --jhi
3075 PerlLIO_setmode(fd, O_BINARY);
3084 * This "flush" is akin to sfio's sync in that it handles files in either
3085 * read or write state
3088 PerlIOBuf_flush(pTHX_ PerlIO *f)
3090 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3092 PerlIO *n = PerlIONext(f);
3093 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3095 * write() the buffer
3097 STDCHAR *buf = b->buf;
3099 while (p < b->ptr) {
3100 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3104 else if (count < 0 || PerlIO_error(n)) {
3105 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3110 b->posn += (p - buf);
3112 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3113 STDCHAR *buf = PerlIO_get_base(f);
3115 * Note position change
3117 b->posn += (b->ptr - buf);
3118 if (b->ptr < b->end) {
3120 * We did not consume all of it
3122 if (PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3123 /* Reload n as some layers may pop themselves on seek */
3124 b->posn = PerlIO_tell(n = PerlIONext(f));
3128 b->ptr = b->end = b->buf;
3129 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3130 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3131 /* FIXME: Doing downstream flush may be sub-optimal see PerlIOBuf_fill() below */
3132 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3138 PerlIOBuf_fill(pTHX_ PerlIO *f)
3140 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3141 PerlIO *n = PerlIONext(f);
3144 * FIXME: doing the down-stream flush maybe sub-optimal if it causes
3145 * pre-read data in stdio buffer to be discarded.
3146 * However, skipping the flush also skips _our_ hosekeeping
3147 * and breaks tell tests. So we do the flush.
3149 if (PerlIO_flush(f) != 0)
3151 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3152 PerlIOBase_flush_linebuf(aTHX);
3155 PerlIO_get_base(f); /* allocate via vtable */
3157 b->ptr = b->end = b->buf;
3158 if (PerlIO_fast_gets(n)) {
3160 * Layer below is also buffered. We do _NOT_ want to call its
3161 * ->Read() because that will loop till it gets what we asked for
3162 * which may hang on a pipe etc. Instead take anything it has to
3163 * hand, or ask it to fill _once_.
3165 avail = PerlIO_get_cnt(n);
3167 avail = PerlIO_fill(n);
3169 avail = PerlIO_get_cnt(n);
3171 if (!PerlIO_error(n) && PerlIO_eof(n))
3176 STDCHAR *ptr = PerlIO_get_ptr(n);
3177 SSize_t cnt = avail;
3178 if (avail > (SSize_t)b->bufsiz)
3180 Copy(ptr, b->buf, avail, STDCHAR);
3181 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3185 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3189 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3191 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3194 b->end = b->buf + avail;
3195 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3200 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3202 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3203 if (PerlIOValid(f)) {
3206 return PerlIOBase_read(aTHX_ f, vbuf, count);
3212 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3214 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3215 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3218 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3223 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3225 * Buffer is already a read buffer, we can overwrite any chars
3226 * which have been read back to buffer start
3228 avail = (b->ptr - b->buf);
3232 * Buffer is idle, set it up so whole buffer is available for
3236 b->end = b->buf + avail;
3238 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3240 * Buffer extends _back_ from where we are now
3242 b->posn -= b->bufsiz;
3244 if (avail > (SSize_t) count) {
3246 * If we have space for more than count, just move count
3254 * In simple stdio-like ungetc() case chars will be already
3257 if (buf != b->ptr) {
3258 Copy(buf, b->ptr, avail, STDCHAR);
3262 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3266 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3272 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3274 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3275 const STDCHAR *buf = (const STDCHAR *) vbuf;
3279 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3282 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3283 if ((SSize_t) count < avail)
3285 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3286 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3301 Copy(buf, b->ptr, avail, STDCHAR);
3308 if (b->ptr >= (b->buf + b->bufsiz))
3311 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3317 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3320 if ((code = PerlIO_flush(f)) == 0) {
3321 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3322 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3323 code = PerlIO_seek(PerlIONext(f), offset, whence);
3325 b->posn = PerlIO_tell(PerlIONext(f));
3332 PerlIOBuf_tell(pTHX_ PerlIO *f)
3334 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3336 * b->posn is file position where b->buf was read, or will be written
3338 Off_t posn = b->posn;
3341 * If buffer is valid adjust position by amount in buffer
3343 posn += (b->ptr - b->buf);
3349 PerlIOBuf_popped(pTHX_ PerlIO *f)
3351 IV code = PerlIOBase_popped(aTHX_ f);
3352 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3353 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3357 b->ptr = b->end = b->buf;
3358 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3363 PerlIOBuf_close(pTHX_ PerlIO *f)
3365 IV code = PerlIOBase_close(aTHX_ f);
3366 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3367 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3371 b->ptr = b->end = b->buf;
3372 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3377 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3379 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3386 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3388 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3391 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3392 return (b->end - b->ptr);
3397 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3399 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3404 Newz('B',b->buf,b->bufsiz, STDCHAR);
3406 b->buf = (STDCHAR *) & b->oneword;
3407 b->bufsiz = sizeof(b->oneword);
3416 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3418 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3421 return (b->end - b->buf);
3425 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3427 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3431 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3432 assert(PerlIO_get_cnt(f) == cnt);
3433 assert(b->ptr >= b->buf);
3435 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3439 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3441 return PerlIOBase_dup(aTHX_ f, o, param, flags);
3446 PerlIO_funcs PerlIO_perlio = {
3466 PerlIOBase_clearerr,
3467 PerlIOBase_setlinebuf,
3472 PerlIOBuf_set_ptrcnt,
3475 /*--------------------------------------------------------------------------------------*/
3477 * Temp layer to hold unread chars when cannot do it any other way
3481 PerlIOPending_fill(pTHX_ PerlIO *f)
3484 * Should never happen
3491 PerlIOPending_close(pTHX_ PerlIO *f)
3494 * A tad tricky - flush pops us, then we close new top
3497 return PerlIO_close(f);
3501 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3504 * A tad tricky - flush pops us, then we seek new top
3507 return PerlIO_seek(f, offset, whence);
3512 PerlIOPending_flush(pTHX_ PerlIO *f)
3514 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3515 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3519 PerlIO_pop(aTHX_ f);
3524 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3530 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3535 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3537 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3538 PerlIOl *l = PerlIOBase(f);
3540 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3541 * etc. get muddled when it changes mid-string when we auto-pop.
3543 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3544 (PerlIOBase(PerlIONext(f))->
3545 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3550 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3552 SSize_t avail = PerlIO_get_cnt(f);
3554 if ((SSize_t)count < avail)
3557 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3558 if (got >= 0 && got < (SSize_t)count) {
3560 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3561 if (more >= 0 || got == 0)
3567 PerlIO_funcs PerlIO_pending = {
3571 PerlIOPending_pushed,
3582 PerlIOPending_close,
3583 PerlIOPending_flush,
3587 PerlIOBase_clearerr,
3588 PerlIOBase_setlinebuf,
3593 PerlIOPending_set_ptrcnt,
3598 /*--------------------------------------------------------------------------------------*/
3600 * crlf - translation On read translate CR,LF to "\n" we do this by
3601 * overriding ptr/cnt entries to hand back a line at a time and keeping a
3602 * record of which nl we "lied" about. On write translate "\n" to CR,LF
3606 PerlIOBuf base; /* PerlIOBuf stuff */
3607 STDCHAR *nl; /* Position of crlf we "lied" about in the
3612 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3615 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3616 code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3618 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3619 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3620 PerlIOBase(f)->flags);
3627 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3629 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3634 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3635 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3637 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3638 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3640 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3645 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3646 b->end = b->ptr = b->buf + b->bufsiz;
3647 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3648 b->posn -= b->bufsiz;
3650 while (count > 0 && b->ptr > b->buf) {
3653 if (b->ptr - 2 >= b->buf) {
3676 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3678 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3681 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3682 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3683 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3684 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3686 while (nl < b->end && *nl != 0xd)
3688 if (nl < b->end && *nl == 0xd) {
3690 if (nl + 1 < b->end) {
3697 * Not CR,LF but just CR
3705 * Blast - found CR as last char in buffer
3710 * They may not care, defer work as long as
3714 return (nl - b->ptr);
3718 b->ptr++; /* say we have read it as far as
3719 * flush() is concerned */
3720 b->buf++; /* Leave space in front of buffer */
3721 b->bufsiz--; /* Buffer is thus smaller */
3722 code = PerlIO_fill(f); /* Fetch some more */
3723 b->bufsiz++; /* Restore size for next time */
3724 b->buf--; /* Point at space */
3725 b->ptr = nl = b->buf; /* Which is what we hand
3727 b->posn--; /* Buffer starts here */
3728 *nl = 0xd; /* Fill in the CR */
3730 goto test; /* fill() call worked */
3732 * CR at EOF - just fall through
3734 /* Should we clear EOF though ??? */
3739 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3745 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3747 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3748 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3754 if (ptr == b->end && *c->nl == 0xd) {
3755 /* Defered CR at end of buffer case - we lied about count */
3767 * Test code - delete when it works ...
3769 IV flags = PerlIOBase(f)->flags;
3770 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3771 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3772 /* Defered CR at end of buffer case - we lied about count */
3778 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3779 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3787 * They have taken what we lied about
3795 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3799 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3801 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3802 return PerlIOBuf_write(aTHX_ f, vbuf, count);
3804 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3805 const STDCHAR *buf = (const STDCHAR *) vbuf;
3806 const STDCHAR *ebuf = buf + count;
3809 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3811 while (buf < ebuf) {
3812 STDCHAR *eptr = b->buf + b->bufsiz;
3813 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3814 while (buf < ebuf && b->ptr < eptr) {
3816 if ((b->ptr + 2) > eptr) {
3824 *(b->ptr)++ = 0xd; /* CR */
3825 *(b->ptr)++ = 0xa; /* LF */
3827 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3837 if (b->ptr >= eptr) {
3843 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3845 return (buf - (STDCHAR *) vbuf);
3850 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3852 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3857 return PerlIOBuf_flush(aTHX_ f);
3860 PerlIO_funcs PerlIO_crlf = {
3863 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3865 PerlIOBuf_popped, /* popped */
3870 PerlIOBuf_read, /* generic read works with ptr/cnt lies
3872 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3873 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3881 PerlIOBase_clearerr,
3882 PerlIOBase_setlinebuf,
3887 PerlIOCrlf_set_ptrcnt,
3891 /*--------------------------------------------------------------------------------------*/
3893 * mmap as "buffer" layer
3897 PerlIOBuf base; /* PerlIOBuf stuff */
3898 Mmap_t mptr; /* Mapped address */
3899 Size_t len; /* mapped length */
3900 STDCHAR *bbuf; /* malloced buffer if map fails */
3903 static size_t page_size = 0;
3906 PerlIOMmap_map(pTHX_ PerlIO *f)
3908 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3909 IV flags = PerlIOBase(f)->flags;
3913 if (flags & PERLIO_F_CANREAD) {
3914 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3915 int fd = PerlIO_fileno(f);
3917 code = Fstat(fd, &st);
3918 if (code == 0 && S_ISREG(st.st_mode)) {
3919 SSize_t len = st.st_size - b->posn;
3923 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3925 SETERRNO(0, SS$_NORMAL);
3926 # ifdef _SC_PAGESIZE
3927 page_size = sysconf(_SC_PAGESIZE);
3929 page_size = sysconf(_SC_PAGE_SIZE);
3931 if ((long) page_size < 0) {
3936 (void) SvUPGRADE(error, SVt_PV);
3937 msg = SvPVx(error, n_a);
3938 Perl_croak(aTHX_ "panic: sysconf: %s",
3943 "panic: sysconf: pagesize unknown");
3947 # ifdef HAS_GETPAGESIZE
3948 page_size = getpagesize();
3950 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3951 page_size = PAGESIZE; /* compiletime, bad */
3955 if ((IV) page_size <= 0)
3956 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3961 * This is a hack - should never happen - open should
3964 b->posn = PerlIO_tell(PerlIONext(f));
3966 posn = (b->posn / page_size) * page_size;
3967 len = st.st_size - posn;
3968 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3969 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3970 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3971 madvise(m->mptr, len, MADV_SEQUENTIAL);
3973 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3974 madvise(m->mptr, len, MADV_WILLNEED);
3976 PerlIOBase(f)->flags =
3977 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3978 b->end = ((STDCHAR *) m->mptr) + len;
3979 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3988 PerlIOBase(f)->flags =
3989 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3991 b->ptr = b->end = b->ptr;
4000 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4002 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4003 PerlIOBuf *b = &m->base;
4007 code = munmap(m->mptr, m->len);
4011 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4014 b->ptr = b->end = b->buf;
4015 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4021 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4023 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4024 PerlIOBuf *b = &m->base;
4025 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4027 * Already have a readbuffer in progress
4033 * We have a write buffer or flushed PerlIOBuf read buffer
4035 m->bbuf = b->buf; /* save it in case we need it again */
4036 b->buf = NULL; /* Clear to trigger below */
4039 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4042 * Map did not work - recover PerlIOBuf buffer if we have one
4047 b->ptr = b->end = b->buf;
4050 return PerlIOBuf_get_base(aTHX_ f);
4054 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4056 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4057 PerlIOBuf *b = &m->base;
4058 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4060 if (b->ptr && (b->ptr - count) >= b->buf
4061 && memEQ(b->ptr - count, vbuf, count)) {
4063 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4068 * Loose the unwritable mapped buffer
4072 * If flush took the "buffer" see if we have one from before
4074 if (!b->buf && m->bbuf)
4077 PerlIOBuf_get_base(aTHX_ f);
4081 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4085 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4087 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4088 PerlIOBuf *b = &m->base;
4089 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4091 * No, or wrong sort of, buffer
4094 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4098 * If unmap took the "buffer" see if we have one from before
4100 if (!b->buf && m->bbuf)
4103 PerlIOBuf_get_base(aTHX_ f);
4107 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4111 PerlIOMmap_flush(pTHX_ PerlIO *f)
4113 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4114 PerlIOBuf *b = &m->base;
4115 IV code = PerlIOBuf_flush(aTHX_ f);
4117 * Now we are "synced" at PerlIOBuf level
4124 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4129 * We seem to have a PerlIOBuf buffer which was not mapped
4130 * remember it in case we need one later
4139 PerlIOMmap_fill(pTHX_ PerlIO *f)
4141 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4142 IV code = PerlIO_flush(f);
4143 if (code == 0 && !b->buf) {
4144 code = PerlIOMmap_map(aTHX_ f);
4146 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4147 code = PerlIOBuf_fill(aTHX_ f);
4153 PerlIOMmap_close(pTHX_ PerlIO *f)
4155 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4156 PerlIOBuf *b = &m->base;
4157 IV code = PerlIO_flush(f);
4161 b->ptr = b->end = b->buf;
4163 if (PerlIOBuf_close(aTHX_ f) != 0)
4169 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4171 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4175 PerlIO_funcs PerlIO_mmap = {
4195 PerlIOBase_clearerr,
4196 PerlIOBase_setlinebuf,
4197 PerlIOMmap_get_base,
4201 PerlIOBuf_set_ptrcnt,
4204 #endif /* HAS_MMAP */
4207 Perl_PerlIO_stdin(pTHX)
4210 PerlIO_stdstreams(aTHX);
4212 return &PL_perlio[1];
4216 Perl_PerlIO_stdout(pTHX)
4219 PerlIO_stdstreams(aTHX);
4221 return &PL_perlio[2];
4225 Perl_PerlIO_stderr(pTHX)
4228 PerlIO_stdstreams(aTHX);
4230 return &PL_perlio[3];
4233 /*--------------------------------------------------------------------------------------*/
4236 PerlIO_getname(PerlIO *f, char *buf)
4241 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4243 name = fgetname(stdio, buf);
4245 Perl_croak(aTHX_ "Don't know how to get file name");
4251 /*--------------------------------------------------------------------------------------*/
4253 * Functions which can be called on any kind of PerlIO implemented in
4257 #undef PerlIO_fdopen
4259 PerlIO_fdopen(int fd, const char *mode)
4262 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4267 PerlIO_open(const char *path, const char *mode)
4270 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4271 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4274 #undef Perlio_reopen
4276 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4279 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4280 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4285 PerlIO_getc(PerlIO *f)
4289 SSize_t count = PerlIO_read(f, buf, 1);
4291 return (unsigned char) buf[0];
4296 #undef PerlIO_ungetc
4298 PerlIO_ungetc(PerlIO *f, int ch)
4303 if (PerlIO_unread(f, &buf, 1) == 1)
4311 PerlIO_putc(PerlIO *f, int ch)
4315 return PerlIO_write(f, &buf, 1);
4320 PerlIO_puts(PerlIO *f, const char *s)
4323 STRLEN len = strlen(s);
4324 return PerlIO_write(f, s, len);
4327 #undef PerlIO_rewind
4329 PerlIO_rewind(PerlIO *f)
4332 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4336 #undef PerlIO_vprintf
4338 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4341 SV *sv = newSVpvn("", 0);
4347 Perl_va_copy(ap, apc);
4348 sv_vcatpvf(sv, fmt, &apc);
4350 sv_vcatpvf(sv, fmt, &ap);
4353 wrote = PerlIO_write(f, s, len);
4358 #undef PerlIO_printf
4360 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4365 result = PerlIO_vprintf(f, fmt, ap);
4370 #undef PerlIO_stdoutf
4372 PerlIO_stdoutf(const char *fmt, ...)
4378 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4383 #undef PerlIO_tmpfile
4385 PerlIO_tmpfile(void)
4388 * I have no idea how portable mkstemp() is ...
4390 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4393 FILE *stdio = PerlSIO_tmpfile();
4396 PerlIOSelf(PerlIO_push
4397 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4398 "w+", Nullsv), PerlIOStdio);
4404 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4405 int fd = mkstemp(SvPVX(sv));
4408 f = PerlIO_fdopen(fd, "w+");
4410 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4412 PerlLIO_unlink(SvPVX(sv));
4422 #endif /* USE_SFIO */
4423 #endif /* PERLIO_IS_STDIO */
4425 /*======================================================================================*/
4427 * Now some functions in terms of above which may be needed even if we are
4428 * not in true PerlIO mode
4432 #undef PerlIO_setpos
4434 PerlIO_setpos(PerlIO *f, SV *pos)
4439 Off_t *posn = (Off_t *) SvPV(pos, len);
4440 if (f && len == sizeof(Off_t))
4441 return PerlIO_seek(f, *posn, SEEK_SET);
4443 SETERRNO(EINVAL, SS$_IVCHAN);
4447 #undef PerlIO_setpos
4449 PerlIO_setpos(PerlIO *f, SV *pos)
4454 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4455 if (f && len == sizeof(Fpos_t)) {
4456 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4457 return fsetpos64(f, fpos);
4459 return fsetpos(f, fpos);
4463 SETERRNO(EINVAL, SS$_IVCHAN);
4469 #undef PerlIO_getpos
4471 PerlIO_getpos(PerlIO *f, SV *pos)
4474 Off_t posn = PerlIO_tell(f);
4475 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4476 return (posn == (Off_t) - 1) ? -1 : 0;
4479 #undef PerlIO_getpos
4481 PerlIO_getpos(PerlIO *f, SV *pos)
4486 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4487 code = fgetpos64(f, &fpos);
4489 code = fgetpos(f, &fpos);
4491 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4496 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4499 vprintf(char *pat, char *args)
4501 _doprnt(pat, args, stdout);
4502 return 0; /* wrong, but perl doesn't use the return
4507 vfprintf(FILE *fd, char *pat, char *args)
4509 _doprnt(pat, args, fd);
4510 return 0; /* wrong, but perl doesn't use the return
4516 #ifndef PerlIO_vsprintf
4518 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4520 int val = vsprintf(s, fmt, ap);
4522 if (strlen(s) >= (STRLEN) n) {
4524 (void) PerlIO_puts(Perl_error_log,
4525 "panic: sprintf overflow - memory corrupted!\n");
4533 #ifndef PerlIO_sprintf
4535 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4540 result = PerlIO_vsprintf(s, n, fmt, ap);