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));
3131 b->ptr = b->end = b->buf;
3132 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3133 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3134 /* FIXME: Doing downstream flush may be sub-optimal see PerlIOBuf_fill() below */
3135 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3141 PerlIOBuf_fill(pTHX_ PerlIO *f)
3143 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3144 PerlIO *n = PerlIONext(f);
3147 * FIXME: doing the down-stream flush maybe sub-optimal if it causes
3148 * pre-read data in stdio buffer to be discarded.
3149 * However, skipping the flush also skips _our_ hosekeeping
3150 * and breaks tell tests. So we do the flush.
3152 if (PerlIO_flush(f) != 0)
3154 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3155 PerlIOBase_flush_linebuf(aTHX);
3158 PerlIO_get_base(f); /* allocate via vtable */
3160 b->ptr = b->end = b->buf;
3161 if (PerlIO_fast_gets(n)) {
3163 * Layer below is also buffered. We do _NOT_ want to call its
3164 * ->Read() because that will loop till it gets what we asked for
3165 * which may hang on a pipe etc. Instead take anything it has to
3166 * hand, or ask it to fill _once_.
3168 avail = PerlIO_get_cnt(n);
3170 avail = PerlIO_fill(n);
3172 avail = PerlIO_get_cnt(n);
3174 if (!PerlIO_error(n) && PerlIO_eof(n))
3179 STDCHAR *ptr = PerlIO_get_ptr(n);
3180 SSize_t cnt = avail;
3181 if (avail > (SSize_t)b->bufsiz)
3183 Copy(ptr, b->buf, avail, STDCHAR);
3184 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3188 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3192 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3194 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3197 b->end = b->buf + avail;
3198 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3203 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3205 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3206 if (PerlIOValid(f)) {
3209 return PerlIOBase_read(aTHX_ f, vbuf, count);
3215 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3217 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3218 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3221 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3226 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3228 * Buffer is already a read buffer, we can overwrite any chars
3229 * which have been read back to buffer start
3231 avail = (b->ptr - b->buf);
3235 * Buffer is idle, set it up so whole buffer is available for
3239 b->end = b->buf + avail;
3241 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3243 * Buffer extends _back_ from where we are now
3245 b->posn -= b->bufsiz;
3247 if (avail > (SSize_t) count) {
3249 * If we have space for more than count, just move count
3257 * In simple stdio-like ungetc() case chars will be already
3260 if (buf != b->ptr) {
3261 Copy(buf, b->ptr, avail, STDCHAR);
3265 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3269 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3275 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3277 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3278 const STDCHAR *buf = (const STDCHAR *) vbuf;
3282 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3285 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3286 if ((SSize_t) count < avail)
3288 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3289 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3304 Copy(buf, b->ptr, avail, STDCHAR);
3311 if (b->ptr >= (b->buf + b->bufsiz))
3314 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3320 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3323 if ((code = PerlIO_flush(f)) == 0) {
3324 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3325 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3326 code = PerlIO_seek(PerlIONext(f), offset, whence);
3328 b->posn = PerlIO_tell(PerlIONext(f));
3335 PerlIOBuf_tell(pTHX_ PerlIO *f)
3337 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3339 * b->posn is file position where b->buf was read, or will be written
3341 Off_t posn = b->posn;
3344 * If buffer is valid adjust position by amount in buffer
3346 posn += (b->ptr - b->buf);
3352 PerlIOBuf_popped(pTHX_ PerlIO *f)
3354 IV code = PerlIOBase_popped(aTHX_ f);
3355 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3356 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3360 b->ptr = b->end = b->buf;
3361 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3366 PerlIOBuf_close(pTHX_ PerlIO *f)
3368 IV code = PerlIOBase_close(aTHX_ f);
3369 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3370 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3374 b->ptr = b->end = b->buf;
3375 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3380 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3382 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3389 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3391 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3394 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3395 return (b->end - b->ptr);
3400 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3402 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3407 Newz('B',b->buf,b->bufsiz, STDCHAR);
3409 b->buf = (STDCHAR *) & b->oneword;
3410 b->bufsiz = sizeof(b->oneword);
3419 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3421 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3424 return (b->end - b->buf);
3428 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3430 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3434 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3435 assert(PerlIO_get_cnt(f) == cnt);
3436 assert(b->ptr >= b->buf);
3438 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3442 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3444 return PerlIOBase_dup(aTHX_ f, o, param, flags);
3449 PerlIO_funcs PerlIO_perlio = {
3469 PerlIOBase_clearerr,
3470 PerlIOBase_setlinebuf,
3475 PerlIOBuf_set_ptrcnt,
3478 /*--------------------------------------------------------------------------------------*/
3480 * Temp layer to hold unread chars when cannot do it any other way
3484 PerlIOPending_fill(pTHX_ PerlIO *f)
3487 * Should never happen
3494 PerlIOPending_close(pTHX_ PerlIO *f)
3497 * A tad tricky - flush pops us, then we close new top
3500 return PerlIO_close(f);
3504 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3507 * A tad tricky - flush pops us, then we seek new top
3510 return PerlIO_seek(f, offset, whence);
3515 PerlIOPending_flush(pTHX_ PerlIO *f)
3517 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3518 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3522 PerlIO_pop(aTHX_ f);
3527 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3533 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3538 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3540 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3541 PerlIOl *l = PerlIOBase(f);
3543 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3544 * etc. get muddled when it changes mid-string when we auto-pop.
3546 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3547 (PerlIOBase(PerlIONext(f))->
3548 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3553 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3555 SSize_t avail = PerlIO_get_cnt(f);
3557 if ((SSize_t)count < avail)
3560 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3561 if (got >= 0 && got < (SSize_t)count) {
3563 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3564 if (more >= 0 || got == 0)
3570 PerlIO_funcs PerlIO_pending = {
3574 PerlIOPending_pushed,
3585 PerlIOPending_close,
3586 PerlIOPending_flush,
3590 PerlIOBase_clearerr,
3591 PerlIOBase_setlinebuf,
3596 PerlIOPending_set_ptrcnt,
3601 /*--------------------------------------------------------------------------------------*/
3603 * crlf - translation On read translate CR,LF to "\n" we do this by
3604 * overriding ptr/cnt entries to hand back a line at a time and keeping a
3605 * record of which nl we "lied" about. On write translate "\n" to CR,LF
3609 PerlIOBuf base; /* PerlIOBuf stuff */
3610 STDCHAR *nl; /* Position of crlf we "lied" about in the
3615 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3618 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3619 code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3621 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3622 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3623 PerlIOBase(f)->flags);
3630 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3632 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3637 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3638 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3640 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3641 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3643 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3648 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3649 b->end = b->ptr = b->buf + b->bufsiz;
3650 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3651 b->posn -= b->bufsiz;
3653 while (count > 0 && b->ptr > b->buf) {
3656 if (b->ptr - 2 >= b->buf) {
3679 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3681 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3684 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3685 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3686 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3687 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3689 while (nl < b->end && *nl != 0xd)
3691 if (nl < b->end && *nl == 0xd) {
3693 if (nl + 1 < b->end) {
3700 * Not CR,LF but just CR
3708 * Blast - found CR as last char in buffer
3713 * They may not care, defer work as long as
3717 return (nl - b->ptr);
3721 b->ptr++; /* say we have read it as far as
3722 * flush() is concerned */
3723 b->buf++; /* Leave space in front of buffer */
3724 b->bufsiz--; /* Buffer is thus smaller */
3725 code = PerlIO_fill(f); /* Fetch some more */
3726 b->bufsiz++; /* Restore size for next time */
3727 b->buf--; /* Point at space */
3728 b->ptr = nl = b->buf; /* Which is what we hand
3730 b->posn--; /* Buffer starts here */
3731 *nl = 0xd; /* Fill in the CR */
3733 goto test; /* fill() call worked */
3735 * CR at EOF - just fall through
3737 /* Should we clear EOF though ??? */
3742 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3748 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3750 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3751 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3757 if (ptr == b->end && *c->nl == 0xd) {
3758 /* Defered CR at end of buffer case - we lied about count */
3770 * Test code - delete when it works ...
3772 IV flags = PerlIOBase(f)->flags;
3773 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3774 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3775 /* Defered CR at end of buffer case - we lied about count */
3781 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3782 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3790 * They have taken what we lied about
3798 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3802 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3804 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3805 return PerlIOBuf_write(aTHX_ f, vbuf, count);
3807 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3808 const STDCHAR *buf = (const STDCHAR *) vbuf;
3809 const STDCHAR *ebuf = buf + count;
3812 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3814 while (buf < ebuf) {
3815 STDCHAR *eptr = b->buf + b->bufsiz;
3816 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3817 while (buf < ebuf && b->ptr < eptr) {
3819 if ((b->ptr + 2) > eptr) {
3827 *(b->ptr)++ = 0xd; /* CR */
3828 *(b->ptr)++ = 0xa; /* LF */
3830 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3840 if (b->ptr >= eptr) {
3846 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3848 return (buf - (STDCHAR *) vbuf);
3853 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3855 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3860 return PerlIOBuf_flush(aTHX_ f);
3863 PerlIO_funcs PerlIO_crlf = {
3866 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3868 PerlIOBuf_popped, /* popped */
3873 PerlIOBuf_read, /* generic read works with ptr/cnt lies
3875 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3876 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3884 PerlIOBase_clearerr,
3885 PerlIOBase_setlinebuf,
3890 PerlIOCrlf_set_ptrcnt,
3894 /*--------------------------------------------------------------------------------------*/
3896 * mmap as "buffer" layer
3900 PerlIOBuf base; /* PerlIOBuf stuff */
3901 Mmap_t mptr; /* Mapped address */
3902 Size_t len; /* mapped length */
3903 STDCHAR *bbuf; /* malloced buffer if map fails */
3906 static size_t page_size = 0;
3909 PerlIOMmap_map(pTHX_ PerlIO *f)
3911 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3912 IV flags = PerlIOBase(f)->flags;
3916 if (flags & PERLIO_F_CANREAD) {
3917 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3918 int fd = PerlIO_fileno(f);
3920 code = Fstat(fd, &st);
3921 if (code == 0 && S_ISREG(st.st_mode)) {
3922 SSize_t len = st.st_size - b->posn;
3926 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3928 SETERRNO(0, SS$_NORMAL);
3929 # ifdef _SC_PAGESIZE
3930 page_size = sysconf(_SC_PAGESIZE);
3932 page_size = sysconf(_SC_PAGE_SIZE);
3934 if ((long) page_size < 0) {
3939 (void) SvUPGRADE(error, SVt_PV);
3940 msg = SvPVx(error, n_a);
3941 Perl_croak(aTHX_ "panic: sysconf: %s",
3946 "panic: sysconf: pagesize unknown");
3950 # ifdef HAS_GETPAGESIZE
3951 page_size = getpagesize();
3953 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3954 page_size = PAGESIZE; /* compiletime, bad */
3958 if ((IV) page_size <= 0)
3959 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3964 * This is a hack - should never happen - open should
3967 b->posn = PerlIO_tell(PerlIONext(f));
3969 posn = (b->posn / page_size) * page_size;
3970 len = st.st_size - posn;
3971 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3972 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3973 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3974 madvise(m->mptr, len, MADV_SEQUENTIAL);
3976 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3977 madvise(m->mptr, len, MADV_WILLNEED);
3979 PerlIOBase(f)->flags =
3980 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3981 b->end = ((STDCHAR *) m->mptr) + len;
3982 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3991 PerlIOBase(f)->flags =
3992 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3994 b->ptr = b->end = b->ptr;
4003 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4005 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4006 PerlIOBuf *b = &m->base;
4010 code = munmap(m->mptr, m->len);
4014 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4017 b->ptr = b->end = b->buf;
4018 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4024 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4026 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4027 PerlIOBuf *b = &m->base;
4028 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4030 * Already have a readbuffer in progress
4036 * We have a write buffer or flushed PerlIOBuf read buffer
4038 m->bbuf = b->buf; /* save it in case we need it again */
4039 b->buf = NULL; /* Clear to trigger below */
4042 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4045 * Map did not work - recover PerlIOBuf buffer if we have one
4050 b->ptr = b->end = b->buf;
4053 return PerlIOBuf_get_base(aTHX_ f);
4057 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4059 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4060 PerlIOBuf *b = &m->base;
4061 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4063 if (b->ptr && (b->ptr - count) >= b->buf
4064 && memEQ(b->ptr - count, vbuf, count)) {
4066 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4071 * Loose the unwritable mapped buffer
4075 * If flush took the "buffer" see if we have one from before
4077 if (!b->buf && m->bbuf)
4080 PerlIOBuf_get_base(aTHX_ f);
4084 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4088 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4090 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4091 PerlIOBuf *b = &m->base;
4092 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4094 * No, or wrong sort of, buffer
4097 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4101 * If unmap took the "buffer" see if we have one from before
4103 if (!b->buf && m->bbuf)
4106 PerlIOBuf_get_base(aTHX_ f);
4110 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4114 PerlIOMmap_flush(pTHX_ PerlIO *f)
4116 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4117 PerlIOBuf *b = &m->base;
4118 IV code = PerlIOBuf_flush(aTHX_ f);
4120 * Now we are "synced" at PerlIOBuf level
4127 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4132 * We seem to have a PerlIOBuf buffer which was not mapped
4133 * remember it in case we need one later
4142 PerlIOMmap_fill(pTHX_ PerlIO *f)
4144 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4145 IV code = PerlIO_flush(f);
4146 if (code == 0 && !b->buf) {
4147 code = PerlIOMmap_map(aTHX_ f);
4149 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4150 code = PerlIOBuf_fill(aTHX_ f);
4156 PerlIOMmap_close(pTHX_ PerlIO *f)
4158 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4159 PerlIOBuf *b = &m->base;
4160 IV code = PerlIO_flush(f);
4164 b->ptr = b->end = b->buf;
4166 if (PerlIOBuf_close(aTHX_ f) != 0)
4172 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4174 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4178 PerlIO_funcs PerlIO_mmap = {
4198 PerlIOBase_clearerr,
4199 PerlIOBase_setlinebuf,
4200 PerlIOMmap_get_base,
4204 PerlIOBuf_set_ptrcnt,
4207 #endif /* HAS_MMAP */
4210 Perl_PerlIO_stdin(pTHX)
4213 PerlIO_stdstreams(aTHX);
4215 return &PL_perlio[1];
4219 Perl_PerlIO_stdout(pTHX)
4222 PerlIO_stdstreams(aTHX);
4224 return &PL_perlio[2];
4228 Perl_PerlIO_stderr(pTHX)
4231 PerlIO_stdstreams(aTHX);
4233 return &PL_perlio[3];
4236 /*--------------------------------------------------------------------------------------*/
4239 PerlIO_getname(PerlIO *f, char *buf)
4244 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4246 name = fgetname(stdio, buf);
4248 Perl_croak(aTHX_ "Don't know how to get file name");
4254 /*--------------------------------------------------------------------------------------*/
4256 * Functions which can be called on any kind of PerlIO implemented in
4260 #undef PerlIO_fdopen
4262 PerlIO_fdopen(int fd, const char *mode)
4265 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4270 PerlIO_open(const char *path, const char *mode)
4273 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4274 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4277 #undef Perlio_reopen
4279 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4282 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4283 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4288 PerlIO_getc(PerlIO *f)
4292 SSize_t count = PerlIO_read(f, buf, 1);
4294 return (unsigned char) buf[0];
4299 #undef PerlIO_ungetc
4301 PerlIO_ungetc(PerlIO *f, int ch)
4306 if (PerlIO_unread(f, &buf, 1) == 1)
4314 PerlIO_putc(PerlIO *f, int ch)
4318 return PerlIO_write(f, &buf, 1);
4323 PerlIO_puts(PerlIO *f, const char *s)
4326 STRLEN len = strlen(s);
4327 return PerlIO_write(f, s, len);
4330 #undef PerlIO_rewind
4332 PerlIO_rewind(PerlIO *f)
4335 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4339 #undef PerlIO_vprintf
4341 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4344 SV *sv = newSVpvn("", 0);
4350 Perl_va_copy(ap, apc);
4351 sv_vcatpvf(sv, fmt, &apc);
4353 sv_vcatpvf(sv, fmt, &ap);
4356 wrote = PerlIO_write(f, s, len);
4361 #undef PerlIO_printf
4363 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4368 result = PerlIO_vprintf(f, fmt, ap);
4373 #undef PerlIO_stdoutf
4375 PerlIO_stdoutf(const char *fmt, ...)
4381 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4386 #undef PerlIO_tmpfile
4388 PerlIO_tmpfile(void)
4391 * I have no idea how portable mkstemp() is ...
4393 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4396 FILE *stdio = PerlSIO_tmpfile();
4399 PerlIOSelf(PerlIO_push
4400 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4401 "w+", Nullsv), PerlIOStdio);
4407 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4408 int fd = mkstemp(SvPVX(sv));
4411 f = PerlIO_fdopen(fd, "w+");
4413 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4415 PerlLIO_unlink(SvPVX(sv));
4425 #endif /* USE_SFIO */
4426 #endif /* PERLIO_IS_STDIO */
4428 /*======================================================================================*/
4430 * Now some functions in terms of above which may be needed even if we are
4431 * not in true PerlIO mode
4435 #undef PerlIO_setpos
4437 PerlIO_setpos(PerlIO *f, SV *pos)
4442 Off_t *posn = (Off_t *) SvPV(pos, len);
4443 if (f && len == sizeof(Off_t))
4444 return PerlIO_seek(f, *posn, SEEK_SET);
4446 SETERRNO(EINVAL, SS$_IVCHAN);
4450 #undef PerlIO_setpos
4452 PerlIO_setpos(PerlIO *f, SV *pos)
4457 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4458 if (f && len == sizeof(Fpos_t)) {
4459 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4460 return fsetpos64(f, fpos);
4462 return fsetpos(f, fpos);
4466 SETERRNO(EINVAL, SS$_IVCHAN);
4472 #undef PerlIO_getpos
4474 PerlIO_getpos(PerlIO *f, SV *pos)
4477 Off_t posn = PerlIO_tell(f);
4478 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4479 return (posn == (Off_t) - 1) ? -1 : 0;
4482 #undef PerlIO_getpos
4484 PerlIO_getpos(PerlIO *f, SV *pos)
4489 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4490 code = fgetpos64(f, &fpos);
4492 code = fgetpos(f, &fpos);
4494 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4499 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4502 vprintf(char *pat, char *args)
4504 _doprnt(pat, args, stdout);
4505 return 0; /* wrong, but perl doesn't use the return
4510 vfprintf(FILE *fd, char *pat, char *args)
4512 _doprnt(pat, args, fd);
4513 return 0; /* wrong, but perl doesn't use the return
4519 #ifndef PerlIO_vsprintf
4521 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4523 int val = vsprintf(s, fmt, ap);
4525 if (strlen(s) >= (STRLEN) n) {
4527 (void) PerlIO_puts(Perl_error_log,
4528 "panic: sprintf overflow - memory corrupted!\n");
4536 #ifndef PerlIO_sprintf
4538 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4543 result = PerlIO_vsprintf(s, n, fmt, ap);