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
162 || strEQ(names, ":crlf")
163 || strEQ(names, ":raw")
164 || strEQ(names, ":bytes")
168 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
176 PerlIO_destruct(pTHX)
181 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
186 return perlsio_binmode(fp, iotype, mode);
191 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
196 #ifdef PERL_IMPLICIT_SYS
197 return PerlSIO_fdupopen(f);
200 return win32_fdupopen(f);
203 int fd = PerlLIO_dup(PerlIO_fileno(f));
206 int omode = fcntl(fd, F_GETFL);
208 omode = djgpp_get_stream_mode(f);
210 PerlIO_intmode2str(omode,mode,NULL);
211 /* the r+ is a hack */
212 return PerlIO_fdopen(fd, mode);
217 SETERRNO(EBADF, SS$_IVCHAN);
227 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
231 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
232 int imode, int perm, PerlIO *old, int narg, SV **args)
236 Perl_croak(aTHX_ "More than one argument to open");
238 if (*args == &PL_sv_undef)
239 return PerlIO_tmpfile();
241 char *name = SvPV_nolen(*args);
243 fd = PerlLIO_open3(name, imode, perm);
245 return PerlIO_fdopen(fd, (char *) mode + 1);
248 return PerlIO_reopen(name, mode, old);
251 return PerlIO_open(name, mode);
256 return PerlIO_fdopen(fd, (char *) mode);
261 XS(XS_PerlIO__Layer__find)
265 Perl_croak(aTHX_ "Usage class->find(name[,load])");
267 char *name = SvPV_nolen(ST(1));
268 ST(0) = (strEQ(name, "crlf")
269 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
276 Perl_boot_core_PerlIO(pTHX)
278 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
284 #ifdef PERLIO_IS_STDIO
290 * Does nothing (yet) except force this file to be included in perl
291 * binary. That allows this file to force inclusion of other functions
292 * that may be required by loadable extensions e.g. for
293 * FileHandle::tmpfile
297 #undef PerlIO_tmpfile
304 #else /* PERLIO_IS_STDIO */
312 * This section is just to make sure these functions get pulled in from
316 #undef PerlIO_tmpfile
327 * Force this file to be included in perl binary. Which allows this
328 * file to force inclusion of other functions that may be required by
329 * loadable extensions e.g. for FileHandle::tmpfile
333 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
334 * results in a lot of lseek()s to regular files and lot of small
337 sfset(sfstdout, SF_SHARE, 0);
341 PerlIO_importFILE(FILE *stdio, int fl)
343 int fd = fileno(stdio);
344 PerlIO *r = PerlIO_fdopen(fd, "r+");
349 PerlIO_findFILE(PerlIO *pio)
351 int fd = PerlIO_fileno(pio);
352 FILE *f = fdopen(fd, "r+");
354 if (!f && errno == EINVAL)
356 if (!f && errno == EINVAL)
363 /*======================================================================================*/
365 * Implement all the PerlIO interface ourselves.
371 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
378 #include <sys/mman.h>
382 void PerlIO_debug(const char *fmt, ...)
383 __attribute__ ((format(__printf__, 1, 2)));
386 PerlIO_debug(const char *fmt, ...)
393 char *s = PerlEnv_getenv("PERLIO_DEBUG");
395 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
402 /* Use fixed buffer as sv_catpvf etc. needs SVs */
406 s = CopFILE(PL_curcop);
409 sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
410 len = strlen(buffer);
411 vsprintf(buffer+len, fmt, ap);
412 PerlLIO_write(dbg, buffer, strlen(buffer));
414 SV *sv = newSVpvn("", 0);
417 s = CopFILE(PL_curcop);
420 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
421 (IV) CopLINE(PL_curcop));
422 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
425 PerlLIO_write(dbg, s, len);
432 /*--------------------------------------------------------------------------------------*/
435 * Inner level routines
439 * Table of pointers to the PerlIO structs (malloc'ed)
441 #define PERLIO_TABLE_SIZE 64
444 PerlIO_allocate(pTHX)
447 * Find a free slot in the table, allocating new table as necessary
452 while ((f = *last)) {
454 last = (PerlIO **) (f);
455 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
461 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
469 #undef PerlIO_fdupopen
471 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
473 if (PerlIOValid(f)) {
474 PerlIO_funcs *tab = PerlIOBase(f)->tab;
476 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
477 new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
481 SETERRNO(EBADF, SS$_IVCHAN);
487 PerlIO_cleantable(pTHX_ PerlIO **tablep)
489 PerlIO *table = *tablep;
492 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
493 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
494 PerlIO *f = table + i;
506 PerlIO_list_alloc(pTHX)
509 Newz('L', list, 1, PerlIO_list_t);
515 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
518 if (--list->refcnt == 0) {
521 for (i = 0; i < list->cur; i++) {
522 if (list->array[i].arg)
523 SvREFCNT_dec(list->array[i].arg);
525 Safefree(list->array);
533 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
536 if (list->cur >= list->len) {
539 Renew(list->array, list->len, PerlIO_pair_t);
541 New('l', list->array, list->len, PerlIO_pair_t);
543 p = &(list->array[list->cur++]);
545 if ((p->arg = arg)) {
551 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
553 PerlIO_list_t *list = (PerlIO_list_t *) NULL;
556 list = PerlIO_list_alloc(aTHX);
557 for (i=0; i < proto->cur; i++) {
559 if (proto->array[i].arg)
560 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
561 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
568 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
571 PerlIO **table = &proto->Iperlio;
574 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
575 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
576 PerlIO_allocate(aTHX); /* root slot is never used */
577 PerlIO_debug("Clone %p from %p\n",aTHX,proto);
578 while ((f = *table)) {
580 table = (PerlIO **) (f++);
581 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
583 (void) fp_dup(f, 0, param);
592 PerlIO_destruct(pTHX)
594 PerlIO **table = &PL_perlio;
597 PerlIO_debug("Destruct %p\n",aTHX);
599 while ((f = *table)) {
601 table = (PerlIO **) (f++);
602 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
606 if (l->tab->kind & PERLIO_K_DESTRUCT) {
607 PerlIO_debug("Destruct popping %s\n", l->tab->name);
621 PerlIO_pop(pTHX_ PerlIO *f)
625 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
626 if (l->tab->Popped) {
628 * If popped returns non-zero do not free its layer structure
629 * it has either done so itself, or it is shared and still in
632 if ((*l->tab->Popped) (aTHX_ f) != 0)
640 /*--------------------------------------------------------------------------------------*/
642 * XS Interface for perl code
646 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
649 if ((SSize_t) len <= 0)
651 for (i = 0; i < PL_known_layers->cur; i++) {
652 PerlIO_funcs *f = PL_known_layers->array[i].funcs;
653 if (memEQ(f->name, name, len)) {
654 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
658 if (load && PL_subname && PL_def_layerlist
659 && PL_def_layerlist->cur >= 2) {
660 SV *pkgsv = newSVpvn("PerlIO", 6);
661 SV *layer = newSVpvn(name, len);
664 * The two SVs are magically freed by load_module
666 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
668 return PerlIO_find_layer(aTHX_ name, len, 0);
670 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
674 #ifdef USE_ATTRIBUTES_FOR_PERLIO
677 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
680 IO *io = GvIOn((GV *) SvRV(sv));
681 PerlIO *ifp = IoIFP(io);
682 PerlIO *ofp = IoOFP(io);
683 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
689 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
692 IO *io = GvIOn((GV *) SvRV(sv));
693 PerlIO *ifp = IoIFP(io);
694 PerlIO *ofp = IoOFP(io);
695 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
701 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
703 Perl_warn(aTHX_ "clear %" SVf, sv);
708 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
710 Perl_warn(aTHX_ "free %" SVf, sv);
714 MGVTBL perlio_vtab = {
722 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
725 SV *sv = SvRV(ST(1));
730 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
732 mg = mg_find(sv, PERL_MAGIC_ext);
733 mg->mg_virtual = &perlio_vtab;
735 Perl_warn(aTHX_ "attrib %" SVf, sv);
736 for (i = 2; i < items; i++) {
738 const char *name = SvPV(ST(i), len);
739 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
741 av_push(av, SvREFCNT_inc(layer));
752 #endif /* USE_ATTIBUTES_FOR_PERLIO */
755 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
757 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
758 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
762 XS(XS_PerlIO__Layer__find)
766 Perl_croak(aTHX_ "Usage class->find(name[,load])");
769 char *name = SvPV(ST(1), len);
770 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
771 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
773 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
780 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
782 if (!PL_known_layers)
783 PL_known_layers = PerlIO_list_alloc(aTHX);
784 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
785 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
789 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
792 const char *s = names;
794 while (isSPACE(*s) || *s == ':')
799 const char *as = Nullch;
801 if (!isIDFIRST(*s)) {
803 * Message is consistent with how attribute lists are
804 * passed. Even though this means "foo : : bar" is
805 * seen as an invalid separator character.
807 char q = ((*s == '\'') ? '"' : '\'');
808 if (ckWARN(WARN_LAYER))
809 Perl_warner(aTHX_ packWARN(WARN_LAYER),
810 "perlio: invalid separator character %c%c%c in layer specification list %s",
812 SETERRNO(EINVAL, LIB$_INVARG);
817 } while (isALNUM(*e));
833 * It's a nul terminated string, not allowed
834 * to \ the terminating null. Anything other
835 * character is passed over.
845 if (ckWARN(WARN_LAYER))
846 Perl_warner(aTHX_ packWARN(WARN_LAYER),
847 "perlio: argument list not closed for layer \"%.*s\"",
859 bool warn_layer = ckWARN(WARN_LAYER);
860 PerlIO_funcs *layer =
861 PerlIO_find_layer(aTHX_ s, llen, 1);
863 PerlIO_list_push(aTHX_ av, layer,
870 Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"",
883 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
885 PerlIO_funcs *tab = &PerlIO_perlio;
886 #ifdef PERLIO_USING_CRLF
889 if (PerlIO_stdio.Set_ptrcnt)
892 PerlIO_debug("Pushing %s\n", tab->name);
893 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
898 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
900 return av->array[n].arg;
904 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
906 if (n >= 0 && n < av->cur) {
907 PerlIO_debug("Layer %" IVdf " is %s\n", n,
908 av->array[n].funcs->name);
909 return av->array[n].funcs;
912 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
917 PerlIO_default_layers(pTHX)
919 if (!PL_def_layerlist) {
920 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
921 PerlIO_funcs *osLayer = &PerlIO_unix;
922 PL_def_layerlist = PerlIO_list_alloc(aTHX);
923 PerlIO_define_layer(aTHX_ & PerlIO_unix);
924 #if defined(WIN32) && !defined(UNDER_CE)
925 PerlIO_define_layer(aTHX_ & PerlIO_win32);
927 osLayer = &PerlIO_win32;
930 PerlIO_define_layer(aTHX_ & PerlIO_raw);
931 PerlIO_define_layer(aTHX_ & PerlIO_perlio);
932 PerlIO_define_layer(aTHX_ & PerlIO_stdio);
933 PerlIO_define_layer(aTHX_ & PerlIO_crlf);
935 PerlIO_define_layer(aTHX_ & PerlIO_mmap);
937 PerlIO_define_layer(aTHX_ & PerlIO_utf8);
938 PerlIO_define_layer(aTHX_ & PerlIO_byte);
939 PerlIO_list_push(aTHX_ PL_def_layerlist,
940 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
943 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
946 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
949 if (PL_def_layerlist->cur < 2) {
950 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
952 return PL_def_layerlist;
956 Perl_boot_core_PerlIO(pTHX)
958 #ifdef USE_ATTRIBUTES_FOR_PERLIO
959 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
962 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
966 PerlIO_default_layer(pTHX_ I32 n)
968 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
971 return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
974 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
975 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
978 PerlIO_stdstreams(pTHX)
981 PerlIO_allocate(aTHX);
982 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
983 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
984 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
989 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
992 Newc('L',l,tab->size,char,PerlIOl);
994 Zero(l, tab->size, char);
998 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
999 (mode) ? mode : "(Null)", (void*)arg);
1000 if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
1001 PerlIO_pop(aTHX_ f);
1009 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1011 PerlIO_pop(aTHX_ f);
1014 PerlIO_pop(aTHX_ f);
1021 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1024 * Remove the dummy layer
1026 PerlIO_pop(aTHX_ f);
1028 * Pop back to bottom layer
1030 if (PerlIOValid(f)) {
1032 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
1033 if (*PerlIONext(f)) {
1034 PerlIO_pop(aTHX_ f);
1038 * Nothing bellow - push unix on top then remove it
1040 if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
1041 PerlIO_pop(aTHX_ PerlIONext(f));
1046 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1053 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1054 PerlIO_list_t *layers, IV n, IV max)
1058 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1060 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1071 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1075 PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1076 code = PerlIO_parse_layers(aTHX_ layers, names);
1078 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1080 PerlIO_list_free(aTHX_ layers);
1086 /*--------------------------------------------------------------------------------------*/
1088 * Given the abstraction above the public API functions
1092 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1094 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1095 (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1096 (names) ? names : "(Null)");
1098 /* Do not flush etc. if (e.g.) switching encodings.
1099 if a pushed layer knows it needs to flush lower layers
1100 (for example :unix which is never going to call them)
1101 it can do the flush when it is pushed.
1103 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1107 /* Turn off UTF-8-ness, to undo UTF-8 locale effects
1108 This may be too simplistic!
1110 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1112 /* FIXME?: Looking down the layer stack seems wrong,
1113 but is a way of reaching past (say) an encoding layer
1114 to flip CRLF-ness of the layer(s) below
1116 #ifdef PERLIO_USING_CRLF
1117 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1118 O_BINARY so we can look for it in mode.
1120 if (!(mode & O_BINARY)) {
1123 /* Perhaps we should turn on bottom-most aware layer
1124 e.g. Ilya's idea that UNIX TTY could serve
1126 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1127 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1128 /* Not in text mode - flush any pending stuff and flip it */
1130 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1132 /* Only need to turn it on in one layer so we are done */
1137 /* Not finding a CRLF aware layer presumably means we are binary
1138 which is not what was requested - so we failed
1139 We _could_ push :crlf layer but so could caller
1144 /* Either asked for BINMODE or that is normal on this platform
1145 see if any CRLF aware layers are present and turn off the flag
1146 and possibly remove layer.
1149 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1150 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1151 /* In text mode - flush any pending stuff and flip it */
1153 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
1154 #ifndef PERLIO_USING_CRLF
1155 /* CRLF is unusual case - if this is just the :crlf layer pop it */
1156 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
1157 PerlIO_pop(aTHX_ f);
1160 /* Normal case is only one layer doing this, so exit on first
1161 abnormal case can always do multiple binmode calls
1173 PerlIO__close(pTHX_ PerlIO *f)
1176 return (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1178 SETERRNO(EBADF, SS$_IVCHAN);
1184 Perl_PerlIO_close(pTHX_ PerlIO *f)
1187 if (PerlIOValid(f)) {
1188 code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1190 PerlIO_pop(aTHX_ f);
1197 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1200 return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
1202 SETERRNO(EBADF, SS$_IVCHAN);
1208 PerlIO_context_layers(pTHX_ const char *mode)
1210 const char *type = NULL;
1212 * Need to supply default layer info from open.pm
1215 SV *layers = PL_curcop->cop_io;
1218 type = SvPV(layers, len);
1219 if (type && mode[0] != 'r') {
1221 * Skip to write part
1223 const char *s = strchr(type, 0);
1224 if (s && (STRLEN)(s - type) < len) {
1233 static PerlIO_funcs *
1234 PerlIO_layer_from_ref(pTHX_ SV *sv)
1237 * For any scalar type load the handler which is bundled with perl
1239 if (SvTYPE(sv) < SVt_PVAV)
1240 return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1243 * For other types allow if layer is known but don't try and load it
1245 switch (SvTYPE(sv)) {
1247 return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1249 return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1251 return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1253 return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1259 PerlIO_resolve_layers(pTHX_ const char *layers,
1260 const char *mode, int narg, SV **args)
1262 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1265 PerlIO_stdstreams(aTHX);
1269 * If it is a reference but not an object see if we have a handler
1272 if (SvROK(arg) && !sv_isobject(arg)) {
1273 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1275 def = PerlIO_list_alloc(aTHX);
1276 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1280 * Don't fail if handler cannot be found :Via(...) etc. may do
1281 * something sensible else we will just stringfy and open
1287 layers = PerlIO_context_layers(aTHX_ mode);
1288 if (layers && *layers) {
1292 av = PerlIO_list_alloc(aTHX);
1293 for (i = 0; i < def->cur; i++) {
1294 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1301 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1305 PerlIO_list_free(aTHX_ av);
1306 return (PerlIO_list_t *) NULL;
1317 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1318 int imode, int perm, PerlIO *f, int narg, SV **args)
1320 if (!f && narg == 1 && *args == &PL_sv_undef) {
1321 if ((f = PerlIO_tmpfile())) {
1323 layers = PerlIO_context_layers(aTHX_ mode);
1324 if (layers && *layers)
1325 PerlIO_apply_layers(aTHX_ f, mode, layers);
1329 PerlIO_list_t *layera = NULL;
1331 PerlIO_funcs *tab = NULL;
1332 if (PerlIOValid(f)) {
1334 * This is "reopen" - it is not tested as perl does not use it
1338 layera = PerlIO_list_alloc(aTHX);
1340 SV *arg = (l->tab->Getarg)
1341 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1343 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1344 l = *PerlIONext(&l);
1348 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1354 * Start at "top" of layer stack
1356 n = layera->cur - 1;
1358 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1367 * Found that layer 'n' can do opens - call it
1369 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1370 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1372 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1373 tab->name, layers, mode, fd, imode, perm,
1374 (void*)f, narg, (void*)args);
1375 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1378 if (n + 1 < layera->cur) {
1380 * More layers above the one that we used to open -
1383 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1384 /* If pushing layers fails close the file */
1391 PerlIO_list_free(aTHX_ layera);
1398 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1401 return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
1403 SETERRNO(EBADF, SS$_IVCHAN);
1409 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1412 return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
1414 SETERRNO(EBADF, SS$_IVCHAN);
1420 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1423 return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
1425 SETERRNO(EBADF, SS$_IVCHAN);
1431 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1434 return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
1436 SETERRNO(EBADF, SS$_IVCHAN);
1442 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1445 return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
1447 SETERRNO(EBADF, SS$_IVCHAN);
1453 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1457 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1458 if (tab && tab->Flush) {
1459 return (*tab->Flush) (aTHX_ f);
1462 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
1463 SETERRNO(EBADF, SS$_IVCHAN);
1468 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1469 SETERRNO(EBADF, SS$_IVCHAN);
1475 * Is it good API design to do flush-all on NULL, a potentially
1476 * errorneous input? Maybe some magical value (PerlIO*
1477 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1478 * things on fflush(NULL), but should we be bound by their design
1481 PerlIO **table = &PL_perlio;
1483 while ((f = *table)) {
1485 table = (PerlIO **) (f++);
1486 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1487 if (*f && PerlIO_flush(f) != 0)
1497 PerlIOBase_flush_linebuf(pTHX)
1499 PerlIO **table = &PL_perlio;
1501 while ((f = *table)) {
1503 table = (PerlIO **) (f++);
1504 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1507 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1508 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1516 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1519 return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
1521 SETERRNO(EBADF, SS$_IVCHAN);
1527 PerlIO_isutf8(PerlIO *f)
1530 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1532 SETERRNO(EBADF, SS$_IVCHAN);
1538 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1541 return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
1543 SETERRNO(EBADF, SS$_IVCHAN);
1549 Perl_PerlIO_error(pTHX_ PerlIO *f)
1552 return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
1554 SETERRNO(EBADF, SS$_IVCHAN);
1560 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1563 (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
1565 SETERRNO(EBADF, SS$_IVCHAN);
1569 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1572 (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
1574 SETERRNO(EBADF, SS$_IVCHAN);
1578 PerlIO_has_base(PerlIO *f)
1580 if (PerlIOValid(f)) {
1581 return (PerlIOBase(f)->tab->Get_base != NULL);
1587 PerlIO_fast_gets(PerlIO *f)
1589 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1590 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1591 return (tab->Set_ptrcnt != NULL);
1597 PerlIO_has_cntptr(PerlIO *f)
1599 if (PerlIOValid(f)) {
1600 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1601 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1607 PerlIO_canset_cnt(PerlIO *f)
1609 if (PerlIOValid(f)) {
1610 PerlIOl *l = PerlIOBase(f);
1611 return (l->tab->Set_ptrcnt != NULL);
1617 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1620 return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
1625 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1628 return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
1633 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1635 if (PerlIOValid(f)) {
1636 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1637 if (tab->Get_ptr == NULL)
1639 return (*tab->Get_ptr) (aTHX_ f);
1645 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1647 if (PerlIOValid(f)) {
1648 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1649 if (tab->Get_cnt == NULL)
1651 return (*tab->Get_cnt) (aTHX_ f);
1657 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1659 if (PerlIOValid(f)) {
1660 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
1665 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1667 if (PerlIOValid(f)) {
1668 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1669 if (tab->Set_ptrcnt == NULL) {
1670 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1672 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
1676 /*--------------------------------------------------------------------------------------*/
1678 * utf8 and raw dummy layers
1682 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1684 if (*PerlIONext(f)) {
1685 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1686 PerlIO_pop(aTHX_ f);
1687 if (tab->kind & PERLIO_K_UTF8)
1688 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1690 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1696 PerlIO_funcs PerlIO_utf8 = {
1699 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1717 NULL, /* get_base */
1718 NULL, /* get_bufsiz */
1721 NULL, /* set_ptrcnt */
1724 PerlIO_funcs PerlIO_byte = {
1745 NULL, /* get_base */
1746 NULL, /* get_bufsiz */
1749 NULL, /* set_ptrcnt */
1753 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1754 IV n, const char *mode, int fd, int imode, int perm,
1755 PerlIO *old, int narg, SV **args)
1757 PerlIO_funcs *tab = PerlIO_default_btm();
1758 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1762 PerlIO_funcs PerlIO_raw = {
1783 NULL, /* get_base */
1784 NULL, /* get_bufsiz */
1787 NULL, /* set_ptrcnt */
1789 /*--------------------------------------------------------------------------------------*/
1790 /*--------------------------------------------------------------------------------------*/
1792 * "Methods" of the "base class"
1796 PerlIOBase_fileno(pTHX_ PerlIO *f)
1798 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1802 PerlIO_modestr(PerlIO *f, char *buf)
1805 IV flags = PerlIOBase(f)->flags;
1806 if (flags & PERLIO_F_APPEND) {
1808 if (flags & PERLIO_F_CANREAD) {
1812 else if (flags & PERLIO_F_CANREAD) {
1814 if (flags & PERLIO_F_CANWRITE)
1817 else if (flags & PERLIO_F_CANWRITE) {
1819 if (flags & PERLIO_F_CANREAD) {
1823 #ifdef PERLIO_USING_CRLF
1824 if (!(flags & PERLIO_F_CRLF))
1832 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1834 PerlIOl *l = PerlIOBase(f);
1836 const char *omode = mode;
1839 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1840 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1841 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1842 if (tab->Set_ptrcnt != NULL)
1843 l->flags |= PERLIO_F_FASTGETS;
1845 if (*mode == '#' || *mode == 'I')
1849 l->flags |= PERLIO_F_CANREAD;
1852 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1855 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1858 SETERRNO(EINVAL, LIB$_INVARG);
1864 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1867 l->flags &= ~PERLIO_F_CRLF;
1870 l->flags |= PERLIO_F_CRLF;
1873 SETERRNO(EINVAL, LIB$_INVARG);
1880 l->flags |= l->next->flags &
1881 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1886 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1887 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1888 l->flags, PerlIO_modestr(f, temp));
1894 PerlIOBase_popped(pTHX_ PerlIO *f)
1900 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1903 * Save the position as current head considers it
1905 Off_t old = PerlIO_tell(f);
1907 PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1908 PerlIOSelf(f, PerlIOBuf)->posn = old;
1909 done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
1914 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1916 STDCHAR *buf = (STDCHAR *) vbuf;
1918 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1921 SSize_t avail = PerlIO_get_cnt(f);
1924 take = ((SSize_t)count < avail) ? count : avail;
1926 STDCHAR *ptr = PerlIO_get_ptr(f);
1927 Copy(ptr, buf, take, STDCHAR);
1928 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1932 if (count > 0 && avail <= 0) {
1933 if (PerlIO_fill(f) != 0)
1937 return (buf - (STDCHAR *) vbuf);
1943 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
1949 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
1955 PerlIOBase_close(pTHX_ PerlIO *f)
1958 PerlIO *n = PerlIONext(f);
1959 if (PerlIO_flush(f) != 0)
1961 if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0)
1963 PerlIOBase(f)->flags &=
1964 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1969 PerlIOBase_eof(pTHX_ PerlIO *f)
1971 if (PerlIOValid(f)) {
1972 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1978 PerlIOBase_error(pTHX_ PerlIO *f)
1980 if (PerlIOValid(f)) {
1981 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1987 PerlIOBase_clearerr(pTHX_ PerlIO *f)
1989 if (PerlIOValid(f)) {
1990 PerlIO *n = PerlIONext(f);
1991 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
1998 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2000 if (PerlIOValid(f)) {
2001 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2006 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2012 return sv_dup(arg, param);
2015 return newSVsv(arg);
2018 return newSVsv(arg);
2023 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2025 PerlIO *nexto = PerlIONext(o);
2026 if (PerlIOValid(nexto)) {
2027 PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
2028 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2031 PerlIO_funcs *self = PerlIOBase(o)->tab;
2034 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2035 self->name, (void*)f, (void*)o, (void*)param);
2037 arg = (*self->Getarg)(aTHX_ o,param,flags);
2039 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2047 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2049 perl_mutex PerlIO_mutex;
2051 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2056 /* Place holder for stdstreams call ??? */
2058 MUTEX_INIT(&PerlIO_mutex);
2063 PerlIOUnix_refcnt_inc(int fd)
2065 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2067 MUTEX_LOCK(&PerlIO_mutex);
2069 PerlIO_fd_refcnt[fd]++;
2070 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2072 MUTEX_UNLOCK(&PerlIO_mutex);
2078 PerlIOUnix_refcnt_dec(int fd)
2081 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2083 MUTEX_LOCK(&PerlIO_mutex);
2085 cnt = --PerlIO_fd_refcnt[fd];
2086 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2088 MUTEX_UNLOCK(&PerlIO_mutex);
2095 PerlIO_cleanup(pTHX)
2099 PerlIO_debug("Cleanup layers for %p\n",aTHX);
2101 PerlIO_debug("Cleanup layers\n");
2103 /* Raise STDIN..STDERR refcount so we don't close them */
2104 for (i=0; i < 3; i++)
2105 PerlIOUnix_refcnt_inc(i);
2106 PerlIO_cleantable(aTHX_ &PL_perlio);
2107 /* Restore STDIN..STDERR refcount */
2108 for (i=0; i < 3; i++)
2109 PerlIOUnix_refcnt_dec(i);
2111 if (PL_known_layers) {
2112 PerlIO_list_free(aTHX_ PL_known_layers);
2113 PL_known_layers = NULL;
2115 if(PL_def_layerlist) {
2116 PerlIO_list_free(aTHX_ PL_def_layerlist);
2117 PL_def_layerlist = NULL;
2123 /*--------------------------------------------------------------------------------------*/
2125 * Bottom-most level for UNIX-like case
2129 struct _PerlIO base; /* The generic part */
2130 int fd; /* UNIX like file descriptor */
2131 int oflags; /* open/fcntl flags */
2135 PerlIOUnix_oflags(const char *mode)
2138 if (*mode == 'I' || *mode == '#')
2143 if (*++mode == '+') {
2150 oflags = O_CREAT | O_TRUNC;
2151 if (*++mode == '+') {
2160 oflags = O_CREAT | O_APPEND;
2161 if (*++mode == '+') {
2174 else if (*mode == 't') {
2176 oflags &= ~O_BINARY;
2180 * Always open in binary mode
2183 if (*mode || oflags == -1) {
2184 SETERRNO(EINVAL, LIB$_INVARG);
2191 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2193 return PerlIOSelf(f, PerlIOUnix)->fd;
2197 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2199 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
2200 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2201 if (*PerlIONext(f)) {
2202 /* We never call down so any pending stuff now */
2203 PerlIO_flush(PerlIONext(f));
2204 s->fd = PerlIO_fileno(PerlIONext(f));
2206 * XXX could (or should) we retrieve the oflags from the open file
2207 * handle rather than believing the "mode" we are passed in? XXX
2208 * Should the value on NULL mode be 0 or -1?
2210 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2212 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2217 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2218 IV n, const char *mode, int fd, int imode,
2219 int perm, PerlIO *f, int narg, SV **args)
2221 if (PerlIOValid(f)) {
2222 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2223 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2226 char *path = SvPV_nolen(*args);
2230 imode = PerlIOUnix_oflags(mode);
2234 fd = PerlLIO_open3(path, imode, perm);
2242 f = PerlIO_allocate(aTHX);
2244 if (!PerlIOValid(f)) {
2245 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
2249 s = PerlIOSelf(f, PerlIOUnix);
2253 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2254 PerlIOUnix_refcnt_inc(fd);
2260 * FIXME: pop layers ???
2268 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2270 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2272 if (flags & PERLIO_DUP_FD) {
2273 fd = PerlLIO_dup(fd);
2275 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2276 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2278 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2279 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2281 PerlIOUnix_refcnt_inc(fd);
2290 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2292 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2293 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2296 SSize_t len = PerlLIO_read(fd, vbuf, count);
2297 if (len >= 0 || errno != EINTR) {
2299 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2300 else if (len == 0 && count != 0)
2301 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2309 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2311 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2313 SSize_t len = PerlLIO_write(fd, vbuf, count);
2314 if (len >= 0 || errno != EINTR) {
2316 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2324 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2327 PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2328 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2329 return (new == (Off_t) - 1) ? -1 : 0;
2333 PerlIOUnix_tell(pTHX_ PerlIO *f)
2335 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2340 PerlIOUnix_close(pTHX_ PerlIO *f)
2342 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2344 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2345 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2346 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2351 SETERRNO(EBADF,SS$_IVCHAN);
2354 while (PerlLIO_close(fd) != 0) {
2355 if (errno != EINTR) {
2362 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2367 PerlIO_funcs PerlIO_unix = {
2383 PerlIOBase_noop_ok, /* flush */
2384 PerlIOBase_noop_fail, /* fill */
2387 PerlIOBase_clearerr,
2388 PerlIOBase_setlinebuf,
2389 NULL, /* get_base */
2390 NULL, /* get_bufsiz */
2393 NULL, /* set_ptrcnt */
2396 /*--------------------------------------------------------------------------------------*/
2401 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2402 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2403 broken by the last second glibc 2.3 fix
2405 #define STDIO_BUFFER_WRITABLE
2410 struct _PerlIO base;
2411 FILE *stdio; /* The stream */
2415 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2417 return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2421 PerlIOStdio_mode(const char *mode, char *tmode)
2427 #ifdef PERLIO_USING_CRLF
2435 * This isn't used yet ...
2438 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2440 if (*PerlIONext(f)) {
2441 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2444 PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2445 PerlIOStdio_mode(mode, tmode));
2448 /* We never call down so any pending stuff now */
2449 PerlIO_flush(PerlIONext(f));
2454 return PerlIOBase_pushed(aTHX_ f, mode, arg);
2459 PerlIO_importFILE(FILE *stdio, int fl)
2464 /* We need to probe to see how we can open the stream
2465 so start with read/write and then try write and read
2466 we dup() so that we can fclose without loosing the fd.
2468 Note that the errno value set by a failing fdopen
2469 varies between stdio implementations.
2471 int fd = PerlLIO_dup(fileno(stdio));
2473 FILE *f2 = fdopen(fd, mode);
2477 f2 = fdopen(fd, mode);
2481 f2 = fdopen(fd, mode);
2484 /* Don't seem to be able to open */
2489 s = PerlIOSelf(PerlIO_push
2490 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2491 mode, Nullsv), PerlIOStdio);
2498 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2499 IV n, const char *mode, int fd, int imode,
2500 int perm, PerlIO *f, int narg, SV **args)
2503 if (PerlIOValid(f)) {
2504 char *path = SvPV_nolen(*args);
2505 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2507 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2508 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2513 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2518 char *path = SvPV_nolen(*args);
2521 fd = PerlLIO_open3(path, imode, perm);
2524 FILE *stdio = PerlSIO_fopen(path, mode);
2528 f = PerlIO_allocate(aTHX);
2530 s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
2531 (mode = PerlIOStdio_mode(mode, tmode)),
2535 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2550 stdio = PerlSIO_stdin;
2553 stdio = PerlSIO_stdout;
2556 stdio = PerlSIO_stderr;
2561 stdio = PerlSIO_fdopen(fd, mode =
2562 PerlIOStdio_mode(mode, tmode));
2567 f = PerlIO_allocate(aTHX);
2569 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio);
2571 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2580 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2582 /* This assumes no layers underneath - which is what
2583 happens, but is not how I remember it. NI-S 2001/10/16
2585 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2586 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2587 if (flags & PERLIO_DUP_FD) {
2588 int fd = PerlLIO_dup(fileno(stdio));
2591 stdio = fdopen(fd, PerlIO_modestr(o,mode));
2594 /* FIXME: To avoid messy error recovery if dup fails
2595 re-use the existing stdio as though flag was not set
2599 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2600 PerlIOUnix_refcnt_inc(fileno(stdio));
2606 PerlIOStdio_close(pTHX_ PerlIO *f)
2608 #ifdef SOCKS5_VERSION_NAME
2610 Sock_size_t optlen = sizeof(int);
2612 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2613 if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2614 /* Do not close it but do flush any buffers */
2615 return PerlIO_flush(f);
2618 #ifdef SOCKS5_VERSION_NAME
2620 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2622 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2624 PerlSIO_fclose(stdio)
2633 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2635 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2638 STDCHAR *buf = (STDCHAR *) vbuf;
2640 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2641 * stdio does not do that for fread()
2643 int ch = PerlSIO_fgetc(s);
2650 got = PerlSIO_fread(vbuf, 1, count, s);
2655 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2658 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2660 #ifdef STDIO_BUFFER_WRITABLE
2661 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2662 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2663 STDCHAR *base = PerlIO_get_base(f);
2664 SSize_t cnt = PerlIO_get_cnt(f);
2665 STDCHAR *ptr = PerlIO_get_ptr(f);
2666 SSize_t avail = ptr - base;
2668 if (avail > count) {
2672 Move(buf-avail,ptr,avail,STDCHAR);
2675 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
2676 if (PerlSIO_feof(s) && unread >= 0)
2677 PerlSIO_clearerr(s);
2682 if (PerlIO_has_cntptr(f)) {
2683 /* We can get pointer to buffer but not its base
2684 Do ungetc() but check chars are ending up in the
2687 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
2688 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2690 int ch = *--buf & 0xFF;
2691 if (ungetc(ch,s) != ch) {
2692 /* ungetc did not work */
2695 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
2696 /* Did not change pointer as expected */
2697 fgetc(s); /* get char back again */
2707 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
2713 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2715 return PerlSIO_fwrite(vbuf, 1, count,
2716 PerlIOSelf(f, PerlIOStdio)->stdio);
2720 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2722 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2723 return PerlSIO_fseek(stdio, offset, whence);
2727 PerlIOStdio_tell(pTHX_ PerlIO *f)
2729 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2730 return PerlSIO_ftell(stdio);
2734 PerlIOStdio_flush(pTHX_ PerlIO *f)
2736 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2737 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2738 return PerlSIO_fflush(stdio);
2743 * FIXME: This discards ungetc() and pre-read stuff which is not
2744 * right if this is just a "sync" from a layer above Suspect right
2745 * design is to do _this_ but not have layer above flush this
2746 * layer read-to-read
2749 * Not writeable - sync by attempting a seek
2752 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2760 PerlIOStdio_eof(pTHX_ PerlIO *f)
2762 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2766 PerlIOStdio_error(pTHX_ PerlIO *f)
2768 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2772 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2774 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2778 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2780 #ifdef HAS_SETLINEBUF
2781 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2783 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2789 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2791 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2792 return (STDCHAR*)PerlSIO_get_base(stdio);
2796 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2798 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2799 return PerlSIO_get_bufsiz(stdio);
2803 #ifdef USE_STDIO_PTR
2805 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2807 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2808 return (STDCHAR*)PerlSIO_get_ptr(stdio);
2812 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2814 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2815 return PerlSIO_get_cnt(stdio);
2819 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2821 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2823 #ifdef STDIO_PTR_LVALUE
2824 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2825 #ifdef STDIO_PTR_LVAL_SETS_CNT
2826 if (PerlSIO_get_cnt(stdio) != (cnt)) {
2827 assert(PerlSIO_get_cnt(stdio) == (cnt));
2830 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2832 * Setting ptr _does_ change cnt - we are done
2836 #else /* STDIO_PTR_LVALUE */
2838 #endif /* STDIO_PTR_LVALUE */
2841 * Now (or only) set cnt
2843 #ifdef STDIO_CNT_LVALUE
2844 PerlSIO_set_cnt(stdio, cnt);
2845 #else /* STDIO_CNT_LVALUE */
2846 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2847 PerlSIO_set_ptr(stdio,
2848 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2850 #else /* STDIO_PTR_LVAL_SETS_CNT */
2852 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2853 #endif /* STDIO_CNT_LVALUE */
2860 PerlIOStdio_fill(pTHX_ PerlIO *f)
2862 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2865 * fflush()ing read-only streams can cause trouble on some stdio-s
2867 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2868 if (PerlSIO_fflush(stdio) != 0)
2871 c = PerlSIO_fgetc(stdio);
2875 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2877 #ifdef STDIO_BUFFER_WRITABLE
2878 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2879 /* Fake ungetc() to the real buffer in case system's ungetc
2882 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
2883 SSize_t cnt = PerlSIO_get_cnt(stdio);
2884 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
2885 if (ptr == base+1) {
2886 *--ptr = (STDCHAR) c;
2887 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
2888 if (PerlSIO_feof(stdio))
2889 PerlSIO_clearerr(stdio);
2895 if (PerlIO_has_cntptr(f)) {
2897 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
2904 /* An ungetc()d char is handled separately from the regular
2905 * buffer, so we stuff it in the buffer ourselves.
2906 * Should never get called as should hit code above
2908 *(--((*stdio)->_ptr)) = (unsigned char) c;
2911 /* If buffer snoop scheme above fails fall back to
2914 if (PerlSIO_ungetc(c, stdio) != c)
2922 PerlIO_funcs PerlIO_stdio = {
2924 sizeof(PerlIOStdio),
2942 PerlIOStdio_clearerr,
2943 PerlIOStdio_setlinebuf,
2945 PerlIOStdio_get_base,
2946 PerlIOStdio_get_bufsiz,
2951 #ifdef USE_STDIO_PTR
2952 PerlIOStdio_get_ptr,
2953 PerlIOStdio_get_cnt,
2954 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2955 PerlIOStdio_set_ptrcnt
2956 #else /* STDIO_PTR_LVALUE */
2958 #endif /* STDIO_PTR_LVALUE */
2959 #else /* USE_STDIO_PTR */
2963 #endif /* USE_STDIO_PTR */
2967 PerlIO_exportFILE(PerlIO *f, int fl)
2973 stdio = fdopen(PerlIO_fileno(f), PerlIO_modestr(f,buf));
2976 PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv),
2984 PerlIO_findFILE(PerlIO *f)
2988 if (l->tab == &PerlIO_stdio) {
2989 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2992 l = *PerlIONext(&l);
2994 return PerlIO_exportFILE(f, 0);
2998 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3002 if (l->tab == &PerlIO_stdio) {
3003 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3004 if (s->stdio == f) {
3006 PerlIO_pop(aTHX_ p);
3015 /*--------------------------------------------------------------------------------------*/
3017 * perlio buffer layer
3021 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3023 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3024 int fd = PerlIO_fileno(f);
3026 if (fd >= 0 && PerlLIO_isatty(fd)) {
3027 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3029 posn = PerlIO_tell(PerlIONext(f));
3030 if (posn != (Off_t) - 1) {
3033 return PerlIOBase_pushed(aTHX_ f, mode, arg);
3037 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3038 IV n, const char *mode, int fd, int imode, int perm,
3039 PerlIO *f, int narg, SV **args)
3041 if (PerlIOValid(f)) {
3042 PerlIO *next = PerlIONext(f);
3043 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3044 next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3046 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
3051 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3059 f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3062 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3064 * if push fails during open, open fails. close will pop us.
3069 fd = PerlIO_fileno(f);
3070 if (init && fd == 2) {
3072 * Initial stderr is unbuffered
3074 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3076 #ifdef PERLIO_USING_CRLF
3077 # ifdef PERLIO_IS_BINMODE_FD
3078 if (PERLIO_IS_BINMODE_FD(fd))
3079 PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch);
3083 * do something about failing setmode()? --jhi
3085 PerlLIO_setmode(fd, O_BINARY);
3094 * This "flush" is akin to sfio's sync in that it handles files in either
3095 * read or write state
3098 PerlIOBuf_flush(pTHX_ PerlIO *f)
3100 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3102 PerlIO *n = PerlIONext(f);
3103 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3105 * write() the buffer
3107 STDCHAR *buf = b->buf;
3109 while (p < b->ptr) {
3110 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3114 else if (count < 0 || PerlIO_error(n)) {
3115 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3120 b->posn += (p - buf);
3122 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3123 STDCHAR *buf = PerlIO_get_base(f);
3125 * Note position change
3127 b->posn += (b->ptr - buf);
3128 if (b->ptr < b->end) {
3130 * We did not consume all of it
3132 if (PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3133 /* Reload n as some layers may pop themselves on seek */
3134 b->posn = PerlIO_tell(n = PerlIONext(f));
3141 b->ptr = b->end = b->buf;
3142 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3143 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3144 /* FIXME: Doing downstream flush may be sub-optimal see PerlIOBuf_fill() below */
3145 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3151 PerlIOBuf_fill(pTHX_ PerlIO *f)
3153 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3154 PerlIO *n = PerlIONext(f);
3157 * FIXME: doing the down-stream flush maybe sub-optimal if it causes
3158 * pre-read data in stdio buffer to be discarded.
3159 * However, skipping the flush also skips _our_ hosekeeping
3160 * and breaks tell tests. So we do the flush.
3162 if (PerlIO_flush(f) != 0)
3164 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3165 PerlIOBase_flush_linebuf(aTHX);
3168 PerlIO_get_base(f); /* allocate via vtable */
3170 b->ptr = b->end = b->buf;
3171 if (PerlIO_fast_gets(n)) {
3173 * Layer below is also buffered. We do _NOT_ want to call its
3174 * ->Read() because that will loop till it gets what we asked for
3175 * which may hang on a pipe etc. Instead take anything it has to
3176 * hand, or ask it to fill _once_.
3178 avail = PerlIO_get_cnt(n);
3180 avail = PerlIO_fill(n);
3182 avail = PerlIO_get_cnt(n);
3184 if (!PerlIO_error(n) && PerlIO_eof(n))
3189 STDCHAR *ptr = PerlIO_get_ptr(n);
3190 SSize_t cnt = avail;
3191 if (avail > (SSize_t)b->bufsiz)
3193 Copy(ptr, b->buf, avail, STDCHAR);
3194 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3198 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3202 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3204 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3207 b->end = b->buf + avail;
3208 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3213 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3215 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3216 if (PerlIOValid(f)) {
3219 return PerlIOBase_read(aTHX_ f, vbuf, count);
3225 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3227 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3228 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3231 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3236 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3238 * Buffer is already a read buffer, we can overwrite any chars
3239 * which have been read back to buffer start
3241 avail = (b->ptr - b->buf);
3245 * Buffer is idle, set it up so whole buffer is available for
3249 b->end = b->buf + avail;
3251 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3253 * Buffer extends _back_ from where we are now
3255 b->posn -= b->bufsiz;
3257 if (avail > (SSize_t) count) {
3259 * If we have space for more than count, just move count
3267 * In simple stdio-like ungetc() case chars will be already
3270 if (buf != b->ptr) {
3271 Copy(buf, b->ptr, avail, STDCHAR);
3275 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3279 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3285 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3287 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3288 const STDCHAR *buf = (const STDCHAR *) vbuf;
3292 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3295 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3296 if ((SSize_t) count < avail)
3298 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3299 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3314 Copy(buf, b->ptr, avail, STDCHAR);
3321 if (b->ptr >= (b->buf + b->bufsiz))
3324 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3330 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3333 if ((code = PerlIO_flush(f)) == 0) {
3334 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3335 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3336 code = PerlIO_seek(PerlIONext(f), offset, whence);
3338 b->posn = PerlIO_tell(PerlIONext(f));
3345 PerlIOBuf_tell(pTHX_ PerlIO *f)
3347 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3349 * b->posn is file position where b->buf was read, or will be written
3351 Off_t posn = b->posn;
3354 * If buffer is valid adjust position by amount in buffer
3356 posn += (b->ptr - b->buf);
3362 PerlIOBuf_popped(pTHX_ PerlIO *f)
3364 IV code = PerlIOBase_popped(aTHX_ f);
3365 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3366 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3370 b->ptr = b->end = b->buf;
3371 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3376 PerlIOBuf_close(pTHX_ PerlIO *f)
3378 IV code = PerlIOBase_close(aTHX_ f);
3379 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3380 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3384 b->ptr = b->end = b->buf;
3385 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3390 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3392 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3399 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3401 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3404 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3405 return (b->end - b->ptr);
3410 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3412 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3417 Newz('B',b->buf,b->bufsiz, STDCHAR);
3419 b->buf = (STDCHAR *) & b->oneword;
3420 b->bufsiz = sizeof(b->oneword);
3429 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3431 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3434 return (b->end - b->buf);
3438 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3440 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3444 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3445 assert(PerlIO_get_cnt(f) == cnt);
3446 assert(b->ptr >= b->buf);
3448 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3452 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3454 return PerlIOBase_dup(aTHX_ f, o, param, flags);
3459 PerlIO_funcs PerlIO_perlio = {
3479 PerlIOBase_clearerr,
3480 PerlIOBase_setlinebuf,
3485 PerlIOBuf_set_ptrcnt,
3488 /*--------------------------------------------------------------------------------------*/
3490 * Temp layer to hold unread chars when cannot do it any other way
3494 PerlIOPending_fill(pTHX_ PerlIO *f)
3497 * Should never happen
3504 PerlIOPending_close(pTHX_ PerlIO *f)
3507 * A tad tricky - flush pops us, then we close new top
3510 return PerlIO_close(f);
3514 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3517 * A tad tricky - flush pops us, then we seek new top
3520 return PerlIO_seek(f, offset, whence);
3525 PerlIOPending_flush(pTHX_ PerlIO *f)
3527 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3528 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3532 PerlIO_pop(aTHX_ f);
3537 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3543 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3548 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3550 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3551 PerlIOl *l = PerlIOBase(f);
3553 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3554 * etc. get muddled when it changes mid-string when we auto-pop.
3556 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3557 (PerlIOBase(PerlIONext(f))->
3558 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3563 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3565 SSize_t avail = PerlIO_get_cnt(f);
3567 if ((SSize_t)count < avail)
3570 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3571 if (got >= 0 && got < (SSize_t)count) {
3573 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3574 if (more >= 0 || got == 0)
3580 PerlIO_funcs PerlIO_pending = {
3584 PerlIOPending_pushed,
3595 PerlIOPending_close,
3596 PerlIOPending_flush,
3600 PerlIOBase_clearerr,
3601 PerlIOBase_setlinebuf,
3606 PerlIOPending_set_ptrcnt,
3611 /*--------------------------------------------------------------------------------------*/
3613 * crlf - translation On read translate CR,LF to "\n" we do this by
3614 * overriding ptr/cnt entries to hand back a line at a time and keeping a
3615 * record of which nl we "lied" about. On write translate "\n" to CR,LF
3619 PerlIOBuf base; /* PerlIOBuf stuff */
3620 STDCHAR *nl; /* Position of crlf we "lied" about in the
3625 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3628 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3629 code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3631 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3632 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3633 PerlIOBase(f)->flags);
3640 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3642 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3647 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3648 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3650 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3651 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3653 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3658 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3659 b->end = b->ptr = b->buf + b->bufsiz;
3660 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3661 b->posn -= b->bufsiz;
3663 while (count > 0 && b->ptr > b->buf) {
3666 if (b->ptr - 2 >= b->buf) {
3689 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3691 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3694 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3695 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3696 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3697 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3699 while (nl < b->end && *nl != 0xd)
3701 if (nl < b->end && *nl == 0xd) {
3703 if (nl + 1 < b->end) {
3710 * Not CR,LF but just CR
3718 * Blast - found CR as last char in buffer
3723 * They may not care, defer work as long as
3727 return (nl - b->ptr);
3731 b->ptr++; /* say we have read it as far as
3732 * flush() is concerned */
3733 b->buf++; /* Leave space in front of buffer */
3734 b->bufsiz--; /* Buffer is thus smaller */
3735 code = PerlIO_fill(f); /* Fetch some more */
3736 b->bufsiz++; /* Restore size for next time */
3737 b->buf--; /* Point at space */
3738 b->ptr = nl = b->buf; /* Which is what we hand
3740 b->posn--; /* Buffer starts here */
3741 *nl = 0xd; /* Fill in the CR */
3743 goto test; /* fill() call worked */
3745 * CR at EOF - just fall through
3747 /* Should we clear EOF though ??? */
3752 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3758 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3760 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3761 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3767 if (ptr == b->end && *c->nl == 0xd) {
3768 /* Defered CR at end of buffer case - we lied about count */
3780 * Test code - delete when it works ...
3782 IV flags = PerlIOBase(f)->flags;
3783 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3784 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3785 /* Defered CR at end of buffer case - we lied about count */
3791 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3792 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3800 * They have taken what we lied about
3808 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3812 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3814 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3815 return PerlIOBuf_write(aTHX_ f, vbuf, count);
3817 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3818 const STDCHAR *buf = (const STDCHAR *) vbuf;
3819 const STDCHAR *ebuf = buf + count;
3822 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3824 while (buf < ebuf) {
3825 STDCHAR *eptr = b->buf + b->bufsiz;
3826 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3827 while (buf < ebuf && b->ptr < eptr) {
3829 if ((b->ptr + 2) > eptr) {
3837 *(b->ptr)++ = 0xd; /* CR */
3838 *(b->ptr)++ = 0xa; /* LF */
3840 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3850 if (b->ptr >= eptr) {
3856 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3858 return (buf - (STDCHAR *) vbuf);
3863 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3865 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3870 return PerlIOBuf_flush(aTHX_ f);
3873 PerlIO_funcs PerlIO_crlf = {
3876 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3878 PerlIOBuf_popped, /* popped */
3883 PerlIOBuf_read, /* generic read works with ptr/cnt lies
3885 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3886 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3894 PerlIOBase_clearerr,
3895 PerlIOBase_setlinebuf,
3900 PerlIOCrlf_set_ptrcnt,
3904 /*--------------------------------------------------------------------------------------*/
3906 * mmap as "buffer" layer
3910 PerlIOBuf base; /* PerlIOBuf stuff */
3911 Mmap_t mptr; /* Mapped address */
3912 Size_t len; /* mapped length */
3913 STDCHAR *bbuf; /* malloced buffer if map fails */
3916 static size_t page_size = 0;
3919 PerlIOMmap_map(pTHX_ PerlIO *f)
3921 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3922 IV flags = PerlIOBase(f)->flags;
3926 if (flags & PERLIO_F_CANREAD) {
3927 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3928 int fd = PerlIO_fileno(f);
3930 code = Fstat(fd, &st);
3931 if (code == 0 && S_ISREG(st.st_mode)) {
3932 SSize_t len = st.st_size - b->posn;
3936 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3938 SETERRNO(0, SS$_NORMAL);
3939 # ifdef _SC_PAGESIZE
3940 page_size = sysconf(_SC_PAGESIZE);
3942 page_size = sysconf(_SC_PAGE_SIZE);
3944 if ((long) page_size < 0) {
3949 (void) SvUPGRADE(error, SVt_PV);
3950 msg = SvPVx(error, n_a);
3951 Perl_croak(aTHX_ "panic: sysconf: %s",
3956 "panic: sysconf: pagesize unknown");
3960 # ifdef HAS_GETPAGESIZE
3961 page_size = getpagesize();
3963 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3964 page_size = PAGESIZE; /* compiletime, bad */
3968 if ((IV) page_size <= 0)
3969 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3974 * This is a hack - should never happen - open should
3977 b->posn = PerlIO_tell(PerlIONext(f));
3979 posn = (b->posn / page_size) * page_size;
3980 len = st.st_size - posn;
3981 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3982 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3983 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3984 madvise(m->mptr, len, MADV_SEQUENTIAL);
3986 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3987 madvise(m->mptr, len, MADV_WILLNEED);
3989 PerlIOBase(f)->flags =
3990 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3991 b->end = ((STDCHAR *) m->mptr) + len;
3992 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4001 PerlIOBase(f)->flags =
4002 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4004 b->ptr = b->end = b->ptr;
4013 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4015 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4016 PerlIOBuf *b = &m->base;
4020 code = munmap(m->mptr, m->len);
4024 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4027 b->ptr = b->end = b->buf;
4028 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4034 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4036 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4037 PerlIOBuf *b = &m->base;
4038 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4040 * Already have a readbuffer in progress
4046 * We have a write buffer or flushed PerlIOBuf read buffer
4048 m->bbuf = b->buf; /* save it in case we need it again */
4049 b->buf = NULL; /* Clear to trigger below */
4052 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4055 * Map did not work - recover PerlIOBuf buffer if we have one
4060 b->ptr = b->end = b->buf;
4063 return PerlIOBuf_get_base(aTHX_ f);
4067 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4069 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4070 PerlIOBuf *b = &m->base;
4071 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4073 if (b->ptr && (b->ptr - count) >= b->buf
4074 && memEQ(b->ptr - count, vbuf, count)) {
4076 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4081 * Loose the unwritable mapped buffer
4085 * If flush took the "buffer" see if we have one from before
4087 if (!b->buf && m->bbuf)
4090 PerlIOBuf_get_base(aTHX_ f);
4094 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4098 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4100 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4101 PerlIOBuf *b = &m->base;
4102 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4104 * No, or wrong sort of, buffer
4107 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4111 * If unmap took the "buffer" see if we have one from before
4113 if (!b->buf && m->bbuf)
4116 PerlIOBuf_get_base(aTHX_ f);
4120 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4124 PerlIOMmap_flush(pTHX_ PerlIO *f)
4126 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4127 PerlIOBuf *b = &m->base;
4128 IV code = PerlIOBuf_flush(aTHX_ f);
4130 * Now we are "synced" at PerlIOBuf level
4137 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4142 * We seem to have a PerlIOBuf buffer which was not mapped
4143 * remember it in case we need one later
4152 PerlIOMmap_fill(pTHX_ PerlIO *f)
4154 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4155 IV code = PerlIO_flush(f);
4156 if (code == 0 && !b->buf) {
4157 code = PerlIOMmap_map(aTHX_ f);
4159 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4160 code = PerlIOBuf_fill(aTHX_ f);
4166 PerlIOMmap_close(pTHX_ PerlIO *f)
4168 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4169 PerlIOBuf *b = &m->base;
4170 IV code = PerlIO_flush(f);
4174 b->ptr = b->end = b->buf;
4176 if (PerlIOBuf_close(aTHX_ f) != 0)
4182 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4184 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4188 PerlIO_funcs PerlIO_mmap = {
4208 PerlIOBase_clearerr,
4209 PerlIOBase_setlinebuf,
4210 PerlIOMmap_get_base,
4214 PerlIOBuf_set_ptrcnt,
4217 #endif /* HAS_MMAP */
4220 Perl_PerlIO_stdin(pTHX)
4223 PerlIO_stdstreams(aTHX);
4225 return &PL_perlio[1];
4229 Perl_PerlIO_stdout(pTHX)
4232 PerlIO_stdstreams(aTHX);
4234 return &PL_perlio[2];
4238 Perl_PerlIO_stderr(pTHX)
4241 PerlIO_stdstreams(aTHX);
4243 return &PL_perlio[3];
4246 /*--------------------------------------------------------------------------------------*/
4249 PerlIO_getname(PerlIO *f, char *buf)
4254 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4256 name = fgetname(stdio, buf);
4258 Perl_croak(aTHX_ "Don't know how to get file name");
4264 /*--------------------------------------------------------------------------------------*/
4266 * Functions which can be called on any kind of PerlIO implemented in
4270 #undef PerlIO_fdopen
4272 PerlIO_fdopen(int fd, const char *mode)
4275 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4280 PerlIO_open(const char *path, const char *mode)
4283 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4284 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4287 #undef Perlio_reopen
4289 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4292 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4293 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4298 PerlIO_getc(PerlIO *f)
4302 SSize_t count = PerlIO_read(f, buf, 1);
4304 return (unsigned char) buf[0];
4309 #undef PerlIO_ungetc
4311 PerlIO_ungetc(PerlIO *f, int ch)
4316 if (PerlIO_unread(f, &buf, 1) == 1)
4324 PerlIO_putc(PerlIO *f, int ch)
4328 return PerlIO_write(f, &buf, 1);
4333 PerlIO_puts(PerlIO *f, const char *s)
4336 STRLEN len = strlen(s);
4337 return PerlIO_write(f, s, len);
4340 #undef PerlIO_rewind
4342 PerlIO_rewind(PerlIO *f)
4345 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4349 #undef PerlIO_vprintf
4351 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4354 SV *sv = newSVpvn("", 0);
4360 Perl_va_copy(ap, apc);
4361 sv_vcatpvf(sv, fmt, &apc);
4363 sv_vcatpvf(sv, fmt, &ap);
4366 wrote = PerlIO_write(f, s, len);
4371 #undef PerlIO_printf
4373 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4378 result = PerlIO_vprintf(f, fmt, ap);
4383 #undef PerlIO_stdoutf
4385 PerlIO_stdoutf(const char *fmt, ...)
4391 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4396 #undef PerlIO_tmpfile
4398 PerlIO_tmpfile(void)
4401 * I have no idea how portable mkstemp() is ...
4403 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4406 FILE *stdio = PerlSIO_tmpfile();
4409 PerlIOSelf(PerlIO_push
4410 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4411 "w+", Nullsv), PerlIOStdio);
4417 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4418 int fd = mkstemp(SvPVX(sv));
4421 f = PerlIO_fdopen(fd, "w+");
4423 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4425 PerlLIO_unlink(SvPVX(sv));
4435 #endif /* USE_SFIO */
4436 #endif /* PERLIO_IS_STDIO */
4438 /*======================================================================================*/
4440 * Now some functions in terms of above which may be needed even if we are
4441 * not in true PerlIO mode
4445 #undef PerlIO_setpos
4447 PerlIO_setpos(PerlIO *f, SV *pos)
4452 Off_t *posn = (Off_t *) SvPV(pos, len);
4453 if (f && len == sizeof(Off_t))
4454 return PerlIO_seek(f, *posn, SEEK_SET);
4456 SETERRNO(EINVAL, SS$_IVCHAN);
4460 #undef PerlIO_setpos
4462 PerlIO_setpos(PerlIO *f, SV *pos)
4467 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4468 if (f && len == sizeof(Fpos_t)) {
4469 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4470 return fsetpos64(f, fpos);
4472 return fsetpos(f, fpos);
4476 SETERRNO(EINVAL, SS$_IVCHAN);
4482 #undef PerlIO_getpos
4484 PerlIO_getpos(PerlIO *f, SV *pos)
4487 Off_t posn = PerlIO_tell(f);
4488 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4489 return (posn == (Off_t) - 1) ? -1 : 0;
4492 #undef PerlIO_getpos
4494 PerlIO_getpos(PerlIO *f, SV *pos)
4499 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4500 code = fgetpos64(f, &fpos);
4502 code = fgetpos(f, &fpos);
4504 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4509 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4512 vprintf(char *pat, char *args)
4514 _doprnt(pat, args, stdout);
4515 return 0; /* wrong, but perl doesn't use the return
4520 vfprintf(FILE *fd, char *pat, char *args)
4522 _doprnt(pat, args, fd);
4523 return 0; /* wrong, but perl doesn't use the return
4529 #ifndef PerlIO_vsprintf
4531 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4533 int val = vsprintf(s, fmt, ap);
4535 if (strlen(s) >= (STRLEN) n) {
4537 (void) PerlIO_puts(Perl_error_log,
4538 "panic: sprintf overflow - memory corrupted!\n");
4546 #ifndef PerlIO_sprintf
4548 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4553 result = PerlIO_vsprintf(s, n, fmt, ap);