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, const char *mode)
343 int fd = fileno(stdio);
344 if (!mode || !*mode) {
347 return PerlIO_fdopen(fd, mode);
351 PerlIO_findFILE(PerlIO *pio)
353 int fd = PerlIO_fileno(pio);
354 FILE *f = fdopen(fd, "r+");
356 if (!f && errno == EINVAL)
358 if (!f && errno == EINVAL)
365 /*======================================================================================*/
367 * Implement all the PerlIO interface ourselves.
373 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
380 #include <sys/mman.h>
384 void PerlIO_debug(const char *fmt, ...)
385 __attribute__ ((format(__printf__, 1, 2)));
388 PerlIO_debug(const char *fmt, ...)
395 char *s = PerlEnv_getenv("PERLIO_DEBUG");
397 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
404 /* Use fixed buffer as sv_catpvf etc. needs SVs */
408 s = CopFILE(PL_curcop);
411 sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
412 len = strlen(buffer);
413 vsprintf(buffer+len, fmt, ap);
414 PerlLIO_write(dbg, buffer, strlen(buffer));
416 SV *sv = newSVpvn("", 0);
419 s = CopFILE(PL_curcop);
422 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
423 (IV) CopLINE(PL_curcop));
424 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
427 PerlLIO_write(dbg, s, len);
434 /*--------------------------------------------------------------------------------------*/
437 * Inner level routines
441 * Table of pointers to the PerlIO structs (malloc'ed)
443 #define PERLIO_TABLE_SIZE 64
446 PerlIO_allocate(pTHX)
449 * Find a free slot in the table, allocating new table as necessary
454 while ((f = *last)) {
456 last = (PerlIO **) (f);
457 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
463 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
471 #undef PerlIO_fdupopen
473 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
475 if (PerlIOValid(f)) {
476 PerlIO_funcs *tab = PerlIOBase(f)->tab;
478 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
479 new = (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX),f,param, flags);
483 SETERRNO(EBADF, SS$_IVCHAN);
489 PerlIO_cleantable(pTHX_ PerlIO **tablep)
491 PerlIO *table = *tablep;
494 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
495 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
496 PerlIO *f = table + i;
508 PerlIO_list_alloc(pTHX)
511 Newz('L', list, 1, PerlIO_list_t);
517 PerlIO_list_free(pTHX_ PerlIO_list_t *list)
520 if (--list->refcnt == 0) {
523 for (i = 0; i < list->cur; i++) {
524 if (list->array[i].arg)
525 SvREFCNT_dec(list->array[i].arg);
527 Safefree(list->array);
535 PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
538 if (list->cur >= list->len) {
541 Renew(list->array, list->len, PerlIO_pair_t);
543 New('l', list->array, list->len, PerlIO_pair_t);
545 p = &(list->array[list->cur++]);
547 if ((p->arg = arg)) {
553 PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
555 PerlIO_list_t *list = (PerlIO_list_t *) NULL;
558 list = PerlIO_list_alloc(aTHX);
559 for (i=0; i < proto->cur; i++) {
561 if (proto->array[i].arg)
562 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
563 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
570 PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
573 PerlIO **table = &proto->Iperlio;
576 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
577 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
578 PerlIO_allocate(aTHX); /* root slot is never used */
579 PerlIO_debug("Clone %p from %p\n",aTHX,proto);
580 while ((f = *table)) {
582 table = (PerlIO **) (f++);
583 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
585 (void) fp_dup(f, 0, param);
594 PerlIO_destruct(pTHX)
596 PerlIO **table = &PL_perlio;
599 PerlIO_debug("Destruct %p\n",aTHX);
601 while ((f = *table)) {
603 table = (PerlIO **) (f++);
604 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
608 if (l->tab->kind & PERLIO_K_DESTRUCT) {
609 PerlIO_debug("Destruct popping %s\n", l->tab->name);
623 PerlIO_pop(pTHX_ PerlIO *f)
627 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
628 if (l->tab->Popped) {
630 * If popped returns non-zero do not free its layer structure
631 * it has either done so itself, or it is shared and still in
634 if ((*l->tab->Popped) (aTHX_ f) != 0)
642 /*--------------------------------------------------------------------------------------*/
644 * XS Interface for perl code
648 PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
651 if ((SSize_t) len <= 0)
653 for (i = 0; i < PL_known_layers->cur; i++) {
654 PerlIO_funcs *f = PL_known_layers->array[i].funcs;
655 if (memEQ(f->name, name, len)) {
656 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
660 if (load && PL_subname && PL_def_layerlist
661 && PL_def_layerlist->cur >= 2) {
662 SV *pkgsv = newSVpvn("PerlIO", 6);
663 SV *layer = newSVpvn(name, len);
666 * The two SVs are magically freed by load_module
668 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
670 return PerlIO_find_layer(aTHX_ name, len, 0);
672 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
676 #ifdef USE_ATTRIBUTES_FOR_PERLIO
679 perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
682 IO *io = GvIOn((GV *) SvRV(sv));
683 PerlIO *ifp = IoIFP(io);
684 PerlIO *ofp = IoOFP(io);
685 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
691 perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
694 IO *io = GvIOn((GV *) SvRV(sv));
695 PerlIO *ifp = IoIFP(io);
696 PerlIO *ofp = IoOFP(io);
697 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
703 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
705 Perl_warn(aTHX_ "clear %" SVf, sv);
710 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
712 Perl_warn(aTHX_ "free %" SVf, sv);
716 MGVTBL perlio_vtab = {
724 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
727 SV *sv = SvRV(ST(1));
732 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
734 mg = mg_find(sv, PERL_MAGIC_ext);
735 mg->mg_virtual = &perlio_vtab;
737 Perl_warn(aTHX_ "attrib %" SVf, sv);
738 for (i = 2; i < items; i++) {
740 const char *name = SvPV(ST(i), len);
741 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
743 av_push(av, SvREFCNT_inc(layer));
754 #endif /* USE_ATTIBUTES_FOR_PERLIO */
757 PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
759 HV *stash = gv_stashpv("PerlIO::Layer", TRUE);
760 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
764 XS(XS_PerlIO__Layer__find)
768 Perl_croak(aTHX_ "Usage class->find(name[,load])");
771 char *name = SvPV(ST(1), len);
772 bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
773 PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
775 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
782 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
784 if (!PL_known_layers)
785 PL_known_layers = PerlIO_list_alloc(aTHX);
786 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
787 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
791 PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
794 const char *s = names;
796 while (isSPACE(*s) || *s == ':')
801 const char *as = Nullch;
803 if (!isIDFIRST(*s)) {
805 * Message is consistent with how attribute lists are
806 * passed. Even though this means "foo : : bar" is
807 * seen as an invalid separator character.
809 char q = ((*s == '\'') ? '"' : '\'');
810 if (ckWARN(WARN_LAYER))
811 Perl_warner(aTHX_ packWARN(WARN_LAYER),
812 "perlio: invalid separator character %c%c%c in layer specification list %s",
814 SETERRNO(EINVAL, LIB$_INVARG);
819 } while (isALNUM(*e));
835 * It's a nul terminated string, not allowed
836 * to \ the terminating null. Anything other
837 * character is passed over.
847 if (ckWARN(WARN_LAYER))
848 Perl_warner(aTHX_ packWARN(WARN_LAYER),
849 "perlio: argument list not closed for layer \"%.*s\"",
861 bool warn_layer = ckWARN(WARN_LAYER);
862 PerlIO_funcs *layer =
863 PerlIO_find_layer(aTHX_ s, llen, 1);
865 PerlIO_list_push(aTHX_ av, layer,
872 Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"",
885 PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
887 PerlIO_funcs *tab = &PerlIO_perlio;
888 #ifdef PERLIO_USING_CRLF
891 if (PerlIO_stdio.Set_ptrcnt)
894 PerlIO_debug("Pushing %s\n", tab->name);
895 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
900 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
902 return av->array[n].arg;
906 PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
908 if (n >= 0 && n < av->cur) {
909 PerlIO_debug("Layer %" IVdf " is %s\n", n,
910 av->array[n].funcs->name);
911 return av->array[n].funcs;
914 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
919 PerlIO_default_layers(pTHX)
921 if (!PL_def_layerlist) {
922 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
923 PerlIO_funcs *osLayer = &PerlIO_unix;
924 PL_def_layerlist = PerlIO_list_alloc(aTHX);
925 PerlIO_define_layer(aTHX_ & PerlIO_unix);
926 #if defined(WIN32) && !defined(UNDER_CE)
927 PerlIO_define_layer(aTHX_ & PerlIO_win32);
929 osLayer = &PerlIO_win32;
932 PerlIO_define_layer(aTHX_ & PerlIO_raw);
933 PerlIO_define_layer(aTHX_ & PerlIO_perlio);
934 PerlIO_define_layer(aTHX_ & PerlIO_stdio);
935 PerlIO_define_layer(aTHX_ & PerlIO_crlf);
937 PerlIO_define_layer(aTHX_ & PerlIO_mmap);
939 PerlIO_define_layer(aTHX_ & PerlIO_utf8);
940 PerlIO_define_layer(aTHX_ & PerlIO_byte);
941 PerlIO_list_push(aTHX_ PL_def_layerlist,
942 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
945 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
948 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
951 if (PL_def_layerlist->cur < 2) {
952 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
954 return PL_def_layerlist;
958 Perl_boot_core_PerlIO(pTHX)
960 #ifdef USE_ATTRIBUTES_FOR_PERLIO
961 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
964 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
968 PerlIO_default_layer(pTHX_ I32 n)
970 PerlIO_list_t *av = PerlIO_default_layers(aTHX);
973 return PerlIO_layer_fetch(aTHX_ av, n, &PerlIO_stdio);
976 #define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
977 #define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
980 PerlIO_stdstreams(pTHX)
983 PerlIO_allocate(aTHX);
984 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
985 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
986 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
991 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
994 Newc('L',l,tab->size,char,PerlIOl);
996 Zero(l, tab->size, char);
1000 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1001 (mode) ? mode : "(Null)", (void*)arg);
1002 if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
1003 PerlIO_pop(aTHX_ f);
1011 PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1013 PerlIO_pop(aTHX_ f);
1016 PerlIO_pop(aTHX_ f);
1023 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1026 * Remove the dummy layer
1028 PerlIO_pop(aTHX_ f);
1030 * Pop back to bottom layer
1032 if (PerlIOValid(f)) {
1034 while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
1035 if (*PerlIONext(f)) {
1036 PerlIO_pop(aTHX_ f);
1040 * Nothing bellow - push unix on top then remove it
1042 if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
1043 PerlIO_pop(aTHX_ PerlIONext(f));
1048 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1055 PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1056 PerlIO_list_t *layers, IV n, IV max)
1060 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1062 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1073 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1077 PerlIO_list_t *layers = PerlIO_list_alloc(aTHX);
1078 code = PerlIO_parse_layers(aTHX_ layers, names);
1080 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1082 PerlIO_list_free(aTHX_ layers);
1088 /*--------------------------------------------------------------------------------------*/
1090 * Given the abstraction above the public API functions
1094 PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1096 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
1097 (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
1098 (names) ? names : "(Null)");
1100 /* Do not flush etc. if (e.g.) switching encodings.
1101 if a pushed layer knows it needs to flush lower layers
1102 (for example :unix which is never going to call them)
1103 it can do the flush when it is pushed.
1105 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1109 /* Turn off UTF-8-ness, to undo UTF-8 locale effects
1110 This may be too simplistic!
1112 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1114 /* FIXME?: Looking down the layer stack seems wrong,
1115 but is a way of reaching past (say) an encoding layer
1116 to flip CRLF-ness of the layer(s) below
1118 #ifdef PERLIO_USING_CRLF
1119 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1120 O_BINARY so we can look for it in mode.
1122 if (!(mode & O_BINARY)) {
1125 /* Perhaps we should turn on bottom-most aware layer
1126 e.g. Ilya's idea that UNIX TTY could serve
1128 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1129 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1130 /* Not in text mode - flush any pending stuff and flip it */
1132 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1134 /* Only need to turn it on in one layer so we are done */
1139 /* Not finding a CRLF aware layer presumably means we are binary
1140 which is not what was requested - so we failed
1141 We _could_ push :crlf layer but so could caller
1146 /* Either asked for BINMODE or that is normal on this platform
1147 see if any CRLF aware layers are present and turn off the flag
1148 and possibly remove layer.
1151 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1152 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1153 /* In text mode - flush any pending stuff and flip it */
1155 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
1156 #ifndef PERLIO_USING_CRLF
1157 /* CRLF is unusual case - if this is just the :crlf layer pop it */
1158 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
1159 PerlIO_pop(aTHX_ f);
1162 /* Normal case is only one layer doing this, so exit on first
1163 abnormal case can always do multiple binmode calls
1175 PerlIO__close(pTHX_ PerlIO *f)
1178 return (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1180 SETERRNO(EBADF, SS$_IVCHAN);
1186 Perl_PerlIO_close(pTHX_ PerlIO *f)
1189 if (PerlIOValid(f)) {
1190 code = (*PerlIOBase(f)->tab->Close) (aTHX_ f);
1192 PerlIO_pop(aTHX_ f);
1199 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1202 return (*PerlIOBase(f)->tab->Fileno) (aTHX_ f);
1204 SETERRNO(EBADF, SS$_IVCHAN);
1210 PerlIO_context_layers(pTHX_ const char *mode)
1212 const char *type = NULL;
1214 * Need to supply default layer info from open.pm
1217 SV *layers = PL_curcop->cop_io;
1220 type = SvPV(layers, len);
1221 if (type && mode[0] != 'r') {
1223 * Skip to write part
1225 const char *s = strchr(type, 0);
1226 if (s && (STRLEN)(s - type) < len) {
1235 static PerlIO_funcs *
1236 PerlIO_layer_from_ref(pTHX_ SV *sv)
1239 * For any scalar type load the handler which is bundled with perl
1241 if (SvTYPE(sv) < SVt_PVAV)
1242 return PerlIO_find_layer(aTHX_ "Scalar", 6, 1);
1245 * For other types allow if layer is known but don't try and load it
1247 switch (SvTYPE(sv)) {
1249 return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1251 return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1253 return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1255 return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1261 PerlIO_resolve_layers(pTHX_ const char *layers,
1262 const char *mode, int narg, SV **args)
1264 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1267 PerlIO_stdstreams(aTHX);
1271 * If it is a reference but not an object see if we have a handler
1274 if (SvROK(arg) && !sv_isobject(arg)) {
1275 PerlIO_funcs *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1277 def = PerlIO_list_alloc(aTHX);
1278 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1282 * Don't fail if handler cannot be found :Via(...) etc. may do
1283 * something sensible else we will just stringfy and open
1289 layers = PerlIO_context_layers(aTHX_ mode);
1290 if (layers && *layers) {
1294 av = PerlIO_list_alloc(aTHX);
1295 for (i = 0; i < def->cur; i++) {
1296 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
1303 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1307 PerlIO_list_free(aTHX_ av);
1308 return (PerlIO_list_t *) NULL;
1319 PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1320 int imode, int perm, PerlIO *f, int narg, SV **args)
1322 if (!f && narg == 1 && *args == &PL_sv_undef) {
1323 if ((f = PerlIO_tmpfile())) {
1325 layers = PerlIO_context_layers(aTHX_ mode);
1326 if (layers && *layers)
1327 PerlIO_apply_layers(aTHX_ f, mode, layers);
1331 PerlIO_list_t *layera = NULL;
1333 PerlIO_funcs *tab = NULL;
1334 if (PerlIOValid(f)) {
1336 * This is "reopen" - it is not tested as perl does not use it
1340 layera = PerlIO_list_alloc(aTHX);
1342 SV *arg = (l->tab->Getarg)
1343 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1345 PerlIO_list_push(aTHX_ layera, l->tab, arg);
1346 l = *PerlIONext(&l);
1350 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1356 * Start at "top" of layer stack
1358 n = layera->cur - 1;
1360 PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1369 * Found that layer 'n' can do opens - call it
1371 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1372 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1374 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1375 tab->name, layers, mode, fd, imode, perm,
1376 (void*)f, narg, (void*)args);
1377 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1380 if (n + 1 < layera->cur) {
1382 * More layers above the one that we used to open -
1385 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1386 /* If pushing layers fails close the file */
1393 PerlIO_list_free(aTHX_ layera);
1400 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1403 return (*PerlIOBase(f)->tab->Read) (aTHX_ f, vbuf, count);
1405 SETERRNO(EBADF, SS$_IVCHAN);
1411 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1414 return (*PerlIOBase(f)->tab->Unread) (aTHX_ f, vbuf, count);
1416 SETERRNO(EBADF, SS$_IVCHAN);
1422 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1425 return (*PerlIOBase(f)->tab->Write) (aTHX_ f, vbuf, count);
1427 SETERRNO(EBADF, SS$_IVCHAN);
1433 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1436 return (*PerlIOBase(f)->tab->Seek) (aTHX_ f, offset, whence);
1438 SETERRNO(EBADF, SS$_IVCHAN);
1444 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1447 return (*PerlIOBase(f)->tab->Tell) (aTHX_ f);
1449 SETERRNO(EBADF, SS$_IVCHAN);
1455 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1459 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1460 if (tab && tab->Flush) {
1461 return (*tab->Flush) (aTHX_ f);
1464 PerlIO_debug("Cannot flush f=%p :%s\n", (void*)f, tab->name);
1465 SETERRNO(EBADF, SS$_IVCHAN);
1470 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
1471 SETERRNO(EBADF, SS$_IVCHAN);
1477 * Is it good API design to do flush-all on NULL, a potentially
1478 * errorneous input? Maybe some magical value (PerlIO*
1479 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1480 * things on fflush(NULL), but should we be bound by their design
1483 PerlIO **table = &PL_perlio;
1485 while ((f = *table)) {
1487 table = (PerlIO **) (f++);
1488 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1489 if (*f && PerlIO_flush(f) != 0)
1499 PerlIOBase_flush_linebuf(pTHX)
1501 PerlIO **table = &PL_perlio;
1503 while ((f = *table)) {
1505 table = (PerlIO **) (f++);
1506 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1509 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1510 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1518 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1521 return (*PerlIOBase(f)->tab->Fill) (aTHX_ f);
1523 SETERRNO(EBADF, SS$_IVCHAN);
1529 PerlIO_isutf8(PerlIO *f)
1532 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1534 SETERRNO(EBADF, SS$_IVCHAN);
1540 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1543 return (*PerlIOBase(f)->tab->Eof) (aTHX_ f);
1545 SETERRNO(EBADF, SS$_IVCHAN);
1551 Perl_PerlIO_error(pTHX_ PerlIO *f)
1554 return (*PerlIOBase(f)->tab->Error) (aTHX_ f);
1556 SETERRNO(EBADF, SS$_IVCHAN);
1562 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1565 (*PerlIOBase(f)->tab->Clearerr) (aTHX_ f);
1567 SETERRNO(EBADF, SS$_IVCHAN);
1571 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1574 (*PerlIOBase(f)->tab->Setlinebuf) (aTHX_ f);
1576 SETERRNO(EBADF, SS$_IVCHAN);
1580 PerlIO_has_base(PerlIO *f)
1582 if (PerlIOValid(f)) {
1583 return (PerlIOBase(f)->tab->Get_base != NULL);
1589 PerlIO_fast_gets(PerlIO *f)
1591 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
1592 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1593 return (tab->Set_ptrcnt != NULL);
1599 PerlIO_has_cntptr(PerlIO *f)
1601 if (PerlIOValid(f)) {
1602 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1603 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1609 PerlIO_canset_cnt(PerlIO *f)
1611 if (PerlIOValid(f)) {
1612 PerlIOl *l = PerlIOBase(f);
1613 return (l->tab->Set_ptrcnt != NULL);
1619 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1622 return (*PerlIOBase(f)->tab->Get_base) (aTHX_ f);
1627 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1630 return (*PerlIOBase(f)->tab->Get_bufsiz) (aTHX_ f);
1635 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1637 if (PerlIOValid(f)) {
1638 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1639 if (tab->Get_ptr == NULL)
1641 return (*tab->Get_ptr) (aTHX_ f);
1647 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1649 if (PerlIOValid(f)) {
1650 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1651 if (tab->Get_cnt == NULL)
1653 return (*tab->Get_cnt) (aTHX_ f);
1659 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
1661 if (PerlIOValid(f)) {
1662 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, NULL, cnt);
1667 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
1669 if (PerlIOValid(f)) {
1670 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1671 if (tab->Set_ptrcnt == NULL) {
1672 Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
1674 (*PerlIOBase(f)->tab->Set_ptrcnt) (aTHX_ f, ptr, cnt);
1678 /*--------------------------------------------------------------------------------------*/
1680 * utf8 and raw dummy layers
1684 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1686 if (*PerlIONext(f)) {
1687 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1688 PerlIO_pop(aTHX_ f);
1689 if (tab->kind & PERLIO_K_UTF8)
1690 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1692 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1698 PerlIO_funcs PerlIO_utf8 = {
1701 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1719 NULL, /* get_base */
1720 NULL, /* get_bufsiz */
1723 NULL, /* set_ptrcnt */
1726 PerlIO_funcs PerlIO_byte = {
1747 NULL, /* get_base */
1748 NULL, /* get_bufsiz */
1751 NULL, /* set_ptrcnt */
1755 PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1756 IV n, const char *mode, int fd, int imode, int perm,
1757 PerlIO *old, int narg, SV **args)
1759 PerlIO_funcs *tab = PerlIO_default_btm();
1760 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1764 PerlIO_funcs PerlIO_raw = {
1785 NULL, /* get_base */
1786 NULL, /* get_bufsiz */
1789 NULL, /* set_ptrcnt */
1791 /*--------------------------------------------------------------------------------------*/
1792 /*--------------------------------------------------------------------------------------*/
1794 * "Methods" of the "base class"
1798 PerlIOBase_fileno(pTHX_ PerlIO *f)
1800 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1804 PerlIO_modestr(PerlIO *f, char *buf)
1807 IV flags = PerlIOBase(f)->flags;
1808 if (flags & PERLIO_F_APPEND) {
1810 if (flags & PERLIO_F_CANREAD) {
1814 else if (flags & PERLIO_F_CANREAD) {
1816 if (flags & PERLIO_F_CANWRITE)
1819 else if (flags & PERLIO_F_CANWRITE) {
1821 if (flags & PERLIO_F_CANREAD) {
1825 #ifdef PERLIO_USING_CRLF
1826 if (!(flags & PERLIO_F_CRLF))
1834 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
1836 PerlIOl *l = PerlIOBase(f);
1838 const char *omode = mode;
1841 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1842 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1843 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1844 if (tab->Set_ptrcnt != NULL)
1845 l->flags |= PERLIO_F_FASTGETS;
1847 if (*mode == '#' || *mode == 'I')
1851 l->flags |= PERLIO_F_CANREAD;
1854 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1857 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1860 SETERRNO(EINVAL, LIB$_INVARG);
1866 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
1869 l->flags &= ~PERLIO_F_CRLF;
1872 l->flags |= PERLIO_F_CRLF;
1875 SETERRNO(EINVAL, LIB$_INVARG);
1882 l->flags |= l->next->flags &
1883 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
1888 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
1889 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
1890 l->flags, PerlIO_modestr(f, temp));
1896 PerlIOBase_popped(pTHX_ PerlIO *f)
1902 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1905 * Save the position as current head considers it
1907 Off_t old = PerlIO_tell(f);
1909 PerlIO_push(aTHX_ f, &PerlIO_pending, "r", Nullsv);
1910 PerlIOSelf(f, PerlIOBuf)->posn = old;
1911 done = PerlIOBuf_unread(aTHX_ f, vbuf, count);
1916 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1918 STDCHAR *buf = (STDCHAR *) vbuf;
1920 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1923 SSize_t avail = PerlIO_get_cnt(f);
1926 take = ((SSize_t)count < avail) ? count : avail;
1928 STDCHAR *ptr = PerlIO_get_ptr(f);
1929 Copy(ptr, buf, take, STDCHAR);
1930 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
1934 if (count > 0 && avail <= 0) {
1935 if (PerlIO_fill(f) != 0)
1939 return (buf - (STDCHAR *) vbuf);
1945 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
1951 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
1957 PerlIOBase_close(pTHX_ PerlIO *f)
1960 PerlIO *n = PerlIONext(f);
1961 if (PerlIO_flush(f) != 0)
1963 if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0)
1965 PerlIOBase(f)->flags &=
1966 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
1971 PerlIOBase_eof(pTHX_ PerlIO *f)
1973 if (PerlIOValid(f)) {
1974 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
1980 PerlIOBase_error(pTHX_ PerlIO *f)
1982 if (PerlIOValid(f)) {
1983 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
1989 PerlIOBase_clearerr(pTHX_ PerlIO *f)
1991 if (PerlIOValid(f)) {
1992 PerlIO *n = PerlIONext(f);
1993 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2000 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2002 if (PerlIOValid(f)) {
2003 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2008 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2014 return sv_dup(arg, param);
2017 return newSVsv(arg);
2020 return newSVsv(arg);
2025 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2027 PerlIO *nexto = PerlIONext(o);
2028 if (PerlIOValid(nexto)) {
2029 PerlIO_funcs *tab = PerlIOBase(nexto)->tab;
2030 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2033 PerlIO_funcs *self = PerlIOBase(o)->tab;
2036 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2037 self->name, (void*)f, (void*)o, (void*)param);
2039 arg = (*self->Getarg)(aTHX_ o,param,flags);
2041 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2049 #define PERLIO_MAX_REFCOUNTABLE_FD 2048
2051 perl_mutex PerlIO_mutex;
2053 int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
2058 /* Place holder for stdstreams call ??? */
2060 MUTEX_INIT(&PerlIO_mutex);
2065 PerlIOUnix_refcnt_inc(int fd)
2067 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2069 MUTEX_LOCK(&PerlIO_mutex);
2071 PerlIO_fd_refcnt[fd]++;
2072 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2074 MUTEX_UNLOCK(&PerlIO_mutex);
2080 PerlIOUnix_refcnt_dec(int fd)
2083 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2085 MUTEX_LOCK(&PerlIO_mutex);
2087 cnt = --PerlIO_fd_refcnt[fd];
2088 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2090 MUTEX_UNLOCK(&PerlIO_mutex);
2097 PerlIO_cleanup(pTHX)
2101 PerlIO_debug("Cleanup layers for %p\n",aTHX);
2103 PerlIO_debug("Cleanup layers\n");
2105 /* Raise STDIN..STDERR refcount so we don't close them */
2106 for (i=0; i < 3; i++)
2107 PerlIOUnix_refcnt_inc(i);
2108 PerlIO_cleantable(aTHX_ &PL_perlio);
2109 /* Restore STDIN..STDERR refcount */
2110 for (i=0; i < 3; i++)
2111 PerlIOUnix_refcnt_dec(i);
2113 if (PL_known_layers) {
2114 PerlIO_list_free(aTHX_ PL_known_layers);
2115 PL_known_layers = NULL;
2117 if(PL_def_layerlist) {
2118 PerlIO_list_free(aTHX_ PL_def_layerlist);
2119 PL_def_layerlist = NULL;
2125 /*--------------------------------------------------------------------------------------*/
2127 * Bottom-most level for UNIX-like case
2131 struct _PerlIO base; /* The generic part */
2132 int fd; /* UNIX like file descriptor */
2133 int oflags; /* open/fcntl flags */
2137 PerlIOUnix_oflags(const char *mode)
2140 if (*mode == 'I' || *mode == '#')
2145 if (*++mode == '+') {
2152 oflags = O_CREAT | O_TRUNC;
2153 if (*++mode == '+') {
2162 oflags = O_CREAT | O_APPEND;
2163 if (*++mode == '+') {
2176 else if (*mode == 't') {
2178 oflags &= ~O_BINARY;
2182 * Always open in binary mode
2185 if (*mode || oflags == -1) {
2186 SETERRNO(EINVAL, LIB$_INVARG);
2193 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2195 return PerlIOSelf(f, PerlIOUnix)->fd;
2199 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2201 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
2202 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2203 if (*PerlIONext(f)) {
2204 /* We never call down so do any pending stuff now */
2205 PerlIO_flush(PerlIONext(f));
2206 s->fd = PerlIO_fileno(PerlIONext(f));
2208 * XXX could (or should) we retrieve the oflags from the open file
2209 * handle rather than believing the "mode" we are passed in? XXX
2210 * Should the value on NULL mode be 0 or -1?
2212 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
2214 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2219 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2220 IV n, const char *mode, int fd, int imode,
2221 int perm, PerlIO *f, int narg, SV **args)
2223 if (PerlIOValid(f)) {
2224 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
2225 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2228 char *path = SvPV_nolen(*args);
2232 imode = PerlIOUnix_oflags(mode);
2236 fd = PerlLIO_open3(path, imode, perm);
2244 f = PerlIO_allocate(aTHX);
2246 if (!PerlIOValid(f)) {
2247 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg),
2251 s = PerlIOSelf(f, PerlIOUnix);
2255 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2256 PerlIOUnix_refcnt_inc(fd);
2262 * FIXME: pop layers ???
2270 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2272 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
2274 if (flags & PERLIO_DUP_FD) {
2275 fd = PerlLIO_dup(fd);
2277 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2278 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2280 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2281 PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
2283 PerlIOUnix_refcnt_inc(fd);
2292 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2294 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2295 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2298 SSize_t len = PerlLIO_read(fd, vbuf, count);
2299 if (len >= 0 || errno != EINTR) {
2301 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2302 else if (len == 0 && count != 0)
2303 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2311 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2313 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2315 SSize_t len = PerlLIO_write(fd, vbuf, count);
2316 if (len >= 0 || errno != EINTR) {
2318 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2326 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2329 PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, whence);
2330 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2331 return (new == (Off_t) - 1) ? -1 : 0;
2335 PerlIOUnix_tell(pTHX_ PerlIO *f)
2337 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2342 PerlIOUnix_close(pTHX_ PerlIO *f)
2344 int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2346 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2347 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2348 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2353 SETERRNO(EBADF,SS$_IVCHAN);
2356 while (PerlLIO_close(fd) != 0) {
2357 if (errno != EINTR) {
2364 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2369 PerlIO_funcs PerlIO_unix = {
2385 PerlIOBase_noop_ok, /* flush */
2386 PerlIOBase_noop_fail, /* fill */
2389 PerlIOBase_clearerr,
2390 PerlIOBase_setlinebuf,
2391 NULL, /* get_base */
2392 NULL, /* get_bufsiz */
2395 NULL, /* set_ptrcnt */
2398 /*--------------------------------------------------------------------------------------*/
2403 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2404 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2405 broken by the last second glibc 2.3 fix
2407 #define STDIO_BUFFER_WRITABLE
2412 struct _PerlIO base;
2413 FILE *stdio; /* The stream */
2417 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2419 return PerlSIO_fileno(PerlIOSelf(f, PerlIOStdio)->stdio);
2423 PerlIOStdio_mode(const char *mode, char *tmode)
2429 #ifdef PERLIO_USING_CRLF
2437 * This isn't used yet ...
2440 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
2442 if (*PerlIONext(f)) {
2443 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2446 PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)), mode =
2447 PerlIOStdio_mode(mode, tmode));
2450 /* We never call down so do any pending stuff now */
2451 PerlIO_flush(PerlIONext(f));
2456 return PerlIOBase_pushed(aTHX_ f, mode, arg);
2461 PerlIO_importFILE(FILE *stdio, const char *mode)
2467 if (!mode || !*mode) {
2468 /* We need to probe to see how we can open the stream
2469 so start with read/write and then try write and read
2470 we dup() so that we can fclose without loosing the fd.
2472 Note that the errno value set by a failing fdopen
2473 varies between stdio implementations.
2475 int fd = PerlLIO_dup(fileno(stdio));
2476 FILE *f2 = fdopen(fd, (mode = "r+"));
2478 f2 = fdopen(fd, (mode = "w"));
2481 f2 = fdopen(fd, (mode = "r"));
2484 /* Don't seem to be able to open */
2490 s = PerlIOSelf(PerlIO_push
2491 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2492 mode, Nullsv), PerlIOStdio);
2499 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2500 IV n, const char *mode, int fd, int imode,
2501 int perm, PerlIO *f, int narg, SV **args)
2504 if (PerlIOValid(f)) {
2505 char *path = SvPV_nolen(*args);
2506 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
2508 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2509 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
2514 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2519 char *path = SvPV_nolen(*args);
2522 fd = PerlLIO_open3(path, imode, perm);
2525 FILE *stdio = PerlSIO_fopen(path, mode);
2529 f = PerlIO_allocate(aTHX);
2531 s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
2532 (mode = PerlIOStdio_mode(mode, tmode)),
2536 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2551 stdio = PerlSIO_stdin;
2554 stdio = PerlSIO_stdout;
2557 stdio = PerlSIO_stderr;
2562 stdio = PerlSIO_fdopen(fd, mode =
2563 PerlIOStdio_mode(mode, tmode));
2568 f = PerlIO_allocate(aTHX);
2570 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio);
2572 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2581 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2583 /* This assumes no layers underneath - which is what
2584 happens, but is not how I remember it. NI-S 2001/10/16
2586 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
2587 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
2588 if (flags & PERLIO_DUP_FD) {
2589 int fd = PerlLIO_dup(fileno(stdio));
2592 stdio = fdopen(fd, PerlIO_modestr(o,mode));
2595 /* FIXME: To avoid messy error recovery if dup fails
2596 re-use the existing stdio as though flag was not set
2600 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2601 PerlIOUnix_refcnt_inc(fileno(stdio));
2607 PerlIOStdio_close(pTHX_ PerlIO *f)
2609 #ifdef SOCKS5_VERSION_NAME
2611 Sock_size_t optlen = sizeof(int);
2613 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2614 if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
2615 /* Do not close it but do flush any buffers */
2616 return PerlIO_flush(f);
2619 #ifdef SOCKS5_VERSION_NAME
2621 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2623 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2625 PerlSIO_fclose(stdio)
2634 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2636 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2639 STDCHAR *buf = (STDCHAR *) vbuf;
2641 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
2642 * stdio does not do that for fread()
2644 int ch = PerlSIO_fgetc(s);
2651 got = PerlSIO_fread(vbuf, 1, count, s);
2656 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2659 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2661 #ifdef STDIO_BUFFER_WRITABLE
2662 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2663 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2664 STDCHAR *base = PerlIO_get_base(f);
2665 SSize_t cnt = PerlIO_get_cnt(f);
2666 STDCHAR *ptr = PerlIO_get_ptr(f);
2667 SSize_t avail = ptr - base;
2669 if (avail > count) {
2673 Move(buf-avail,ptr,avail,STDCHAR);
2676 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
2677 if (PerlSIO_feof(s) && unread >= 0)
2678 PerlSIO_clearerr(s);
2683 if (PerlIO_has_cntptr(f)) {
2684 /* We can get pointer to buffer but not its base
2685 Do ungetc() but check chars are ending up in the
2688 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
2689 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
2691 int ch = *--buf & 0xFF;
2692 if (ungetc(ch,s) != ch) {
2693 /* ungetc did not work */
2696 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
2697 /* Did not change pointer as expected */
2698 fgetc(s); /* get char back again */
2708 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
2714 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2716 return PerlSIO_fwrite(vbuf, 1, count,
2717 PerlIOSelf(f, PerlIOStdio)->stdio);
2721 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2723 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2724 return PerlSIO_fseek(stdio, offset, whence);
2728 PerlIOStdio_tell(pTHX_ PerlIO *f)
2730 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2731 return PerlSIO_ftell(stdio);
2735 PerlIOStdio_flush(pTHX_ PerlIO *f)
2737 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2738 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2739 return PerlSIO_fflush(stdio);
2744 * FIXME: This discards ungetc() and pre-read stuff which is not
2745 * right if this is just a "sync" from a layer above Suspect right
2746 * design is to do _this_ but not have layer above flush this
2747 * layer read-to-read
2750 * Not writeable - sync by attempting a seek
2753 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2761 PerlIOStdio_eof(pTHX_ PerlIO *f)
2763 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
2767 PerlIOStdio_error(pTHX_ PerlIO *f)
2769 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
2773 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
2775 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
2779 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
2781 #ifdef HAS_SETLINEBUF
2782 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
2784 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
2790 PerlIOStdio_get_base(pTHX_ PerlIO *f)
2792 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2793 return (STDCHAR*)PerlSIO_get_base(stdio);
2797 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
2799 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2800 return PerlSIO_get_bufsiz(stdio);
2804 #ifdef USE_STDIO_PTR
2806 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
2808 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2809 return (STDCHAR*)PerlSIO_get_ptr(stdio);
2813 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
2815 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2816 return PerlSIO_get_cnt(stdio);
2820 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
2822 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2824 #ifdef STDIO_PTR_LVALUE
2825 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
2826 #ifdef STDIO_PTR_LVAL_SETS_CNT
2827 if (PerlSIO_get_cnt(stdio) != (cnt)) {
2828 assert(PerlSIO_get_cnt(stdio) == (cnt));
2831 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2833 * Setting ptr _does_ change cnt - we are done
2837 #else /* STDIO_PTR_LVALUE */
2839 #endif /* STDIO_PTR_LVALUE */
2842 * Now (or only) set cnt
2844 #ifdef STDIO_CNT_LVALUE
2845 PerlSIO_set_cnt(stdio, cnt);
2846 #else /* STDIO_CNT_LVALUE */
2847 #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
2848 PerlSIO_set_ptr(stdio,
2849 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2851 #else /* STDIO_PTR_LVAL_SETS_CNT */
2853 #endif /* STDIO_PTR_LVAL_SETS_CNT */
2854 #endif /* STDIO_CNT_LVALUE */
2861 PerlIOStdio_fill(pTHX_ PerlIO *f)
2863 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2866 * fflush()ing read-only streams can cause trouble on some stdio-s
2868 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2869 if (PerlSIO_fflush(stdio) != 0)
2872 c = PerlSIO_fgetc(stdio);
2876 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2878 #ifdef STDIO_BUFFER_WRITABLE
2879 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
2880 /* Fake ungetc() to the real buffer in case system's ungetc
2883 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
2884 SSize_t cnt = PerlSIO_get_cnt(stdio);
2885 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
2886 if (ptr == base+1) {
2887 *--ptr = (STDCHAR) c;
2888 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
2889 if (PerlSIO_feof(stdio))
2890 PerlSIO_clearerr(stdio);
2896 if (PerlIO_has_cntptr(f)) {
2898 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
2905 /* An ungetc()d char is handled separately from the regular
2906 * buffer, so we stuff it in the buffer ourselves.
2907 * Should never get called as should hit code above
2909 *(--((*stdio)->_ptr)) = (unsigned char) c;
2912 /* If buffer snoop scheme above fails fall back to
2915 if (PerlSIO_ungetc(c, stdio) != c)
2923 PerlIO_funcs PerlIO_stdio = {
2925 sizeof(PerlIOStdio),
2943 PerlIOStdio_clearerr,
2944 PerlIOStdio_setlinebuf,
2946 PerlIOStdio_get_base,
2947 PerlIOStdio_get_bufsiz,
2952 #ifdef USE_STDIO_PTR
2953 PerlIOStdio_get_ptr,
2954 PerlIOStdio_get_cnt,
2955 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
2956 PerlIOStdio_set_ptrcnt
2957 #else /* STDIO_PTR_LVALUE */
2959 #endif /* STDIO_PTR_LVALUE */
2960 #else /* USE_STDIO_PTR */
2964 #endif /* USE_STDIO_PTR */
2968 PerlIO_exportFILE(PerlIO *f, const char *mode)
2974 if (!mode || !*mode) {
2975 mode = PerlIO_modestr(f,buf);
2977 stdio = fdopen(PerlIO_fileno(f), mode);
2980 PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv),
2988 PerlIO_findFILE(PerlIO *f)
2992 if (l->tab == &PerlIO_stdio) {
2993 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2996 l = *PerlIONext(&l);
2998 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
2999 return PerlIO_exportFILE(f, Nullch);
3003 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3007 if (l->tab == &PerlIO_stdio) {
3008 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3009 if (s->stdio == f) {
3011 PerlIO_pop(aTHX_ p);
3020 /*--------------------------------------------------------------------------------------*/
3022 * perlio buffer layer
3026 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3028 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3029 int fd = PerlIO_fileno(f);
3030 if (fd >= 0 && PerlLIO_isatty(fd)) {
3031 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3033 if (*PerlIONext(f)) {
3034 Off_t posn = PerlIO_tell(PerlIONext(f));
3035 if (posn != (Off_t) - 1) {
3039 return PerlIOBase_pushed(aTHX_ f, mode, arg);
3043 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3044 IV n, const char *mode, int fd, int imode, int perm,
3045 PerlIO *f, int narg, SV **args)
3047 if (PerlIOValid(f)) {
3048 PerlIO *next = PerlIONext(f);
3049 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3050 next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3052 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
3057 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3065 f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3068 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3070 * if push fails during open, open fails. close will pop us.
3075 fd = PerlIO_fileno(f);
3076 if (init && fd == 2) {
3078 * Initial stderr is unbuffered
3080 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3082 #ifdef PERLIO_USING_CRLF
3083 # ifdef PERLIO_IS_BINMODE_FD
3084 if (PERLIO_IS_BINMODE_FD(fd))
3085 PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch);
3089 * do something about failing setmode()? --jhi
3091 PerlLIO_setmode(fd, O_BINARY);
3100 * This "flush" is akin to sfio's sync in that it handles files in either
3101 * read or write state
3104 PerlIOBuf_flush(pTHX_ PerlIO *f)
3106 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3108 PerlIO *n = PerlIONext(f);
3109 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3111 * write() the buffer
3113 STDCHAR *buf = b->buf;
3115 while (p < b->ptr) {
3116 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3120 else if (count < 0 || PerlIO_error(n)) {
3121 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3126 b->posn += (p - buf);
3128 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3129 STDCHAR *buf = PerlIO_get_base(f);
3131 * Note position change
3133 b->posn += (b->ptr - buf);
3134 if (b->ptr < b->end) {
3135 /* We did not consume all of it - try and seek downstream to
3136 our logical position
3138 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3139 /* Reload n as some layers may pop themselves on seek */
3140 b->posn = PerlIO_tell(n = PerlIONext(f));
3143 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3144 data is lost for good - so return saying "ok" having undone
3147 b->posn -= (b->ptr - buf);
3152 b->ptr = b->end = b->buf;
3153 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3154 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3155 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3161 PerlIOBuf_fill(pTHX_ PerlIO *f)
3163 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3164 PerlIO *n = PerlIONext(f);
3167 * Down-stream flush is defined not to loose read data so is harmless.
3168 * we would not normally be fill'ing if there was data left in anycase.
3170 if (PerlIO_flush(f) != 0)
3172 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
3173 PerlIOBase_flush_linebuf(aTHX);
3176 PerlIO_get_base(f); /* allocate via vtable */
3178 b->ptr = b->end = b->buf;
3180 if (!PerlIOValid(n)) {
3181 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3185 if (PerlIO_fast_gets(n)) {
3187 * Layer below is also buffered. We do _NOT_ want to call its
3188 * ->Read() because that will loop till it gets what we asked for
3189 * which may hang on a pipe etc. Instead take anything it has to
3190 * hand, or ask it to fill _once_.
3192 avail = PerlIO_get_cnt(n);
3194 avail = PerlIO_fill(n);
3196 avail = PerlIO_get_cnt(n);
3198 if (!PerlIO_error(n) && PerlIO_eof(n))
3203 STDCHAR *ptr = PerlIO_get_ptr(n);
3204 SSize_t cnt = avail;
3205 if (avail > (SSize_t)b->bufsiz)
3207 Copy(ptr, b->buf, avail, STDCHAR);
3208 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3212 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3216 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3218 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3221 b->end = b->buf + avail;
3222 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3227 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3229 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3230 if (PerlIOValid(f)) {
3233 return PerlIOBase_read(aTHX_ f, vbuf, count);
3239 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3241 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3242 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3245 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3250 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3252 * Buffer is already a read buffer, we can overwrite any chars
3253 * which have been read back to buffer start
3255 avail = (b->ptr - b->buf);
3259 * Buffer is idle, set it up so whole buffer is available for
3263 b->end = b->buf + avail;
3265 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3267 * Buffer extends _back_ from where we are now
3269 b->posn -= b->bufsiz;
3271 if (avail > (SSize_t) count) {
3273 * If we have space for more than count, just move count
3281 * In simple stdio-like ungetc() case chars will be already
3284 if (buf != b->ptr) {
3285 Copy(buf, b->ptr, avail, STDCHAR);
3289 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3293 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3299 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3301 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3302 const STDCHAR *buf = (const STDCHAR *) vbuf;
3306 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3309 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3310 if ((SSize_t) count < avail)
3312 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3313 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3328 Copy(buf, b->ptr, avail, STDCHAR);
3335 if (b->ptr >= (b->buf + b->bufsiz))
3338 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3344 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3347 if ((code = PerlIO_flush(f)) == 0) {
3348 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3349 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3350 code = PerlIO_seek(PerlIONext(f), offset, whence);
3352 b->posn = PerlIO_tell(PerlIONext(f));
3359 PerlIOBuf_tell(pTHX_ PerlIO *f)
3361 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3363 * b->posn is file position where b->buf was read, or will be written
3365 Off_t posn = b->posn;
3368 * If buffer is valid adjust position by amount in buffer
3370 posn += (b->ptr - b->buf);
3376 PerlIOBuf_popped(pTHX_ PerlIO *f)
3378 IV code = PerlIOBase_popped(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_close(pTHX_ PerlIO *f)
3392 IV code = PerlIOBase_close(aTHX_ f);
3393 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3394 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3398 b->ptr = b->end = b->buf;
3399 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3404 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
3406 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3413 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
3415 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3418 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3419 return (b->end - b->ptr);
3424 PerlIOBuf_get_base(pTHX_ PerlIO *f)
3426 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3431 Newz('B',b->buf,b->bufsiz, STDCHAR);
3433 b->buf = (STDCHAR *) & b->oneword;
3434 b->bufsiz = sizeof(b->oneword);
3443 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
3445 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3448 return (b->end - b->buf);
3452 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3454 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3458 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
3459 assert(PerlIO_get_cnt(f) == cnt);
3460 assert(b->ptr >= b->buf);
3462 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3466 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3468 return PerlIOBase_dup(aTHX_ f, o, param, flags);
3473 PerlIO_funcs PerlIO_perlio = {
3493 PerlIOBase_clearerr,
3494 PerlIOBase_setlinebuf,
3499 PerlIOBuf_set_ptrcnt,
3502 /*--------------------------------------------------------------------------------------*/
3504 * Temp layer to hold unread chars when cannot do it any other way
3508 PerlIOPending_fill(pTHX_ PerlIO *f)
3511 * Should never happen
3518 PerlIOPending_close(pTHX_ PerlIO *f)
3521 * A tad tricky - flush pops us, then we close new top
3524 return PerlIO_close(f);
3528 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3531 * A tad tricky - flush pops us, then we seek new top
3534 return PerlIO_seek(f, offset, whence);
3539 PerlIOPending_flush(pTHX_ PerlIO *f)
3541 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3542 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3546 PerlIO_pop(aTHX_ f);
3551 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3557 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
3562 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3564 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
3565 PerlIOl *l = PerlIOBase(f);
3567 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3568 * etc. get muddled when it changes mid-string when we auto-pop.
3570 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3571 (PerlIOBase(PerlIONext(f))->
3572 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3577 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3579 SSize_t avail = PerlIO_get_cnt(f);
3581 if ((SSize_t)count < avail)
3584 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
3585 if (got >= 0 && got < (SSize_t)count) {
3587 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3588 if (more >= 0 || got == 0)
3594 PerlIO_funcs PerlIO_pending = {
3598 PerlIOPending_pushed,
3609 PerlIOPending_close,
3610 PerlIOPending_flush,
3614 PerlIOBase_clearerr,
3615 PerlIOBase_setlinebuf,
3620 PerlIOPending_set_ptrcnt,
3625 /*--------------------------------------------------------------------------------------*/
3627 * crlf - translation On read translate CR,LF to "\n" we do this by
3628 * overriding ptr/cnt entries to hand back a line at a time and keeping a
3629 * record of which nl we "lied" about. On write translate "\n" to CR,LF
3633 PerlIOBuf base; /* PerlIOBuf stuff */
3634 STDCHAR *nl; /* Position of crlf we "lied" about in the
3639 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
3642 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
3643 code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
3645 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3646 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3647 PerlIOBase(f)->flags);
3654 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3656 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3661 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3662 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
3664 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3665 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3667 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3672 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3673 b->end = b->ptr = b->buf + b->bufsiz;
3674 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3675 b->posn -= b->bufsiz;
3677 while (count > 0 && b->ptr > b->buf) {
3680 if (b->ptr - 2 >= b->buf) {
3703 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
3705 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3708 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3709 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3710 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3711 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
3713 while (nl < b->end && *nl != 0xd)
3715 if (nl < b->end && *nl == 0xd) {
3717 if (nl + 1 < b->end) {
3724 * Not CR,LF but just CR
3732 * Blast - found CR as last char in buffer
3737 * They may not care, defer work as long as
3741 return (nl - b->ptr);
3745 b->ptr++; /* say we have read it as far as
3746 * flush() is concerned */
3747 b->buf++; /* Leave space in front of buffer */
3748 b->bufsiz--; /* Buffer is thus smaller */
3749 code = PerlIO_fill(f); /* Fetch some more */
3750 b->bufsiz++; /* Restore size for next time */
3751 b->buf--; /* Point at space */
3752 b->ptr = nl = b->buf; /* Which is what we hand
3754 b->posn--; /* Buffer starts here */
3755 *nl = 0xd; /* Fill in the CR */
3757 goto test; /* fill() call worked */
3759 * CR at EOF - just fall through
3761 /* Should we clear EOF though ??? */
3766 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3772 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3774 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3775 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3781 if (ptr == b->end && *c->nl == 0xd) {
3782 /* Defered CR at end of buffer case - we lied about count */
3794 * Test code - delete when it works ...
3796 IV flags = PerlIOBase(f)->flags;
3797 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
3798 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3799 /* Defered CR at end of buffer case - we lied about count */
3805 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
3806 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3814 * They have taken what we lied about
3822 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3826 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3828 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3829 return PerlIOBuf_write(aTHX_ f, vbuf, count);
3831 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3832 const STDCHAR *buf = (const STDCHAR *) vbuf;
3833 const STDCHAR *ebuf = buf + count;
3836 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3838 while (buf < ebuf) {
3839 STDCHAR *eptr = b->buf + b->bufsiz;
3840 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3841 while (buf < ebuf && b->ptr < eptr) {
3843 if ((b->ptr + 2) > eptr) {
3851 *(b->ptr)++ = 0xd; /* CR */
3852 *(b->ptr)++ = 0xa; /* LF */
3854 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3864 if (b->ptr >= eptr) {
3870 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3872 return (buf - (STDCHAR *) vbuf);
3877 PerlIOCrlf_flush(pTHX_ PerlIO *f)
3879 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3884 return PerlIOBuf_flush(aTHX_ f);
3887 PerlIO_funcs PerlIO_crlf = {
3890 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3892 PerlIOBuf_popped, /* popped */
3897 PerlIOBuf_read, /* generic read works with ptr/cnt lies
3899 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3900 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3908 PerlIOBase_clearerr,
3909 PerlIOBase_setlinebuf,
3914 PerlIOCrlf_set_ptrcnt,
3918 /*--------------------------------------------------------------------------------------*/
3920 * mmap as "buffer" layer
3924 PerlIOBuf base; /* PerlIOBuf stuff */
3925 Mmap_t mptr; /* Mapped address */
3926 Size_t len; /* mapped length */
3927 STDCHAR *bbuf; /* malloced buffer if map fails */
3930 static size_t page_size = 0;
3933 PerlIOMmap_map(pTHX_ PerlIO *f)
3935 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3936 IV flags = PerlIOBase(f)->flags;
3940 if (flags & PERLIO_F_CANREAD) {
3941 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3942 int fd = PerlIO_fileno(f);
3944 code = Fstat(fd, &st);
3945 if (code == 0 && S_ISREG(st.st_mode)) {
3946 SSize_t len = st.st_size - b->posn;
3950 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3952 SETERRNO(0, SS$_NORMAL);
3953 # ifdef _SC_PAGESIZE
3954 page_size = sysconf(_SC_PAGESIZE);
3956 page_size = sysconf(_SC_PAGE_SIZE);
3958 if ((long) page_size < 0) {
3963 (void) SvUPGRADE(error, SVt_PV);
3964 msg = SvPVx(error, n_a);
3965 Perl_croak(aTHX_ "panic: sysconf: %s",
3970 "panic: sysconf: pagesize unknown");
3974 # ifdef HAS_GETPAGESIZE
3975 page_size = getpagesize();
3977 # if defined(I_SYS_PARAM) && defined(PAGESIZE)
3978 page_size = PAGESIZE; /* compiletime, bad */
3982 if ((IV) page_size <= 0)
3983 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3988 * This is a hack - should never happen - open should
3991 b->posn = PerlIO_tell(PerlIONext(f));
3993 posn = (b->posn / page_size) * page_size;
3994 len = st.st_size - posn;
3995 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3996 if (m->mptr && m->mptr != (Mmap_t) - 1) {
3997 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
3998 madvise(m->mptr, len, MADV_SEQUENTIAL);
4000 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
4001 madvise(m->mptr, len, MADV_WILLNEED);
4003 PerlIOBase(f)->flags =
4004 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4005 b->end = ((STDCHAR *) m->mptr) + len;
4006 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4015 PerlIOBase(f)->flags =
4016 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4018 b->ptr = b->end = b->ptr;
4027 PerlIOMmap_unmap(pTHX_ PerlIO *f)
4029 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4030 PerlIOBuf *b = &m->base;
4034 code = munmap(m->mptr, m->len);
4038 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4041 b->ptr = b->end = b->buf;
4042 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4048 PerlIOMmap_get_base(pTHX_ PerlIO *f)
4050 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4051 PerlIOBuf *b = &m->base;
4052 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4054 * Already have a readbuffer in progress
4060 * We have a write buffer or flushed PerlIOBuf read buffer
4062 m->bbuf = b->buf; /* save it in case we need it again */
4063 b->buf = NULL; /* Clear to trigger below */
4066 PerlIOMmap_map(aTHX_ f); /* Try and map it */
4069 * Map did not work - recover PerlIOBuf buffer if we have one
4074 b->ptr = b->end = b->buf;
4077 return PerlIOBuf_get_base(aTHX_ f);
4081 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4083 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4084 PerlIOBuf *b = &m->base;
4085 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4087 if (b->ptr && (b->ptr - count) >= b->buf
4088 && memEQ(b->ptr - count, vbuf, count)) {
4090 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4095 * Loose the unwritable mapped buffer
4099 * If flush took the "buffer" see if we have one from before
4101 if (!b->buf && m->bbuf)
4104 PerlIOBuf_get_base(aTHX_ f);
4108 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4112 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4114 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4115 PerlIOBuf *b = &m->base;
4116 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4118 * No, or wrong sort of, buffer
4121 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4125 * If unmap took the "buffer" see if we have one from before
4127 if (!b->buf && m->bbuf)
4130 PerlIOBuf_get_base(aTHX_ f);
4134 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4138 PerlIOMmap_flush(pTHX_ PerlIO *f)
4140 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4141 PerlIOBuf *b = &m->base;
4142 IV code = PerlIOBuf_flush(aTHX_ f);
4144 * Now we are "synced" at PerlIOBuf level
4151 if (PerlIOMmap_unmap(aTHX_ f) != 0)
4156 * We seem to have a PerlIOBuf buffer which was not mapped
4157 * remember it in case we need one later
4166 PerlIOMmap_fill(pTHX_ PerlIO *f)
4168 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4169 IV code = PerlIO_flush(f);
4170 if (code == 0 && !b->buf) {
4171 code = PerlIOMmap_map(aTHX_ f);
4173 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4174 code = PerlIOBuf_fill(aTHX_ f);
4180 PerlIOMmap_close(pTHX_ PerlIO *f)
4182 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
4183 PerlIOBuf *b = &m->base;
4184 IV code = PerlIO_flush(f);
4188 b->ptr = b->end = b->buf;
4190 if (PerlIOBuf_close(aTHX_ f) != 0)
4196 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4198 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4202 PerlIO_funcs PerlIO_mmap = {
4222 PerlIOBase_clearerr,
4223 PerlIOBase_setlinebuf,
4224 PerlIOMmap_get_base,
4228 PerlIOBuf_set_ptrcnt,
4231 #endif /* HAS_MMAP */
4234 Perl_PerlIO_stdin(pTHX)
4237 PerlIO_stdstreams(aTHX);
4239 return &PL_perlio[1];
4243 Perl_PerlIO_stdout(pTHX)
4246 PerlIO_stdstreams(aTHX);
4248 return &PL_perlio[2];
4252 Perl_PerlIO_stderr(pTHX)
4255 PerlIO_stdstreams(aTHX);
4257 return &PL_perlio[3];
4260 /*--------------------------------------------------------------------------------------*/
4263 PerlIO_getname(PerlIO *f, char *buf)
4268 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4270 name = fgetname(stdio, buf);
4272 Perl_croak(aTHX_ "Don't know how to get file name");
4278 /*--------------------------------------------------------------------------------------*/
4280 * Functions which can be called on any kind of PerlIO implemented in
4284 #undef PerlIO_fdopen
4286 PerlIO_fdopen(int fd, const char *mode)
4289 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4294 PerlIO_open(const char *path, const char *mode)
4297 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4298 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4301 #undef Perlio_reopen
4303 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4306 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4307 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4312 PerlIO_getc(PerlIO *f)
4316 SSize_t count = PerlIO_read(f, buf, 1);
4318 return (unsigned char) buf[0];
4323 #undef PerlIO_ungetc
4325 PerlIO_ungetc(PerlIO *f, int ch)
4330 if (PerlIO_unread(f, &buf, 1) == 1)
4338 PerlIO_putc(PerlIO *f, int ch)
4342 return PerlIO_write(f, &buf, 1);
4347 PerlIO_puts(PerlIO *f, const char *s)
4350 STRLEN len = strlen(s);
4351 return PerlIO_write(f, s, len);
4354 #undef PerlIO_rewind
4356 PerlIO_rewind(PerlIO *f)
4359 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4363 #undef PerlIO_vprintf
4365 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4368 SV *sv = newSVpvn("", 0);
4374 Perl_va_copy(ap, apc);
4375 sv_vcatpvf(sv, fmt, &apc);
4377 sv_vcatpvf(sv, fmt, &ap);
4380 wrote = PerlIO_write(f, s, len);
4385 #undef PerlIO_printf
4387 PerlIO_printf(PerlIO *f, const char *fmt, ...)
4392 result = PerlIO_vprintf(f, fmt, ap);
4397 #undef PerlIO_stdoutf
4399 PerlIO_stdoutf(const char *fmt, ...)
4405 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4410 #undef PerlIO_tmpfile
4412 PerlIO_tmpfile(void)
4415 * I have no idea how portable mkstemp() is ...
4417 #if defined(WIN32) || !defined(HAVE_MKSTEMP)
4420 FILE *stdio = PerlSIO_tmpfile();
4423 PerlIOSelf(PerlIO_push
4424 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4425 "w+", Nullsv), PerlIOStdio);
4431 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4432 int fd = mkstemp(SvPVX(sv));
4435 f = PerlIO_fdopen(fd, "w+");
4437 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4439 PerlLIO_unlink(SvPVX(sv));
4449 #endif /* USE_SFIO */
4450 #endif /* PERLIO_IS_STDIO */
4452 /*======================================================================================*/
4454 * Now some functions in terms of above which may be needed even if we are
4455 * not in true PerlIO mode
4459 #undef PerlIO_setpos
4461 PerlIO_setpos(PerlIO *f, SV *pos)
4466 Off_t *posn = (Off_t *) SvPV(pos, len);
4467 if (f && len == sizeof(Off_t))
4468 return PerlIO_seek(f, *posn, SEEK_SET);
4470 SETERRNO(EINVAL, SS$_IVCHAN);
4474 #undef PerlIO_setpos
4476 PerlIO_setpos(PerlIO *f, SV *pos)
4481 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4482 if (f && len == sizeof(Fpos_t)) {
4483 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4484 return fsetpos64(f, fpos);
4486 return fsetpos(f, fpos);
4490 SETERRNO(EINVAL, SS$_IVCHAN);
4496 #undef PerlIO_getpos
4498 PerlIO_getpos(PerlIO *f, SV *pos)
4501 Off_t posn = PerlIO_tell(f);
4502 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4503 return (posn == (Off_t) - 1) ? -1 : 0;
4506 #undef PerlIO_getpos
4508 PerlIO_getpos(PerlIO *f, SV *pos)
4513 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
4514 code = fgetpos64(f, &fpos);
4516 code = fgetpos(f, &fpos);
4518 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4523 #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4526 vprintf(char *pat, char *args)
4528 _doprnt(pat, args, stdout);
4529 return 0; /* wrong, but perl doesn't use the return
4534 vfprintf(FILE *fd, char *pat, char *args)
4536 _doprnt(pat, args, fd);
4537 return 0; /* wrong, but perl doesn't use the return
4543 #ifndef PerlIO_vsprintf
4545 PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
4547 int val = vsprintf(s, fmt, ap);
4549 if (strlen(s) >= (STRLEN) n) {
4551 (void) PerlIO_puts(Perl_error_log,
4552 "panic: sprintf overflow - memory corrupted!\n");
4560 #ifndef PerlIO_sprintf
4562 PerlIO_sprintf(char *s, int n, const char *fmt, ...)
4567 result = PerlIO_vsprintf(s, n, fmt, ap);