This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
This *really* should clear up Win32's Perl_do_exec undefined warnings
[perl5.git] / perlio.c
CommitLineData
14a5cf38 1/*
cbdf9ef8 2 * perlio.c Copyright (c) 1996-2005, Nick Ing-Simmons You may distribute
14a5cf38 3 * under the terms of either the GNU General Public License or the
71200d45 4 * Artistic License, as specified in the README file.
760ac839
LW
5 */
6
14a5cf38 7/*
d31a8517
AT
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.
10 */
11
166f8a29
DM
12/* This file contains the functions needed to implement PerlIO, which
13 * is Perl's private replacement for the C stdio library. This is used
14 * by default unless you compile with -Uuseperlio or run with
15 * PERLIO=:stdio (but don't do this unless you know what you're doing)
16 */
17
d31a8517 18/*
71200d45 19 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
14a5cf38 20 * at the dispatch tables, even when we do not need it for other reasons.
71200d45 21 * Invent a dSYS macro to abstract this out
14a5cf38 22 */
7bcba3d4
NIS
23#ifdef PERL_IMPLICIT_SYS
24#define dSYS dTHX
25#else
26#define dSYS dNOOP
27#endif
28
760ac839 29#define VOIDUSED 1
12ae5dfc
JH
30#ifdef PERL_MICRO
31# include "uconfig.h"
32#else
33# include "config.h"
34#endif
760ac839 35
6f9d8c32 36#define PERLIO_NOT_STDIO 0
760ac839 37#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
14a5cf38 38/*
71200d45 39 * #define PerlIO FILE
14a5cf38 40 */
760ac839
LW
41#endif
42/*
6f9d8c32 43 * This file provides those parts of PerlIO abstraction
88b61e10 44 * which are not #defined in perlio.h.
6f9d8c32 45 * Which these are depends on various Configure #ifdef's
760ac839
LW
46 */
47
48#include "EXTERN.h"
864dbfa3 49#define PERL_IN_PERLIO_C
760ac839
LW
50#include "perl.h"
51
32af7c23
CL
52#ifdef PERL_IMPLICIT_CONTEXT
53#undef dSYS
54#define dSYS dTHX
55#endif
56
0c4f7ff0
NIS
57#include "XSUB.h"
58
27da23d5
JH
59#define PERLIO_MAX_REFCOUNTABLE_FD 2048
60
9cffb111
OS
61#ifdef __Lynx__
62/* Missing proto on LynxOS */
63int mkstemp(char*);
64#endif
65
1b7a0411 66/* Call the callback or PerlIOBase, and return failure. */
b32dd47e 67#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
1b7a0411 68 if (PerlIOValid(f)) { \
46c461b5 69 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
70 if (tab && tab->callback) \
71 return (*tab->callback) args; \
72 else \
73 return PerlIOBase_ ## base args; \
74 } \
75 else \
76 SETERRNO(EBADF, SS_IVCHAN); \
77 return failure
78
79/* Call the callback or fail, and return failure. */
b32dd47e 80#define Perl_PerlIO_or_fail(f, callback, failure, args) \
1b7a0411 81 if (PerlIOValid(f)) { \
46c461b5 82 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
83 if (tab && tab->callback) \
84 return (*tab->callback) args; \
85 SETERRNO(EINVAL, LIB_INVARG); \
86 } \
87 else \
88 SETERRNO(EBADF, SS_IVCHAN); \
89 return failure
90
91/* Call the callback or PerlIOBase, and be void. */
b32dd47e 92#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
1b7a0411 93 if (PerlIOValid(f)) { \
46c461b5 94 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
95 if (tab && tab->callback) \
96 (*tab->callback) args; \
97 else \
98 PerlIOBase_ ## base args; \
1b7a0411
JH
99 } \
100 else \
101 SETERRNO(EBADF, SS_IVCHAN)
102
103/* Call the callback or fail, and be void. */
b32dd47e 104#define Perl_PerlIO_or_fail_void(f, callback, args) \
1b7a0411 105 if (PerlIOValid(f)) { \
46c461b5 106 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH
107 if (tab && tab->callback) \
108 (*tab->callback) args; \
37725cdc
NIS
109 else \
110 SETERRNO(EINVAL, LIB_INVARG); \
1b7a0411
JH
111 } \
112 else \
113 SETERRNO(EBADF, SS_IVCHAN)
114
71ab4674
SP
115#ifndef USE_SFIO
116int
117perlsio_binmode(FILE *fp, int iotype, int mode)
118{
119 /*
120 * This used to be contents of do_binmode in doio.c
121 */
122#ifdef DOSISH
123# if defined(atarist) || defined(__MINT__)
124 if (!fflush(fp)) {
125 if (mode & O_BINARY)
126 ((FILE *) fp)->_flag |= _IOBIN;
127 else
128 ((FILE *) fp)->_flag &= ~_IOBIN;
129 return 1;
130 }
131 return 0;
132# else
133 dTHX;
134#ifdef NETWARE
135 if (PerlLIO_setmode(fp, mode) != -1) {
136#else
137 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
138#endif
139# if defined(WIN32) && defined(__BORLANDC__)
140 /*
141 * The translation mode of the stream is maintained independent
142of
143 * the translation mode of the fd in the Borland RTL (heavy
144 * digging through their runtime sources reveal). User has to
145set
146 * the mode explicitly for the stream (though they don't
147document
148 * this anywhere). GSAR 97-5-24
149 */
150 fseek(fp, 0L, 0);
151 if (mode & O_BINARY)
152 fp->flags |= _F_BIN;
153 else
154 fp->flags &= ~_F_BIN;
155# endif
156 return 1;
157 }
158 else
159 return 0;
160# endif
161#else
162# if defined(USEMYBINMODE)
163 dTHX;
164 if (my_binmode(fp, iotype, mode) != FALSE)
165 return 1;
166 else
167 return 0;
168# else
169 PERL_UNUSED_ARG(fp);
170 PERL_UNUSED_ARG(iotype);
171 PERL_UNUSED_ARG(mode);
172 return 1;
173# endif
174#endif
175}
176#endif /* sfio */
177
06c7082d 178#ifndef O_ACCMODE
22569500 179#define O_ACCMODE 3 /* Assume traditional implementation */
06c7082d
NIS
180#endif
181
182int
183PerlIO_intmode2str(int rawmode, char *mode, int *writing)
184{
de009b76 185 const int result = rawmode & O_ACCMODE;
06c7082d
NIS
186 int ix = 0;
187 int ptype;
188 switch (result) {
189 case O_RDONLY:
190 ptype = IoTYPE_RDONLY;
191 break;
192 case O_WRONLY:
193 ptype = IoTYPE_WRONLY;
194 break;
195 case O_RDWR:
196 default:
197 ptype = IoTYPE_RDWR;
198 break;
199 }
200 if (writing)
201 *writing = (result != O_RDONLY);
202
203 if (result == O_RDONLY) {
204 mode[ix++] = 'r';
205 }
206#ifdef O_APPEND
207 else if (rawmode & O_APPEND) {
208 mode[ix++] = 'a';
209 if (result != O_WRONLY)
210 mode[ix++] = '+';
211 }
212#endif
213 else {
214 if (result == O_WRONLY)
215 mode[ix++] = 'w';
216 else {
217 mode[ix++] = 'r';
218 mode[ix++] = '+';
219 }
220 }
221 if (rawmode & O_BINARY)
222 mode[ix++] = 'b';
223 mode[ix] = '\0';
224 return ptype;
225}
226
eb73beca
NIS
227#ifndef PERLIO_LAYERS
228int
229PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
230{
6874a2de
NIS
231 if (!names || !*names
232 || strEQ(names, ":crlf")
233 || strEQ(names, ":raw")
234 || strEQ(names, ":bytes")
235 ) {
14a5cf38
JH
236 return 0;
237 }
238 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
239 /*
71200d45 240 * NOTREACHED
14a5cf38
JH
241 */
242 return -1;
eb73beca
NIS
243}
244
13621cfb
NIS
245void
246PerlIO_destruct(pTHX)
247{
248}
249
f5b9d040
NIS
250int
251PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
252{
92bff44d 253#ifdef USE_SFIO
8772537c
AL
254 PERL_UNUSED_ARG(iotype);
255 PERL_UNUSED_ARG(mode);
256 PERL_UNUSED_ARG(names);
14a5cf38 257 return 1;
92bff44d 258#else
14a5cf38 259 return perlsio_binmode(fp, iotype, mode);
92bff44d 260#endif
f5b9d040 261}
60382766 262
e0fa5af2 263PerlIO *
ecdeb87c 264PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
e0fa5af2 265{
a0fd4948 266#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
0553478e
NIS
267 return NULL;
268#else
269#ifdef PERL_IMPLICIT_SYS
22569500 270 return PerlSIO_fdupopen(f);
0553478e 271#else
30753f56
NIS
272#ifdef WIN32
273 return win32_fdupopen(f);
274#else
e0fa5af2 275 if (f) {
504618e9 276 const int fd = PerlLIO_dup(PerlIO_fileno(f));
e0fa5af2 277 if (fd >= 0) {
06c7082d
NIS
278 char mode[8];
279 int omode = fcntl(fd, F_GETFL);
a5936e02
JH
280#ifdef DJGPP
281 omode = djgpp_get_stream_mode(f);
282#endif
06c7082d 283 PerlIO_intmode2str(omode,mode,NULL);
e0fa5af2 284 /* the r+ is a hack */
06c7082d 285 return PerlIO_fdopen(fd, mode);
e0fa5af2
NIS
286 }
287 return NULL;
288 }
289 else {
93189314 290 SETERRNO(EBADF, SS_IVCHAN);
e0fa5af2 291 }
7114a2d2 292#endif
e0fa5af2 293 return NULL;
0553478e 294#endif
30753f56 295#endif
e0fa5af2
NIS
296}
297
298
14a5cf38 299/*
71200d45 300 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
14a5cf38 301 */
ee518936
NIS
302
303PerlIO *
14a5cf38
JH
304PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
305 int imode, int perm, PerlIO *old, int narg, SV **args)
306{
7cf31beb
NIS
307 if (narg) {
308 if (narg > 1) {
3b8752bb 309 Perl_croak(aTHX_ "More than one argument to open");
7cf31beb 310 }
14a5cf38
JH
311 if (*args == &PL_sv_undef)
312 return PerlIO_tmpfile();
313 else {
e62f0680 314 const char *name = SvPV_nolen_const(*args);
3b6c1aba 315 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
316 fd = PerlLIO_open3(name, imode, perm);
317 if (fd >= 0)
de009b76 318 return PerlIO_fdopen(fd, mode + 1);
14a5cf38
JH
319 }
320 else if (old) {
321 return PerlIO_reopen(name, mode, old);
322 }
323 else {
324 return PerlIO_open(name, mode);
325 }
326 }
327 }
328 else {
329 return PerlIO_fdopen(fd, (char *) mode);
330 }
331 return NULL;
ee518936
NIS
332}
333
0c4f7ff0
NIS
334XS(XS_PerlIO__Layer__find)
335{
14a5cf38
JH
336 dXSARGS;
337 if (items < 2)
338 Perl_croak(aTHX_ "Usage class->find(name[,load])");
339 else {
e62f0680 340 const char *name = SvPV_nolen_const(ST(1));
14a5cf38
JH
341 ST(0) = (strEQ(name, "crlf")
342 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
343 XSRETURN(1);
344 }
0c4f7ff0
NIS
345}
346
347
348void
349Perl_boot_core_PerlIO(pTHX)
350{
14a5cf38 351 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
0c4f7ff0
NIS
352}
353
ac27b0f5
NIS
354#endif
355
32e30700 356
6f9d8c32 357#ifdef PERLIO_IS_STDIO
760ac839
LW
358
359void
e8632036 360PerlIO_init(pTHX)
760ac839 361{
14a5cf38
JH
362 /*
363 * Does nothing (yet) except force this file to be included in perl
71200d45 364 * binary. That allows this file to force inclusion of other functions
14a5cf38 365 * that may be required by loadable extensions e.g. for
71200d45 366 * FileHandle::tmpfile
14a5cf38 367 */
760ac839
LW
368}
369
33dcbb9a
PP
370#undef PerlIO_tmpfile
371PerlIO *
8ac85365 372PerlIO_tmpfile(void)
33dcbb9a 373{
14a5cf38 374 return tmpfile();
33dcbb9a
PP
375}
376
22569500 377#else /* PERLIO_IS_STDIO */
760ac839
LW
378
379#ifdef USE_SFIO
380
381#undef HAS_FSETPOS
382#undef HAS_FGETPOS
383
14a5cf38
JH
384/*
385 * This section is just to make sure these functions get pulled in from
71200d45 386 * libsfio.a
14a5cf38 387 */
760ac839
LW
388
389#undef PerlIO_tmpfile
390PerlIO *
c78749f2 391PerlIO_tmpfile(void)
760ac839 392{
14a5cf38 393 return sftmp(0);
760ac839
LW
394}
395
396void
e8632036 397PerlIO_init(pTHX)
760ac839 398{
14a5cf38
JH
399 /*
400 * Force this file to be included in perl binary. Which allows this
401 * file to force inclusion of other functions that may be required by
71200d45 402 * loadable extensions e.g. for FileHandle::tmpfile
14a5cf38 403 */
760ac839 404
14a5cf38 405 /*
71200d45 406 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
14a5cf38 407 * results in a lot of lseek()s to regular files and lot of small
71200d45 408 * writes to pipes.
14a5cf38
JH
409 */
410 sfset(sfstdout, SF_SHARE, 0);
760ac839
LW
411}
412
b9d6bf13 413/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
92bff44d 414PerlIO *
4b069b44 415PerlIO_importFILE(FILE *stdio, const char *mode)
92bff44d 416{
de009b76 417 const int fd = fileno(stdio);
4b069b44 418 if (!mode || !*mode) {
81428673 419 mode = "r+";
4b069b44
NIS
420 }
421 return PerlIO_fdopen(fd, mode);
92bff44d
NIS
422}
423
424FILE *
425PerlIO_findFILE(PerlIO *pio)
426{
de009b76
AL
427 const int fd = PerlIO_fileno(pio);
428 FILE * const f = fdopen(fd, "r+");
14a5cf38
JH
429 PerlIO_flush(pio);
430 if (!f && errno == EINVAL)
431 f = fdopen(fd, "w");
432 if (!f && errno == EINVAL)
433 f = fdopen(fd, "r");
434 return f;
92bff44d
NIS
435}
436
437
22569500 438#else /* USE_SFIO */
6f9d8c32 439/*======================================================================================*/
14a5cf38 440/*
71200d45 441 * Implement all the PerlIO interface ourselves.
9e353e3b 442 */
760ac839 443
76ced9ad
NIS
444#include "perliol.h"
445
14a5cf38
JH
446/*
447 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
71200d45 448 * files
14a5cf38 449 */
02f66e2f
NIS
450#ifdef I_UNISTD
451#include <unistd.h>
452#endif
06da4f11
NIS
453#ifdef HAS_MMAP
454#include <sys/mman.h>
455#endif
456
6f9d8c32 457void
14a5cf38
JH
458PerlIO_debug(const char *fmt, ...)
459{
14a5cf38
JH
460 va_list ap;
461 dSYS;
462 va_start(ap, fmt);
27da23d5 463 if (!PL_perlio_debug_fd && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
de009b76 464 const char *s = PerlEnv_getenv("PERLIO_DEBUG");
14a5cf38 465 if (s && *s)
27da23d5 466 PL_perlio_debug_fd = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
14a5cf38 467 else
27da23d5 468 PL_perlio_debug_fd = -1;
14a5cf38 469 }
27da23d5 470 if (PL_perlio_debug_fd > 0) {
14a5cf38 471 dTHX;
de009b76 472 STRLEN len;
c4420975 473 const char *s = CopFILE(PL_curcop);
70ace5da
NIS
474#ifdef USE_ITHREADS
475 /* Use fixed buffer as sv_catpvf etc. needs SVs */
476 char buffer[1024];
70ace5da
NIS
477 if (!s)
478 s = "(none)";
c4420975 479 len = my_sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop));
70ace5da 480 vsprintf(buffer+len, fmt, ap);
27da23d5 481 PerlLIO_write(PL_perlio_debug_fd, buffer, strlen(buffer));
70ace5da 482#else
c4420975 483 SV * const sv = newSVpvn("", 0);
14a5cf38
JH
484 if (!s)
485 s = "(none)";
486 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s,
487 (IV) CopLINE(PL_curcop));
488 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
489
b83604b4 490 s = SvPV_const(sv, len);
27da23d5 491 PerlLIO_write(PL_perlio_debug_fd, s, len);
14a5cf38 492 SvREFCNT_dec(sv);
70ace5da 493#endif
14a5cf38
JH
494 }
495 va_end(ap);
6f9d8c32
NIS
496}
497
9e353e3b
NIS
498/*--------------------------------------------------------------------------------------*/
499
14a5cf38 500/*
71200d45 501 * Inner level routines
14a5cf38 502 */
9e353e3b 503
14a5cf38 504/*
71200d45 505 * Table of pointers to the PerlIO structs (malloc'ed)
14a5cf38 506 */
05d1247b 507#define PERLIO_TABLE_SIZE 64
6f9d8c32 508
760ac839 509PerlIO *
5f1a76d0 510PerlIO_allocate(pTHX)
6f9d8c32 511{
14a5cf38 512 /*
71200d45 513 * Find a free slot in the table, allocating new table as necessary
14a5cf38
JH
514 */
515 PerlIO **last;
516 PerlIO *f;
a1ea730d 517 last = &PL_perlio;
14a5cf38
JH
518 while ((f = *last)) {
519 int i;
520 last = (PerlIO **) (f);
521 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
522 if (!*++f) {
523 return f;
524 }
525 }
526 }
a02a5408 527 Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
14a5cf38
JH
528 if (!f) {
529 return NULL;
530 }
531 *last = f;
532 return f + 1;
05d1247b
NIS
533}
534
a1ea730d
NIS
535#undef PerlIO_fdupopen
536PerlIO *
ecdeb87c 537PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
a1ea730d 538{
04892f78 539 if (PerlIOValid(f)) {
de009b76 540 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
fe5a182c 541 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
210e727c
JH
542 if (tab && tab->Dup)
543 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
37725cdc
NIS
544 else {
545 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
546 }
a1ea730d 547 }
210e727c
JH
548 else
549 SETERRNO(EBADF, SS_IVCHAN);
550
551 return NULL;
a1ea730d
NIS
552}
553
554void
5f1a76d0 555PerlIO_cleantable(pTHX_ PerlIO **tablep)
05d1247b 556{
14a5cf38
JH
557 PerlIO *table = *tablep;
558 if (table) {
559 int i;
560 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
561 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
562 PerlIO *f = table + i;
563 if (*f) {
564 PerlIO_close(f);
565 }
566 }
3a1ee7e8 567 Safefree(table);
14a5cf38 568 *tablep = NULL;
05d1247b 569 }
05d1247b
NIS
570}
571
fcf2db38
NIS
572
573PerlIO_list_t *
3a1ee7e8 574PerlIO_list_alloc(pTHX)
fcf2db38 575{
14a5cf38 576 PerlIO_list_t *list;
a02a5408 577 Newxz(list, 1, PerlIO_list_t);
14a5cf38
JH
578 list->refcnt = 1;
579 return list;
fcf2db38
NIS
580}
581
582void
3a1ee7e8 583PerlIO_list_free(pTHX_ PerlIO_list_t *list)
fcf2db38 584{
14a5cf38
JH
585 if (list) {
586 if (--list->refcnt == 0) {
587 if (list->array) {
14a5cf38
JH
588 IV i;
589 for (i = 0; i < list->cur; i++) {
590 if (list->array[i].arg)
591 SvREFCNT_dec(list->array[i].arg);
592 }
593 Safefree(list->array);
594 }
595 Safefree(list);
596 }
597 }
fcf2db38
NIS
598}
599
600void
3a1ee7e8 601PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
14a5cf38 602{
14a5cf38
JH
603 PerlIO_pair_t *p;
604 if (list->cur >= list->len) {
605 list->len += 8;
606 if (list->array)
607 Renew(list->array, list->len, PerlIO_pair_t);
608 else
a02a5408 609 Newx(list->array, list->len, PerlIO_pair_t);
14a5cf38
JH
610 }
611 p = &(list->array[list->cur++]);
612 p->funcs = funcs;
613 if ((p->arg = arg)) {
7fc63493 614 (void)SvREFCNT_inc(arg);
14a5cf38 615 }
fcf2db38
NIS
616}
617
3a1ee7e8
NIS
618PerlIO_list_t *
619PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
620{
694c95cf
JH
621 PerlIO_list_t *list = (PerlIO_list_t *) NULL;
622 if (proto) {
623 int i;
624 list = PerlIO_list_alloc(aTHX);
625 for (i=0; i < proto->cur; i++) {
626 SV *arg = Nullsv;
627 if (proto->array[i].arg)
628 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
629 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
630 }
3a1ee7e8
NIS
631 }
632 return list;
633}
4a4a6116 634
05d1247b 635void
3a1ee7e8 636PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
9a6404c5 637{
3aaf42a7 638#ifdef USE_ITHREADS
3a1ee7e8
NIS
639 PerlIO **table = &proto->Iperlio;
640 PerlIO *f;
641 PL_perlio = NULL;
642 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
643 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
644 PerlIO_allocate(aTHX); /* root slot is never used */
694c95cf 645 PerlIO_debug("Clone %p from %p\n",aTHX,proto);
3a1ee7e8
NIS
646 while ((f = *table)) {
647 int i;
648 table = (PerlIO **) (f++);
649 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
650 if (*f) {
93a8090d 651 (void) fp_dup(f, 0, param);
3a1ee7e8
NIS
652 }
653 f++;
654 }
655 }
1b6737cc
AL
656#else
657 PERL_UNUSED_ARG(proto);
658 PERL_UNUSED_ARG(param);
3aaf42a7 659#endif
9a6404c5
DM
660}
661
662void
13621cfb
NIS
663PerlIO_destruct(pTHX)
664{
a1ea730d 665 PerlIO **table = &PL_perlio;
14a5cf38 666 PerlIO *f;
694c95cf
JH
667#ifdef USE_ITHREADS
668 PerlIO_debug("Destruct %p\n",aTHX);
669#endif
14a5cf38
JH
670 while ((f = *table)) {
671 int i;
672 table = (PerlIO **) (f++);
673 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
674 PerlIO *x = f;
675 PerlIOl *l;
676 while ((l = *x)) {
677 if (l->tab->kind & PERLIO_K_DESTRUCT) {
678 PerlIO_debug("Destruct popping %s\n", l->tab->name);
679 PerlIO_flush(x);
680 PerlIO_pop(aTHX_ x);
681 }
682 else {
683 x = PerlIONext(x);
684 }
685 }
686 f++;
687 }
688 }
13621cfb
NIS
689}
690
691void
a999f61b 692PerlIO_pop(pTHX_ PerlIO *f)
760ac839 693{
14a5cf38
JH
694 PerlIOl *l = *f;
695 if (l) {
fe5a182c 696 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
14a5cf38
JH
697 if (l->tab->Popped) {
698 /*
699 * If popped returns non-zero do not free its layer structure
700 * it has either done so itself, or it is shared and still in
71200d45 701 * use
14a5cf38 702 */
f62ce20a 703 if ((*l->tab->Popped) (aTHX_ f) != 0)
14a5cf38
JH
704 return;
705 }
b47cad08 706 *f = l->next;
3a1ee7e8 707 Safefree(l);
a8c08ecd 708 }
6f9d8c32
NIS
709}
710
39f7a870
JH
711/* Return as an array the stack of layers on a filehandle. Note that
712 * the stack is returned top-first in the array, and there are three
713 * times as many array elements as there are layers in the stack: the
714 * first element of a layer triplet is the name, the second one is the
715 * arguments, and the third one is the flags. */
716
717AV *
718PerlIO_get_layers(pTHX_ PerlIO *f)
719{
720 AV *av = newAV();
721
722 if (PerlIOValid(f)) {
39f7a870
JH
723 PerlIOl *l = PerlIOBase(f);
724
725 while (l) {
726 SV *name = l->tab && l->tab->name ?
727 newSVpv(l->tab->name, 0) : &PL_sv_undef;
728 SV *arg = l->tab && l->tab->Getarg ?
729 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
730 av_push(av, name);
731 av_push(av, arg);
732 av_push(av, newSViv((IV)l->flags));
733 l = l->next;
734 }
735 }
736
737 return av;
738}
739
9e353e3b 740/*--------------------------------------------------------------------------------------*/
14a5cf38 741/*
71200d45 742 * XS Interface for perl code
14a5cf38 743 */
9e353e3b 744
fcf2db38 745PerlIO_funcs *
2edd7e44 746PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
f3862f8b 747{
27da23d5 748 dVAR;
14a5cf38
JH
749 IV i;
750 if ((SSize_t) len <= 0)
751 len = strlen(name);
3a1ee7e8 752 for (i = 0; i < PL_known_layers->cur; i++) {
46c461b5 753 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
a9f76400 754 if (memEQ(f->name, name, len) && f->name[len] == 0) {
fe5a182c 755 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
14a5cf38
JH
756 return f;
757 }
758 }
3a1ee7e8
NIS
759 if (load && PL_subname && PL_def_layerlist
760 && PL_def_layerlist->cur >= 2) {
d7a09b41
SR
761 if (PL_in_load_module) {
762 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
763 return NULL;
764 } else {
46c461b5
AL
765 SV * const pkgsv = newSVpvn("PerlIO", 6);
766 SV * const layer = newSVpvn(name, len);
767 CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
768 ENTER;
d7a09b41 769 SAVEINT(PL_in_load_module);
c9bca74a 770 if (cv) {
9cfa90c0 771 SAVEGENERICSV(PL_warnhook);
504618e9 772 (void)SvREFCNT_inc(cv);
c9bca74a
NIS
773 PL_warnhook = (SV *) cv;
774 }
d7a09b41
SR
775 PL_in_load_module++;
776 /*
777 * The two SVs are magically freed by load_module
778 */
779 Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
780 PL_in_load_module--;
781 LEAVE;
782 return PerlIO_find_layer(aTHX_ name, len, 0);
783 }
14a5cf38
JH
784 }
785 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
786 return NULL;
f3862f8b
NIS
787}
788
2a1bc955 789#ifdef USE_ATTRIBUTES_FOR_PERLIO
b13b2135
NIS
790
791static int
792perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
793{
14a5cf38
JH
794 if (SvROK(sv)) {
795 IO *io = GvIOn((GV *) SvRV(sv));
796 PerlIO *ifp = IoIFP(io);
797 PerlIO *ofp = IoOFP(io);
798 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
799 }
800 return 0;
b13b2135
NIS
801}
802
803static int
804perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
805{
14a5cf38
JH
806 if (SvROK(sv)) {
807 IO *io = GvIOn((GV *) SvRV(sv));
808 PerlIO *ifp = IoIFP(io);
809 PerlIO *ofp = IoOFP(io);
810 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
811 }
812 return 0;
b13b2135
NIS
813}
814
815static int
816perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
817{
14a5cf38
JH
818 Perl_warn(aTHX_ "clear %" SVf, sv);
819 return 0;
b13b2135
NIS
820}
821
822static int
823perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
824{
14a5cf38
JH
825 Perl_warn(aTHX_ "free %" SVf, sv);
826 return 0;
b13b2135
NIS
827}
828
829MGVTBL perlio_vtab = {
14a5cf38
JH
830 perlio_mg_get,
831 perlio_mg_set,
22569500 832 NULL, /* len */
14a5cf38
JH
833 perlio_mg_clear,
834 perlio_mg_free
b13b2135
NIS
835};
836
837XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
838{
14a5cf38
JH
839 dXSARGS;
840 SV *sv = SvRV(ST(1));
841 AV *av = newAV();
842 MAGIC *mg;
843 int count = 0;
844 int i;
845 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
846 SvRMAGICAL_off(sv);
847 mg = mg_find(sv, PERL_MAGIC_ext);
848 mg->mg_virtual = &perlio_vtab;
849 mg_magical(sv);
850 Perl_warn(aTHX_ "attrib %" SVf, sv);
851 for (i = 2; i < items; i++) {
852 STRLEN len;
e62f0680 853 const char *name = SvPV_const(ST(i), len);
14a5cf38
JH
854 SV *layer = PerlIO_find_layer(aTHX_ name, len, 1);
855 if (layer) {
856 av_push(av, SvREFCNT_inc(layer));
857 }
858 else {
859 ST(count) = ST(i);
860 count++;
861 }
862 }
863 SvREFCNT_dec(av);
864 XSRETURN(count);
865}
866
22569500 867#endif /* USE_ATTIBUTES_FOR_PERLIO */
2a1bc955 868
e3f3bf95
NIS
869SV *
870PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
f3862f8b 871{
46c461b5
AL
872 HV * const stash = gv_stashpv("PerlIO::Layer", TRUE);
873 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
14a5cf38 874 return sv;
e3f3bf95
NIS
875}
876
5ca1d77f 877XS(XS_PerlIO__Layer__NoWarnings)
c9bca74a 878{
37725cdc 879 /* This is used as a %SIG{__WARN__} handler to supress warnings
c9bca74a
NIS
880 during loading of layers.
881 */
882 dXSARGS;
883 if (items)
e62f0680 884 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
c9bca74a
NIS
885 XSRETURN(0);
886}
887
5ca1d77f 888XS(XS_PerlIO__Layer__find)
0c4f7ff0 889{
14a5cf38
JH
890 dXSARGS;
891 if (items < 2)
892 Perl_croak(aTHX_ "Usage class->find(name[,load])");
893 else {
de009b76 894 STRLEN len;
46c461b5 895 const char * const name = SvPV_const(ST(1), len);
de009b76 896 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
46c461b5 897 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
14a5cf38
JH
898 ST(0) =
899 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
900 &PL_sv_undef;
901 XSRETURN(1);
902 }
0c4f7ff0
NIS
903}
904
e3f3bf95
NIS
905void
906PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
907{
3a1ee7e8
NIS
908 if (!PL_known_layers)
909 PL_known_layers = PerlIO_list_alloc(aTHX);
910 PerlIO_list_push(aTHX_ PL_known_layers, tab, Nullsv);
fe5a182c 911 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
f3862f8b
NIS
912}
913
1141d9f8 914int
fcf2db38 915PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1141d9f8 916{
14a5cf38
JH
917 if (names) {
918 const char *s = names;
919 while (*s) {
920 while (isSPACE(*s) || *s == ':')
921 s++;
922 if (*s) {
923 STRLEN llen = 0;
924 const char *e = s;
925 const char *as = Nullch;
926 STRLEN alen = 0;
927 if (!isIDFIRST(*s)) {
928 /*
929 * Message is consistent with how attribute lists are
930 * passed. Even though this means "foo : : bar" is
71200d45 931 * seen as an invalid separator character.
14a5cf38 932 */
de009b76 933 const char q = ((*s == '\'') ? '"' : '\'');
99ef548b 934 if (ckWARN(WARN_LAYER))
22569500 935 Perl_warner(aTHX_ packWARN(WARN_LAYER),
b4581f09 936 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1e616cf5 937 q, *s, q, s);
93189314 938 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
939 return -1;
940 }
941 do {
942 e++;
943 } while (isALNUM(*e));
944 llen = e - s;
945 if (*e == '(') {
946 int nesting = 1;
947 as = ++e;
948 while (nesting) {
949 switch (*e++) {
950 case ')':
951 if (--nesting == 0)
952 alen = (e - 1) - as;
953 break;
954 case '(':
955 ++nesting;
956 break;
957 case '\\':
958 /*
959 * It's a nul terminated string, not allowed
960 * to \ the terminating null. Anything other
71200d45 961 * character is passed over.
14a5cf38
JH
962 */
963 if (*e++) {
964 break;
965 }
966 /*
71200d45 967 * Drop through
14a5cf38
JH
968 */
969 case '\0':
970 e--;
22569500
NIS
971 if (ckWARN(WARN_LAYER))
972 Perl_warner(aTHX_ packWARN(WARN_LAYER),
b4581f09 973 "Argument list not closed for PerlIO layer \"%.*s\"",
14a5cf38
JH
974 (int) (e - s), s);
975 return -1;
976 default:
977 /*
71200d45 978 * boring.
14a5cf38
JH
979 */
980 break;
981 }
982 }
983 }
984 if (e > s) {
46c461b5 985 PerlIO_funcs * const layer =
14a5cf38
JH
986 PerlIO_find_layer(aTHX_ s, llen, 1);
987 if (layer) {
3a1ee7e8 988 PerlIO_list_push(aTHX_ av, layer,
14a5cf38
JH
989 (as) ? newSVpvn(as,
990 alen) :
991 &PL_sv_undef);
992 }
993 else {
041457d9 994 if (ckWARN(WARN_LAYER))
b4581f09 995 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
14a5cf38
JH
996 (int) llen, s);
997 return -1;
998 }
999 }
1000 s = e;
1001 }
1002 }
1003 }
1004 return 0;
1141d9f8
NIS
1005}
1006
dfebf958 1007void
fcf2db38 1008PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
dfebf958 1009{
27da23d5 1010 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
35990314 1011#ifdef PERLIO_USING_CRLF
6ce75a77 1012 tab = &PerlIO_crlf;
846be114 1013#else
6ce75a77 1014 if (PerlIO_stdio.Set_ptrcnt)
22569500 1015 tab = &PerlIO_stdio;
846be114 1016#endif
14a5cf38 1017 PerlIO_debug("Pushing %s\n", tab->name);
3a1ee7e8 1018 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
14a5cf38 1019 &PL_sv_undef);
dfebf958
NIS
1020}
1021
e3f3bf95 1022SV *
14a5cf38 1023PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
e3f3bf95 1024{
14a5cf38 1025 return av->array[n].arg;
e3f3bf95
NIS
1026}
1027
f3862f8b 1028PerlIO_funcs *
14a5cf38 1029PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
f3862f8b 1030{
14a5cf38
JH
1031 if (n >= 0 && n < av->cur) {
1032 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1033 av->array[n].funcs->name);
1034 return av->array[n].funcs;
1035 }
1036 if (!def)
1037 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1038 return def;
e3f3bf95
NIS
1039}
1040
4ec2216f
NIS
1041IV
1042PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1043{
8772537c
AL
1044 PERL_UNUSED_ARG(mode);
1045 PERL_UNUSED_ARG(arg);
1046 PERL_UNUSED_ARG(tab);
4ec2216f
NIS
1047 if (PerlIOValid(f)) {
1048 PerlIO_flush(f);
1049 PerlIO_pop(aTHX_ f);
1050 return 0;
1051 }
1052 return -1;
1053}
1054
27da23d5 1055PERLIO_FUNCS_DECL(PerlIO_remove) = {
4ec2216f
NIS
1056 sizeof(PerlIO_funcs),
1057 "pop",
1058 0,
1059 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1060 PerlIOPop_pushed,
1061 NULL,
1062 NULL,
1063 NULL,
1064 NULL,
1065 NULL,
1066 NULL,
1067 NULL,
1068 NULL,
1069 NULL,
1070 NULL,
de009b76
AL
1071 NULL,
1072 NULL,
4ec2216f
NIS
1073 NULL, /* flush */
1074 NULL, /* fill */
1075 NULL,
1076 NULL,
1077 NULL,
1078 NULL,
1079 NULL, /* get_base */
1080 NULL, /* get_bufsiz */
1081 NULL, /* get_ptr */
1082 NULL, /* get_cnt */
1083 NULL, /* set_ptrcnt */
1084};
1085
fcf2db38 1086PerlIO_list_t *
e3f3bf95
NIS
1087PerlIO_default_layers(pTHX)
1088{
3a1ee7e8 1089 if (!PL_def_layerlist) {
14a5cf38 1090 const char *s = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
27da23d5 1091 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
3a1ee7e8 1092 PL_def_layerlist = PerlIO_list_alloc(aTHX);
27da23d5 1093 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
979e2c82 1094#if defined(WIN32)
27da23d5 1095 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
2f8118af 1096#if 0
14a5cf38 1097 osLayer = &PerlIO_win32;
0c4128ad 1098#endif
2f8118af 1099#endif
27da23d5
JH
1100 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1101 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1102 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1103 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
06da4f11 1104#ifdef HAS_MMAP
27da23d5 1105 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
06da4f11 1106#endif
27da23d5
JH
1107 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1108 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1109 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
3a1ee7e8 1110 PerlIO_list_push(aTHX_ PL_def_layerlist,
14a5cf38
JH
1111 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1112 &PL_sv_undef);
1113 if (s) {
3a1ee7e8 1114 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
14a5cf38
JH
1115 }
1116 else {
3a1ee7e8 1117 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
14a5cf38 1118 }
1141d9f8 1119 }
3a1ee7e8
NIS
1120 if (PL_def_layerlist->cur < 2) {
1121 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
f3862f8b 1122 }
3a1ee7e8 1123 return PL_def_layerlist;
e3f3bf95
NIS
1124}
1125
0c4f7ff0
NIS
1126void
1127Perl_boot_core_PerlIO(pTHX)
1128{
1129#ifdef USE_ATTRIBUTES_FOR_PERLIO
14a5cf38
JH
1130 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1131 __FILE__);
0c4f7ff0 1132#endif
14a5cf38 1133 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
c9bca74a 1134 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
0c4f7ff0 1135}
e3f3bf95
NIS
1136
1137PerlIO_funcs *
1138PerlIO_default_layer(pTHX_ I32 n)
1139{
46c461b5 1140 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
14a5cf38
JH
1141 if (n < 0)
1142 n += av->cur;
27da23d5 1143 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
f3862f8b
NIS
1144}
1145
a999f61b
NIS
1146#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1147#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
60382766
NIS
1148
1149void
1141d9f8 1150PerlIO_stdstreams(pTHX)
60382766 1151{
a1ea730d 1152 if (!PL_perlio) {
14a5cf38
JH
1153 PerlIO_allocate(aTHX);
1154 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1155 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1156 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1157 }
60382766
NIS
1158}
1159
1160PerlIO *
27da23d5 1161PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
14a5cf38 1162{
2dc2558e
NIS
1163 if (tab->fsize != sizeof(PerlIO_funcs)) {
1164 mismatch:
1165 Perl_croak(aTHX_ "Layer does not match this perl");
1166 }
1167 if (tab->size) {
b464bac0 1168 PerlIOl *l;
2dc2558e
NIS
1169 if (tab->size < sizeof(PerlIOl)) {
1170 goto mismatch;
1171 }
1172 /* Real layer with a data area */
a02a5408 1173 Newxc(l,tab->size,char,PerlIOl);
2dc2558e
NIS
1174 if (l && f) {
1175 Zero(l, tab->size, char);
1176 l->next = *f;
27da23d5 1177 l->tab = (PerlIO_funcs*) tab;
2dc2558e
NIS
1178 *f = l;
1179 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1180 (mode) ? mode : "(Null)", (void*)arg);
210e727c 1181 if (*l->tab->Pushed &&
27da23d5 1182 (*l->tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
2dc2558e
NIS
1183 PerlIO_pop(aTHX_ f);
1184 return NULL;
1185 }
1186 }
1187 }
1188 else if (f) {
1189 /* Pseudo-layer where push does its own stack adjust */
00f51856
NIS
1190 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1191 (mode) ? mode : "(Null)", (void*)arg);
210e727c 1192 if (tab->Pushed &&
27da23d5 1193 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
210e727c 1194 return NULL;
14a5cf38
JH
1195 }
1196 }
1197 return f;
60382766
NIS
1198}
1199
dfebf958 1200IV
86e05cf2
NIS
1201PerlIOBase_binmode(pTHX_ PerlIO *f)
1202{
1203 if (PerlIOValid(f)) {
1204 /* Is layer suitable for raw stream ? */
1205 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1206 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1207 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1208 }
1209 else {
1210 /* Not suitable - pop it */
1211 PerlIO_pop(aTHX_ f);
1212 }
1213 return 0;
1214 }
1215 return -1;
1216}
1217
1218IV
2dc2558e 1219PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
dfebf958 1220{
8772537c
AL
1221 PERL_UNUSED_ARG(mode);
1222 PERL_UNUSED_ARG(arg);
1223 PERL_UNUSED_ARG(tab);
86e05cf2 1224
04892f78 1225 if (PerlIOValid(f)) {
86e05cf2 1226 PerlIO *t;
de009b76 1227 const PerlIOl *l;
14a5cf38 1228 PerlIO_flush(f);
86e05cf2
NIS
1229 /*
1230 * Strip all layers that are not suitable for a raw stream
1231 */
1232 t = f;
1233 while (t && (l = *t)) {
1234 if (l->tab->Binmode) {
1235 /* Has a handler - normal case */
1236 if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1237 if (*t == l) {
1238 /* Layer still there - move down a layer */
1239 t = PerlIONext(t);
1240 }
1241 }
1242 else {
1243 return -1;
1244 }
14a5cf38
JH
1245 }
1246 else {
86e05cf2
NIS
1247 /* No handler - pop it */
1248 PerlIO_pop(aTHX_ t);
14a5cf38
JH
1249 }
1250 }
86e05cf2
NIS
1251 if (PerlIOValid(f)) {
1252 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1253 return 0;
1254 }
14a5cf38
JH
1255 }
1256 return -1;
dfebf958
NIS
1257}
1258
ac27b0f5 1259int
14a5cf38 1260PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
d9dac8cd 1261 PerlIO_list_t *layers, IV n, IV max)
14a5cf38 1262{
14a5cf38
JH
1263 int code = 0;
1264 while (n < max) {
8772537c 1265 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
14a5cf38
JH
1266 if (tab) {
1267 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1268 code = -1;
1269 break;
1270 }
1271 }
1272 n++;
1273 }
1274 return code;
e3f3bf95
NIS
1275}
1276
1277int
ac27b0f5
NIS
1278PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1279{
14a5cf38 1280 int code = 0;
53f1b6d2 1281 if (f && names) {
8772537c 1282 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
14a5cf38
JH
1283 code = PerlIO_parse_layers(aTHX_ layers, names);
1284 if (code == 0) {
d9dac8cd 1285 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
14a5cf38 1286 }
3a1ee7e8 1287 PerlIO_list_free(aTHX_ layers);
ac27b0f5 1288 }
14a5cf38 1289 return code;
ac27b0f5
NIS
1290}
1291
f3862f8b 1292
60382766 1293/*--------------------------------------------------------------------------------------*/
14a5cf38 1294/*
71200d45 1295 * Given the abstraction above the public API functions
14a5cf38 1296 */
60382766
NIS
1297
1298int
f5b9d040 1299PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 1300{
14a5cf38 1301 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
fe5a182c 1302 (void*)f, PerlIOBase(f)->tab->name, iotype, mode,
14a5cf38 1303 (names) ? names : "(Null)");
03c0554d
NIS
1304 if (names) {
1305 /* Do not flush etc. if (e.g.) switching encodings.
1306 if a pushed layer knows it needs to flush lower layers
1307 (for example :unix which is never going to call them)
1308 it can do the flush when it is pushed.
1309 */
1310 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1311 }
1312 else {
86e05cf2 1313 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
35990314 1314#ifdef PERLIO_USING_CRLF
03c0554d
NIS
1315 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1316 O_BINARY so we can look for it in mode.
1317 */
1318 if (!(mode & O_BINARY)) {
1319 /* Text mode */
86e05cf2
NIS
1320 /* FIXME?: Looking down the layer stack seems wrong,
1321 but is a way of reaching past (say) an encoding layer
1322 to flip CRLF-ness of the layer(s) below
1323 */
03c0554d
NIS
1324 while (*f) {
1325 /* Perhaps we should turn on bottom-most aware layer
1326 e.g. Ilya's idea that UNIX TTY could serve
1327 */
1328 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1329 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1330 /* Not in text mode - flush any pending stuff and flip it */
1331 PerlIO_flush(f);
1332 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1333 }
1334 /* Only need to turn it on in one layer so we are done */
1335 return TRUE;
ed53a2bb 1336 }
03c0554d 1337 f = PerlIONext(f);
14a5cf38 1338 }
03c0554d
NIS
1339 /* Not finding a CRLF aware layer presumably means we are binary
1340 which is not what was requested - so we failed
1341 We _could_ push :crlf layer but so could caller
1342 */
1343 return FALSE;
14a5cf38 1344 }
6ce75a77 1345#endif
86e05cf2
NIS
1346 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1347 So code that used to be here is now in PerlIORaw_pushed().
03c0554d 1348 */
27da23d5 1349 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), Nullch, Nullsv) ? TRUE : FALSE;
14a5cf38 1350 }
f5b9d040
NIS
1351}
1352
f5b9d040 1353int
e87a358a 1354PerlIO__close(pTHX_ PerlIO *f)
f5b9d040 1355{
37725cdc 1356 if (PerlIOValid(f)) {
46c461b5 1357 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
37725cdc
NIS
1358 if (tab && tab->Close)
1359 return (*tab->Close)(aTHX_ f);
1360 else
1361 return PerlIOBase_close(aTHX_ f);
1362 }
14a5cf38 1363 else {
93189314 1364 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1365 return -1;
1366 }
76ced9ad
NIS
1367}
1368
b931b1d9 1369int
e87a358a 1370Perl_PerlIO_close(pTHX_ PerlIO *f)
b931b1d9 1371{
de009b76 1372 const int code = PerlIO__close(aTHX_ f);
37725cdc
NIS
1373 while (PerlIOValid(f)) {
1374 PerlIO_pop(aTHX_ f);
f6c77cf1 1375 }
14a5cf38 1376 return code;
b931b1d9
NIS
1377}
1378
b931b1d9 1379int
e87a358a 1380Perl_PerlIO_fileno(pTHX_ PerlIO *f)
b931b1d9 1381{
b32dd47e 1382 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
b931b1d9
NIS
1383}
1384
1141d9f8
NIS
1385static const char *
1386PerlIO_context_layers(pTHX_ const char *mode)
1387{
14a5cf38
JH
1388 const char *type = NULL;
1389 /*
71200d45 1390 * Need to supply default layer info from open.pm
14a5cf38
JH
1391 */
1392 if (PL_curcop) {
1393 SV *layers = PL_curcop->cop_io;
1394 if (layers) {
1395 STRLEN len;
b83604b4 1396 type = SvPV_const(layers, len);
14a5cf38
JH
1397 if (type && mode[0] != 'r') {
1398 /*
71200d45 1399 * Skip to write part
14a5cf38
JH
1400 */
1401 const char *s = strchr(type, 0);
eb160463 1402 if (s && (STRLEN)(s - type) < len) {
14a5cf38
JH
1403 type = s + 1;
1404 }
1405 }
1406 }
1407 }
1408 return type;
1141d9f8
NIS
1409}
1410
fcf2db38 1411static PerlIO_funcs *
2edd7e44
NIS
1412PerlIO_layer_from_ref(pTHX_ SV *sv)
1413{
14a5cf38 1414 /*
71200d45 1415 * For any scalar type load the handler which is bundled with perl
14a5cf38
JH
1416 */
1417 if (SvTYPE(sv) < SVt_PVAV)
e934609f 1418 return PerlIO_find_layer(aTHX_ "scalar", 6, 1);
14a5cf38
JH
1419
1420 /*
71200d45 1421 * For other types allow if layer is known but don't try and load it
14a5cf38
JH
1422 */
1423 switch (SvTYPE(sv)) {
1424 case SVt_PVAV:
1425 return PerlIO_find_layer(aTHX_ "Array", 5, 0);
1426 case SVt_PVHV:
1427 return PerlIO_find_layer(aTHX_ "Hash", 4, 0);
1428 case SVt_PVCV:
1429 return PerlIO_find_layer(aTHX_ "Code", 4, 0);
1430 case SVt_PVGV:
1431 return PerlIO_find_layer(aTHX_ "Glob", 4, 0);
1432 }
1433 return NULL;
2edd7e44
NIS
1434}
1435
fcf2db38 1436PerlIO_list_t *
14a5cf38
JH
1437PerlIO_resolve_layers(pTHX_ const char *layers,
1438 const char *mode, int narg, SV **args)
1439{
1440 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1441 int incdef = 1;
a1ea730d 1442 if (!PL_perlio)
14a5cf38
JH
1443 PerlIO_stdstreams(aTHX);
1444 if (narg) {
1445 SV *arg = *args;
1446 /*
71200d45
NIS
1447 * If it is a reference but not an object see if we have a handler
1448 * for it
14a5cf38
JH
1449 */
1450 if (SvROK(arg) && !sv_isobject(arg)) {
46c461b5 1451 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1452 if (handler) {
3a1ee7e8
NIS
1453 def = PerlIO_list_alloc(aTHX);
1454 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH
1455 incdef = 0;
1456 }
1457 /*
e934609f 1458 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1459 * something sensible else we will just stringfy and open
71200d45 1460 * resulting string.
14a5cf38
JH
1461 */
1462 }
1463 }
9fe371da 1464 if (!layers || !*layers)
14a5cf38
JH
1465 layers = PerlIO_context_layers(aTHX_ mode);
1466 if (layers && *layers) {
1467 PerlIO_list_t *av;
1468 if (incdef) {
de009b76 1469 IV i;
3a1ee7e8 1470 av = PerlIO_list_alloc(aTHX);
14a5cf38 1471 for (i = 0; i < def->cur; i++) {
3a1ee7e8 1472 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
14a5cf38
JH
1473 def->array[i].arg);
1474 }
1475 }
1476 else {
1477 av = def;
1478 }
0cff2cf3
NIS
1479 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1480 return av;
1481 }
1482 else {
1483 PerlIO_list_free(aTHX_ av);
1484 return (PerlIO_list_t *) NULL;
1485 }
14a5cf38
JH
1486 }
1487 else {
1488 if (incdef)
1489 def->refcnt++;
1490 return def;
1491 }
ee518936
NIS
1492}
1493
1494PerlIO *
14a5cf38
JH
1495PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1496 int imode, int perm, PerlIO *f, int narg, SV **args)
1497{
1498 if (!f && narg == 1 && *args == &PL_sv_undef) {
1499 if ((f = PerlIO_tmpfile())) {
9fe371da 1500 if (!layers || !*layers)
14a5cf38
JH
1501 layers = PerlIO_context_layers(aTHX_ mode);
1502 if (layers && *layers)
1503 PerlIO_apply_layers(aTHX_ f, mode, layers);
1504 }
1505 }
1506 else {
de009b76 1507 PerlIO_list_t *layera;
14a5cf38
JH
1508 IV n;
1509 PerlIO_funcs *tab = NULL;
04892f78 1510 if (PerlIOValid(f)) {
14a5cf38 1511 /*
71200d45
NIS
1512 * This is "reopen" - it is not tested as perl does not use it
1513 * yet
14a5cf38
JH
1514 */
1515 PerlIOl *l = *f;
3a1ee7e8 1516 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1517 while (l) {
46c461b5 1518 SV * const arg = (l->tab->Getarg)
04892f78
NIS
1519 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1520 : &PL_sv_undef;
3a1ee7e8 1521 PerlIO_list_push(aTHX_ layera, l->tab, arg);
14a5cf38
JH
1522 l = *PerlIONext(&l);
1523 }
1524 }
1525 else {
1526 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS
1527 if (!layera) {
1528 return NULL;
1529 }
14a5cf38
JH
1530 }
1531 /*
71200d45 1532 * Start at "top" of layer stack
14a5cf38
JH
1533 */
1534 n = layera->cur - 1;
1535 while (n >= 0) {
46c461b5 1536 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH
1537 if (t && t->Open) {
1538 tab = t;
1539 break;
1540 }
1541 n--;
1542 }
1543 if (tab) {
1544 /*
71200d45 1545 * Found that layer 'n' can do opens - call it
14a5cf38 1546 */
7cf31beb 1547 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1548 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1549 }
14a5cf38 1550 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
fe5a182c
JH
1551 tab->name, layers, mode, fd, imode, perm,
1552 (void*)f, narg, (void*)args);
210e727c
JH
1553 if (tab->Open)
1554 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1555 f, narg, args);
1556 else {
1557 SETERRNO(EINVAL, LIB_INVARG);
1558 f = NULL;
1559 }
14a5cf38
JH
1560 if (f) {
1561 if (n + 1 < layera->cur) {
1562 /*
1563 * More layers above the one that we used to open -
71200d45 1564 * apply them now
14a5cf38 1565 */
d9dac8cd
NIS
1566 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1567 /* If pushing layers fails close the file */
1568 PerlIO_close(f);
14a5cf38
JH
1569 f = NULL;
1570 }
1571 }
1572 }
1573 }
3a1ee7e8 1574 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH
1575 }
1576 return f;
ee518936 1577}
b931b1d9
NIS
1578
1579
9e353e3b 1580SSize_t
e87a358a 1581Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1582{
b32dd47e 1583 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1584}
1585
313ca112 1586SSize_t
e87a358a 1587Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1588{
b32dd47e 1589 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1590}
1591
9e353e3b 1592SSize_t
e87a358a 1593Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1594{
b32dd47e 1595 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1596}
1597
6f9d8c32 1598int
e87a358a 1599Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1600{
b32dd47e 1601 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW
1602}
1603
9e353e3b 1604Off_t
e87a358a 1605Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1606{
b32dd47e 1607 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW
1608}
1609
6f9d8c32 1610int
e87a358a 1611Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1612{
14a5cf38
JH
1613 if (f) {
1614 if (*f) {
de009b76 1615 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH
1616
1617 if (tab && tab->Flush)
f62ce20a 1618 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH
1619 else
1620 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH
1621 }
1622 else {
fe5a182c 1623 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
93189314 1624 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1625 return -1;
1626 }
1627 }
1628 else {
1629 /*
1630 * Is it good API design to do flush-all on NULL, a potentially
1631 * errorneous input? Maybe some magical value (PerlIO*
1632 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1633 * things on fflush(NULL), but should we be bound by their design
71200d45 1634 * decisions? --jhi
14a5cf38 1635 */
a1ea730d 1636 PerlIO **table = &PL_perlio;
14a5cf38
JH
1637 int code = 0;
1638 while ((f = *table)) {
1639 int i;
1640 table = (PerlIO **) (f++);
1641 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1642 if (*f && PerlIO_flush(f) != 0)
1643 code = -1;
1644 f++;
1645 }
1646 }
1647 return code;
1648 }
760ac839
LW
1649}
1650
a9c883f6 1651void
f62ce20a 1652PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1653{
a1ea730d 1654 PerlIO **table = &PL_perlio;
14a5cf38
JH
1655 PerlIO *f;
1656 while ((f = *table)) {
1657 int i;
1658 table = (PerlIO **) (f++);
1659 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1660 if (*f
1661 && (PerlIOBase(f)->
1662 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1663 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1664 PerlIO_flush(f);
1665 f++;
1666 }
a9c883f6 1667 }
a9c883f6
NIS
1668}
1669
06da4f11 1670int
e87a358a 1671Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1672{
b32dd47e 1673 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS
1674}
1675
f3862f8b
NIS
1676int
1677PerlIO_isutf8(PerlIO *f)
1678{
1b7a0411
JH
1679 if (PerlIOValid(f))
1680 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1681 else
1682 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1683
1b7a0411 1684 return -1;
f3862f8b
NIS
1685}
1686
6f9d8c32 1687int
e87a358a 1688Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1689{
b32dd47e 1690 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS
1691}
1692
9e353e3b 1693int
e87a358a 1694Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1695{
b32dd47e 1696 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS
1697}
1698
9e353e3b 1699void
e87a358a 1700Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1701{
b32dd47e 1702 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS
1703}
1704
9e353e3b 1705void
e87a358a 1706Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1707{
b32dd47e 1708 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS
1709}
1710
9e353e3b
NIS
1711int
1712PerlIO_has_base(PerlIO *f)
1713{
1b7a0411 1714 if (PerlIOValid(f)) {
46c461b5 1715 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1716
1717 if (tab)
1718 return (tab->Get_base != NULL);
1719 SETERRNO(EINVAL, LIB_INVARG);
1720 }
1721 else
1722 SETERRNO(EBADF, SS_IVCHAN);
1723
1724 return 0;
760ac839
LW
1725}
1726
9e353e3b
NIS
1727int
1728PerlIO_fast_gets(PerlIO *f)
760ac839 1729{
04892f78 1730 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
46c461b5 1731 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1732
1733 if (tab)
1734 return (tab->Set_ptrcnt != NULL);
1735 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 1736 }
1b7a0411
JH
1737 else
1738 SETERRNO(EBADF, SS_IVCHAN);
1739
14a5cf38 1740 return 0;
9e353e3b
NIS
1741}
1742
9e353e3b
NIS
1743int
1744PerlIO_has_cntptr(PerlIO *f)
1745{
04892f78 1746 if (PerlIOValid(f)) {
46c461b5 1747 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1748
1749 if (tab)
1750 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1751 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 1752 }
1b7a0411
JH
1753 else
1754 SETERRNO(EBADF, SS_IVCHAN);
1755
14a5cf38 1756 return 0;
9e353e3b
NIS
1757}
1758
9e353e3b
NIS
1759int
1760PerlIO_canset_cnt(PerlIO *f)
1761{
04892f78 1762 if (PerlIOValid(f)) {
46c461b5 1763 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1764
1765 if (tab)
1766 return (tab->Set_ptrcnt != NULL);
1767 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 1768 }
1b7a0411
JH
1769 else
1770 SETERRNO(EBADF, SS_IVCHAN);
1771
14a5cf38 1772 return 0;
760ac839
LW
1773}
1774
888911fc 1775STDCHAR *
e87a358a 1776Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1777{
b32dd47e 1778 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS
1779}
1780
9e353e3b 1781int
e87a358a 1782Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1783{
b32dd47e 1784 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS
1785}
1786
9e353e3b 1787STDCHAR *
e87a358a 1788Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1789{
b32dd47e 1790 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS
1791}
1792
05d1247b 1793int
e87a358a 1794Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1795{
b32dd47e 1796 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS
1797}
1798
9e353e3b 1799void
e87a358a 1800Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
9e353e3b 1801{
b32dd47e 1802 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS
1803}
1804
9e353e3b 1805void
e87a358a 1806Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
9e353e3b 1807{
b32dd47e 1808 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS
1809}
1810
4ec2216f 1811
9e353e3b 1812/*--------------------------------------------------------------------------------------*/
14a5cf38 1813/*
71200d45 1814 * utf8 and raw dummy layers
14a5cf38 1815 */
dfebf958 1816
26fb694e 1817IV
2dc2558e 1818PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1819{
8772537c
AL
1820 PERL_UNUSED_ARG(mode);
1821 PERL_UNUSED_ARG(arg);
00f51856 1822 if (PerlIOValid(f)) {
14a5cf38
JH
1823 if (tab->kind & PERLIO_K_UTF8)
1824 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1825 else
1826 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1827 return 0;
1828 }
1829 return -1;
26fb694e
NIS
1830}
1831
27da23d5 1832PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1833 sizeof(PerlIO_funcs),
14a5cf38 1834 "utf8",
2dc2558e 1835 0,
6874a2de 1836 PERLIO_K_DUMMY | PERLIO_K_UTF8,
14a5cf38
JH
1837 PerlIOUtf8_pushed,
1838 NULL,
1839 NULL,
1840 NULL,
1841 NULL,
1842 NULL,
1843 NULL,
1844 NULL,
1845 NULL,
1846 NULL,
1847 NULL,
de009b76
AL
1848 NULL,
1849 NULL,
22569500
NIS
1850 NULL, /* flush */
1851 NULL, /* fill */
14a5cf38
JH
1852 NULL,
1853 NULL,
1854 NULL,
1855 NULL,
22569500
NIS
1856 NULL, /* get_base */
1857 NULL, /* get_bufsiz */
1858 NULL, /* get_ptr */
1859 NULL, /* get_cnt */
1860 NULL, /* set_ptrcnt */
26fb694e
NIS
1861};
1862
27da23d5 1863PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1864 sizeof(PerlIO_funcs),
14a5cf38 1865 "bytes",
2dc2558e 1866 0,
14a5cf38
JH
1867 PERLIO_K_DUMMY,
1868 PerlIOUtf8_pushed,
1869 NULL,
1870 NULL,
1871 NULL,
1872 NULL,
1873 NULL,
1874 NULL,
1875 NULL,
1876 NULL,
1877 NULL,
1878 NULL,
de009b76
AL
1879 NULL,
1880 NULL,
22569500
NIS
1881 NULL, /* flush */
1882 NULL, /* fill */
14a5cf38
JH
1883 NULL,
1884 NULL,
1885 NULL,
1886 NULL,
22569500
NIS
1887 NULL, /* get_base */
1888 NULL, /* get_bufsiz */
1889 NULL, /* get_ptr */
1890 NULL, /* get_cnt */
1891 NULL, /* set_ptrcnt */
dfebf958
NIS
1892};
1893
1894PerlIO *
14a5cf38
JH
1895PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1896 IV n, const char *mode, int fd, int imode, int perm,
1897 PerlIO *old, int narg, SV **args)
dfebf958 1898{
8772537c
AL
1899 PerlIO_funcs * const tab = PerlIO_default_btm();
1900 PERL_UNUSED_ARG(self);
210e727c
JH
1901 if (tab && tab->Open)
1902 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1903 old, narg, args);
1904 SETERRNO(EINVAL, LIB_INVARG);
1905 return NULL;
dfebf958
NIS
1906}
1907
27da23d5 1908PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 1909 sizeof(PerlIO_funcs),
14a5cf38 1910 "raw",
2dc2558e 1911 0,
14a5cf38
JH
1912 PERLIO_K_DUMMY,
1913 PerlIORaw_pushed,
1914 PerlIOBase_popped,
1915 PerlIORaw_open,
1916 NULL,
1917 NULL,
1918 NULL,
1919 NULL,
1920 NULL,
1921 NULL,
1922 NULL,
1923 NULL,
de009b76
AL
1924 NULL,
1925 NULL,
22569500
NIS
1926 NULL, /* flush */
1927 NULL, /* fill */
14a5cf38
JH
1928 NULL,
1929 NULL,
1930 NULL,
1931 NULL,
22569500
NIS
1932 NULL, /* get_base */
1933 NULL, /* get_bufsiz */
1934 NULL, /* get_ptr */
1935 NULL, /* get_cnt */
1936 NULL, /* set_ptrcnt */
dfebf958
NIS
1937};
1938/*--------------------------------------------------------------------------------------*/
1939/*--------------------------------------------------------------------------------------*/
14a5cf38 1940/*
71200d45 1941 * "Methods" of the "base class"
14a5cf38 1942 */
9e353e3b
NIS
1943
1944IV
f62ce20a 1945PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 1946{
04892f78 1947 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS
1948}
1949
f5b9d040 1950char *
81428673 1951PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH
1952{
1953 char *s = buf;
81428673 1954 if (PerlIOValid(f)) {
de009b76 1955 const IV flags = PerlIOBase(f)->flags;
81428673
NIS
1956 if (flags & PERLIO_F_APPEND) {
1957 *s++ = 'a';
1958 if (flags & PERLIO_F_CANREAD) {
1959 *s++ = '+';
1960 }
14a5cf38 1961 }
81428673
NIS
1962 else if (flags & PERLIO_F_CANREAD) {
1963 *s++ = 'r';
1964 if (flags & PERLIO_F_CANWRITE)
1965 *s++ = '+';
1966 }
1967 else if (flags & PERLIO_F_CANWRITE) {
1968 *s++ = 'w';
1969 if (flags & PERLIO_F_CANREAD) {
1970 *s++ = '+';
1971 }
14a5cf38 1972 }
35990314 1973#ifdef PERLIO_USING_CRLF
81428673
NIS
1974 if (!(flags & PERLIO_F_CRLF))
1975 *s++ = 'b';
5f1a76d0 1976#endif
81428673 1977 }
14a5cf38
JH
1978 *s = '\0';
1979 return buf;
f5b9d040
NIS
1980}
1981
81428673 1982
76ced9ad 1983IV
2dc2558e 1984PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 1985{
de009b76 1986 PerlIOl * const l = PerlIOBase(f);
8772537c 1987 PERL_UNUSED_ARG(arg);
de009b76 1988
14a5cf38
JH
1989 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1990 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1991 if (tab->Set_ptrcnt != NULL)
1992 l->flags |= PERLIO_F_FASTGETS;
1993 if (mode) {
3b6c1aba 1994 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH
1995 mode++;
1996 switch (*mode++) {
1997 case 'r':
1998 l->flags |= PERLIO_F_CANREAD;
1999 break;
2000 case 'a':
2001 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2002 break;
2003 case 'w':
2004 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2005 break;
2006 default:
93189314 2007 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2008 return -1;
2009 }
2010 while (*mode) {
2011 switch (*mode++) {
2012 case '+':
2013 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2014 break;
2015 case 'b':
2016 l->flags &= ~PERLIO_F_CRLF;
2017 break;
2018 case 't':
2019 l->flags |= PERLIO_F_CRLF;
2020 break;
2021 default:
93189314 2022 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2023 return -1;
2024 }
2025 }
2026 }
2027 else {
2028 if (l->next) {
2029 l->flags |= l->next->flags &
2030 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2031 PERLIO_F_APPEND);
2032 }
2033 }
5e2ab84b 2034#if 0
14a5cf38
JH
2035 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2036 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2037 l->flags, PerlIO_modestr(f, temp));
5e2ab84b 2038#endif
14a5cf38 2039 return 0;
76ced9ad
NIS
2040}
2041
2042IV
f62ce20a 2043PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2044{
8772537c 2045 PERL_UNUSED_ARG(f);
14a5cf38 2046 return 0;
760ac839
LW
2047}
2048
9e353e3b 2049SSize_t
f62ce20a 2050PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2051{
14a5cf38 2052 /*
71200d45 2053 * Save the position as current head considers it
14a5cf38 2054 */
de009b76 2055 const Off_t old = PerlIO_tell(f);
27da23d5 2056 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", Nullsv);
14a5cf38 2057 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2058 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS
2059}
2060
f6c77cf1 2061SSize_t
f62ce20a 2062PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2063{
14a5cf38
JH
2064 STDCHAR *buf = (STDCHAR *) vbuf;
2065 if (f) {
263df5f1
JH
2066 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2067 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2068 SETERRNO(EBADF, SS_IVCHAN);
2069 return 0;
2070 }
14a5cf38 2071 while (count > 0) {
93c2c2ec
IZ
2072 get_cnt:
2073 {
14a5cf38
JH
2074 SSize_t avail = PerlIO_get_cnt(f);
2075 SSize_t take = 0;
2076 if (avail > 0)
eb160463 2077 take = ((SSize_t)count < avail) ? count : avail;
14a5cf38
JH
2078 if (take > 0) {
2079 STDCHAR *ptr = PerlIO_get_ptr(f);
2080 Copy(ptr, buf, take, STDCHAR);
2081 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2082 count -= take;
2083 buf += take;
93c2c2ec
IZ
2084 if (avail == 0) /* set_ptrcnt could have reset avail */
2085 goto get_cnt;
14a5cf38
JH
2086 }
2087 if (count > 0 && avail <= 0) {
2088 if (PerlIO_fill(f) != 0)
2089 break;
2090 }
93c2c2ec 2091 }
14a5cf38
JH
2092 }
2093 return (buf - (STDCHAR *) vbuf);
2094 }
f6c77cf1 2095 return 0;
f6c77cf1
NIS
2096}
2097
9e353e3b 2098IV
f62ce20a 2099PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2100{
8772537c 2101 PERL_UNUSED_ARG(f);
14a5cf38 2102 return 0;
9e353e3b
NIS
2103}
2104
2105IV
f62ce20a 2106PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2107{
8772537c 2108 PERL_UNUSED_ARG(f);
14a5cf38 2109 return -1;
06da4f11
NIS
2110}
2111
2112IV
f62ce20a 2113PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2114{
37725cdc
NIS
2115 IV code = -1;
2116 if (PerlIOValid(f)) {
2117 PerlIO *n = PerlIONext(f);
2118 code = PerlIO_flush(f);
2119 PerlIOBase(f)->flags &=
2120 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2121 while (PerlIOValid(n)) {
de009b76 2122 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS
2123 if (tab && tab->Close) {
2124 if ((*tab->Close)(aTHX_ n) != 0)
2125 code = -1;
2126 break;
2127 }
2128 else {
2129 PerlIOBase(n)->flags &=
2130 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2131 }
2132 n = PerlIONext(n);
2133 }
2134 }
2135 else {
2136 SETERRNO(EBADF, SS_IVCHAN);
2137 }
14a5cf38 2138 return code;
9e353e3b
NIS
2139}
2140
2141IV
f62ce20a 2142PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2143{
04892f78 2144 if (PerlIOValid(f)) {
14a5cf38
JH
2145 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2146 }
2147 return 1;
9e353e3b
NIS
2148}
2149
2150IV
f62ce20a 2151PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2152{
04892f78 2153 if (PerlIOValid(f)) {
14a5cf38
JH
2154 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2155 }
2156 return 1;
9e353e3b
NIS
2157}
2158
2159void
f62ce20a 2160PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2161{
04892f78 2162 if (PerlIOValid(f)) {
14a5cf38
JH
2163 PerlIO *n = PerlIONext(f);
2164 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2165 if (PerlIOValid(n))
14a5cf38
JH
2166 PerlIO_clearerr(n);
2167 }
9e353e3b
NIS
2168}
2169
2170void
f62ce20a 2171PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2172{
04892f78 2173 if (PerlIOValid(f)) {
14a5cf38
JH
2174 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2175 }
9e353e3b
NIS
2176}
2177
93a8090d
NIS
2178SV *
2179PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2180{
2181 if (!arg)
2182 return Nullsv;
2183#ifdef sv_dup
2184 if (param) {
2185 return sv_dup(arg, param);
2186 }
2187 else {
2188 return newSVsv(arg);
2189 }
2190#else
1b6737cc 2191 PERL_UNUSED_ARG(param);
93a8090d
NIS
2192 return newSVsv(arg);
2193#endif
2194}
2195
2196PerlIO *
ecdeb87c 2197PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2198{
1b6737cc 2199 PerlIO * const nexto = PerlIONext(o);
04892f78 2200 if (PerlIOValid(nexto)) {
de009b76 2201 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS
2202 if (tab && tab->Dup)
2203 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2204 else
2205 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS
2206 }
2207 if (f) {
2208 PerlIO_funcs *self = PerlIOBase(o)->tab;
210e727c 2209 SV *arg;
93a8090d 2210 char buf[8];
fe5a182c
JH
2211 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2212 self->name, (void*)f, (void*)o, (void*)param);
210e727c
JH
2213 if (self->Getarg)
2214 arg = (*self->Getarg)(aTHX_ o, param, flags);
2215 else {
37725cdc 2216 arg = Nullsv;
93a8090d
NIS
2217 }
2218 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
ecdeb87c 2219 if (arg) {
93a8090d
NIS
2220 SvREFCNT_dec(arg);
2221 }
2222 }
2223 return f;
2224}
2225
168d5872 2226#ifdef USE_THREADS
93a8090d 2227perl_mutex PerlIO_mutex;
93a8090d 2228#endif
27da23d5
JH
2229
2230/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d
NIS
2231
2232void
2233PerlIO_init(pTHX)
2234{
2235 /* Place holder for stdstreams call ??? */
168d5872 2236#ifdef USE_THREADS
27da23d5 2237 MUTEX_INIT(&PerlIO_mutex);
93a8090d
NIS
2238#endif
2239}
2240
168d5872
NIS
2241void
2242PerlIOUnix_refcnt_inc(int fd)
2243{
27da23d5 2244 dTHX;
168d5872
NIS
2245 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2246#ifdef USE_THREADS
2247 MUTEX_LOCK(&PerlIO_mutex);
2248#endif
27da23d5
JH
2249 PL_perlio_fd_refcnt[fd]++;
2250 PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]);
168d5872
NIS
2251#ifdef USE_THREADS
2252 MUTEX_UNLOCK(&PerlIO_mutex);
2253#endif
2254 }
2255}
2256
168d5872
NIS
2257int
2258PerlIOUnix_refcnt_dec(int fd)
2259{
27da23d5 2260 dTHX;
168d5872
NIS
2261 int cnt = 0;
2262 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2263#ifdef USE_THREADS
2264 MUTEX_LOCK(&PerlIO_mutex);
2265#endif
27da23d5 2266 cnt = --PL_perlio_fd_refcnt[fd];
168d5872
NIS
2267 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2268#ifdef USE_THREADS
2269 MUTEX_UNLOCK(&PerlIO_mutex);
2270#endif
2271 }
2272 return cnt;
2273}
2274
694c95cf
JH
2275void
2276PerlIO_cleanup(pTHX)
2277{
2278 int i;
2279#ifdef USE_ITHREADS
9f4bd222
NIS
2280 PerlIO_debug("Cleanup layers for %p\n",aTHX);
2281#else
2282 PerlIO_debug("Cleanup layers\n");
694c95cf
JH
2283#endif
2284 /* Raise STDIN..STDERR refcount so we don't close them */
2285 for (i=0; i < 3; i++)
2286 PerlIOUnix_refcnt_inc(i);
2287 PerlIO_cleantable(aTHX_ &PL_perlio);
2288 /* Restore STDIN..STDERR refcount */
2289 for (i=0; i < 3; i++)
2290 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS
2291
2292 if (PL_known_layers) {
2293 PerlIO_list_free(aTHX_ PL_known_layers);
2294 PL_known_layers = NULL;
2295 }
27da23d5 2296 if (PL_def_layerlist) {
9f4bd222
NIS
2297 PerlIO_list_free(aTHX_ PL_def_layerlist);
2298 PL_def_layerlist = NULL;
2299 }
694c95cf
JH
2300}
2301
2302
2303
9e353e3b 2304/*--------------------------------------------------------------------------------------*/
14a5cf38 2305/*
71200d45 2306 * Bottom-most level for UNIX-like case
14a5cf38 2307 */
9e353e3b 2308
14a5cf38 2309typedef struct {
22569500
NIS
2310 struct _PerlIO base; /* The generic part */
2311 int fd; /* UNIX like file descriptor */
2312 int oflags; /* open/fcntl flags */
9e353e3b
NIS
2313} PerlIOUnix;
2314
6f9d8c32 2315int
9e353e3b 2316PerlIOUnix_oflags(const char *mode)
760ac839 2317{
14a5cf38 2318 int oflags = -1;
3b6c1aba 2319 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH
2320 mode++;
2321 switch (*mode) {
2322 case 'r':
2323 oflags = O_RDONLY;
2324 if (*++mode == '+') {
2325 oflags = O_RDWR;
2326 mode++;
2327 }
2328 break;
2329
2330 case 'w':
2331 oflags = O_CREAT | O_TRUNC;
2332 if (*++mode == '+') {
2333 oflags |= O_RDWR;
2334 mode++;
2335 }
2336 else
2337 oflags |= O_WRONLY;
2338 break;
2339
2340 case 'a':
2341 oflags = O_CREAT | O_APPEND;
2342 if (*++mode == '+') {
2343 oflags |= O_RDWR;
2344 mode++;
2345 }
2346 else
2347 oflags |= O_WRONLY;
2348 break;
2349 }
2350 if (*mode == 'b') {
2351 oflags |= O_BINARY;
2352 oflags &= ~O_TEXT;
2353 mode++;
2354 }
2355 else if (*mode == 't') {
2356 oflags |= O_TEXT;
2357 oflags &= ~O_BINARY;
2358 mode++;
2359 }
2360 /*
71200d45 2361 * Always open in binary mode
14a5cf38
JH
2362 */
2363 oflags |= O_BINARY;
2364 if (*mode || oflags == -1) {
93189314 2365 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2366 oflags = -1;
2367 }
2368 return oflags;
9e353e3b
NIS
2369}
2370
2371IV
f62ce20a 2372PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2373{
14a5cf38 2374 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS
2375}
2376
aa063c35
NIS
2377static void
2378PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2379{
de009b76 2380 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2381#if defined(WIN32)
aa063c35
NIS
2382 Stat_t st;
2383 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2384 if (!S_ISREG(st.st_mode)) {
aa063c35 2385 PerlIO_debug("%d is not regular file\n",fd);
6caa5a9c
NIS
2386 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2387 }
aa063c35
NIS
2388 else {
2389 PerlIO_debug("%d _is_ a regular file\n",fd);
2390 }
6caa5a9c
NIS
2391 }
2392#endif
aa063c35
NIS
2393 s->fd = fd;
2394 s->oflags = imode;
2395 PerlIOUnix_refcnt_inc(fd);
2396}
2397
2398IV
2399PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2400{
2401 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2402 if (*PerlIONext(f)) {
4b069b44 2403 /* We never call down so do any pending stuff now */
03c0554d 2404 PerlIO_flush(PerlIONext(f));
14a5cf38 2405 /*
71200d45 2406 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2407 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2408 * Should the value on NULL mode be 0 or -1?
14a5cf38 2409 */
acbd16bf 2410 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2411 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH
2412 }
2413 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2414
14a5cf38 2415 return code;
4b803d04
NIS
2416}
2417
c2fcde81
JH
2418IV
2419PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2420{
de009b76 2421 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2422 Off_t new_loc;
c2fcde81
JH
2423 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2424#ifdef ESPIPE
2425 SETERRNO(ESPIPE, LIB_INVARG);
2426#else
2427 SETERRNO(EINVAL, LIB_INVARG);
2428#endif
2429 return -1;
2430 }
0723351e
NC
2431 new_loc = PerlLIO_lseek(fd, offset, whence);
2432 if (new_loc == (Off_t) - 1)
c2fcde81
JH
2433 {
2434 return -1;
2435 }
2436 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2437 return 0;
2438}
2439
9e353e3b 2440PerlIO *
14a5cf38
JH
2441PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2442 IV n, const char *mode, int fd, int imode,
2443 int perm, PerlIO *f, int narg, SV **args)
2444{
d9dac8cd 2445 if (PerlIOValid(f)) {
14a5cf38 2446 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2447 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH
2448 }
2449 if (narg > 0) {
3b6c1aba 2450 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH
2451 mode++;
2452 else {
2453 imode = PerlIOUnix_oflags(mode);
2454 perm = 0666;
2455 }
2456 if (imode != -1) {
e62f0680 2457 const char *path = SvPV_nolen_const(*args);
14a5cf38
JH
2458 fd = PerlLIO_open3(path, imode, perm);
2459 }
2460 }
2461 if (fd >= 0) {
3b6c1aba 2462 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2463 mode++;
2464 if (!f) {
2465 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS
2466 }
2467 if (!PerlIOValid(f)) {
a33cf58c
NIS
2468 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2469 return NULL;
2470 }
d9dac8cd 2471 }
aa063c35 2472 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2473 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH
2474 if (*mode == IoTYPE_APPEND)
2475 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH
2476 return f;
2477 }
2478 else {
2479 if (f) {
2480 /*
71200d45 2481 * FIXME: pop layers ???
14a5cf38
JH
2482 */
2483 }
2484 return NULL;
2485 }
9e353e3b
NIS
2486}
2487
71200d45 2488PerlIO *
ecdeb87c 2489PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45
NIS
2490{
2491 PerlIOUnix *os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2492 int fd = os->fd;
ecdeb87c
NIS
2493 if (flags & PERLIO_DUP_FD) {
2494 fd = PerlLIO_dup(fd);
2495 }
93a8090d 2496 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
ecdeb87c 2497 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS
2498 if (f) {
2499 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2500 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS
2501 return f;
2502 }
71200d45
NIS
2503 }
2504 return NULL;
2505}
2506
2507
9e353e3b 2508SSize_t
f62ce20a 2509PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2510{
de009b76 2511 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2512#ifdef PERLIO_STD_SPECIAL
2513 if (fd == 0)
2514 return PERLIO_STD_IN(fd, vbuf, count);
2515#endif
81428673 2516 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2517 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2518 return 0;
1fd8f4ce 2519 }
14a5cf38 2520 while (1) {
b464bac0 2521 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2522 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2523 if (len < 0) {
2524 if (errno != EAGAIN) {
2525 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2526 }
2527 }
2528 else if (len == 0 && count != 0) {
14a5cf38 2529 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS
2530 SETERRNO(0,0);
2531 }
14a5cf38
JH
2532 return len;
2533 }
2534 PERL_ASYNC_CHECK();
2535 }
b464bac0 2536 /*NOTREACHED*/
9e353e3b
NIS
2537}
2538
2539SSize_t
f62ce20a 2540PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2541{
de009b76 2542 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2543#ifdef PERLIO_STD_SPECIAL
2544 if (fd == 1 || fd == 2)
2545 return PERLIO_STD_OUT(fd, vbuf, count);
2546#endif
14a5cf38 2547 while (1) {
de009b76 2548 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2549 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2550 if (len < 0) {
2551 if (errno != EAGAIN) {
2552 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2553 }
2554 }
14a5cf38
JH
2555 return len;
2556 }
2557 PERL_ASYNC_CHECK();
06da4f11 2558 }
1b6737cc 2559 /*NOTREACHED*/
9e353e3b
NIS
2560}
2561
9e353e3b 2562Off_t
f62ce20a 2563PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2564{
14a5cf38 2565 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2566}
2567
71200d45 2568
9e353e3b 2569IV
f62ce20a 2570PerlIOUnix_close(pTHX_ PerlIO *f)
9e353e3b 2571{
de009b76 2572 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2573 int code = 0;
168d5872
NIS
2574 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2575 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2576 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2577 return 0;
22569500 2578 }
93a8090d
NIS
2579 }
2580 else {
93189314 2581 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2582 return -1;
2583 }
14a5cf38
JH
2584 while (PerlLIO_close(fd) != 0) {
2585 if (errno != EINTR) {
2586 code = -1;
2587 break;
2588 }
2589 PERL_ASYNC_CHECK();
2590 }
2591 if (code == 0) {
2592 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2593 }
2594 return code;
9e353e3b
NIS
2595}
2596
27da23d5 2597PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2598 sizeof(PerlIO_funcs),
14a5cf38
JH
2599 "unix",
2600 sizeof(PerlIOUnix),
2601 PERLIO_K_RAW,
2602 PerlIOUnix_pushed,
44798d05 2603 PerlIOBase_popped,
14a5cf38 2604 PerlIOUnix_open,
86e05cf2 2605 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2606 NULL,
2607 PerlIOUnix_fileno,
71200d45 2608 PerlIOUnix_dup,
14a5cf38
JH
2609 PerlIOUnix_read,
2610 PerlIOBase_unread,
2611 PerlIOUnix_write,
2612 PerlIOUnix_seek,
2613 PerlIOUnix_tell,
2614 PerlIOUnix_close,
22569500
NIS
2615 PerlIOBase_noop_ok, /* flush */
2616 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2617 PerlIOBase_eof,
2618 PerlIOBase_error,
2619 PerlIOBase_clearerr,
2620 PerlIOBase_setlinebuf,
22569500
NIS
2621 NULL, /* get_base */
2622 NULL, /* get_bufsiz */
2623 NULL, /* get_ptr */
2624 NULL, /* get_cnt */
2625 NULL, /* set_ptrcnt */
9e353e3b
NIS
2626};
2627
2628/*--------------------------------------------------------------------------------------*/
14a5cf38 2629/*
71200d45 2630 * stdio as a layer
14a5cf38 2631 */
9e353e3b 2632
313e59c8
NIS
2633#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2634/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2635 broken by the last second glibc 2.3 fix
2636 */
2637#define STDIO_BUFFER_WRITABLE
2638#endif
2639
2640
14a5cf38
JH
2641typedef struct {
2642 struct _PerlIO base;
22569500 2643 FILE *stdio; /* The stream */
9e353e3b
NIS
2644} PerlIOStdio;
2645
2646IV
f62ce20a 2647PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2648{
c4420975
AL
2649 if (PerlIOValid(f)) {
2650 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2651 if (s)
2652 return PerlSIO_fileno(s);
439ba545
NIS
2653 }
2654 errno = EBADF;
2655 return -1;
9e353e3b
NIS
2656}
2657
766a733e 2658char *
14a5cf38
JH
2659PerlIOStdio_mode(const char *mode, char *tmode)
2660{
de009b76 2661 char * const ret = tmode;
a0625d38
SR
2662 if (mode) {
2663 while (*mode) {
2664 *tmode++ = *mode++;
2665 }
14a5cf38 2666 }
95005ad8 2667#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2668 *tmode++ = 'b';
2669#endif
14a5cf38
JH
2670 *tmode = '\0';
2671 return ret;
2672}
2673
4b803d04 2674IV
2dc2558e 2675PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2676{
1fd8f4ce
NIS
2677 PerlIO *n;
2678 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2679 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS
2680 if (toptab == tab) {
2681 /* Top is already stdio - pop self (duplicate) and use original */
2682 PerlIO_pop(aTHX_ f);
2683 return 0;
2684 } else {
de009b76 2685 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2686 char tmode[8];
2687 FILE *stdio;
81428673 2688 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
2689 mode = PerlIOStdio_mode(mode, tmode)))) {
2690 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2691 /* We never call down so do any pending stuff now */
2692 PerlIO_flush(PerlIONext(f));
81428673 2693 }
1fd8f4ce
NIS
2694 else {
2695 return -1;
2696 }
2697 }
14a5cf38 2698 }
2dc2558e 2699 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
2700}
2701
22569500 2702
9e353e3b 2703PerlIO *
4b069b44 2704PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2705{
14a5cf38
JH
2706 dTHX;
2707 PerlIO *f = NULL;
2708 if (stdio) {
22569500 2709 PerlIOStdio *s;
4b069b44
NIS
2710 if (!mode || !*mode) {
2711 /* We need to probe to see how we can open the stream
2712 so start with read/write and then try write and read
2713 we dup() so that we can fclose without loosing the fd.
2714
2715 Note that the errno value set by a failing fdopen
2716 varies between stdio implementations.
2717 */
de009b76 2718 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 2719 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2720 if (!f2) {
a33cf58c 2721 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
2722 }
2723 if (!f2) {
a33cf58c 2724 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
2725 }
2726 if (!f2) {
2727 /* Don't seem to be able to open */
2728 PerlLIO_close(fd);
2729 return f;
2730 }
2731 fclose(f2);
22569500 2732 }
27da23d5 2733 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, Nullsv))) {
a33cf58c
NIS
2734 s = PerlIOSelf(f, PerlIOStdio);
2735 s->stdio = stdio;
2736 }
14a5cf38
JH
2737 }
2738 return f;
9e353e3b
NIS
2739}
2740
2741PerlIO *
14a5cf38
JH
2742PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2743 IV n, const char *mode, int fd, int imode,
2744 int perm, PerlIO *f, int narg, SV **args)
2745{
2746 char tmode[8];
d9dac8cd 2747 if (PerlIOValid(f)) {
e62f0680 2748 const char *path = SvPV_nolen_const(*args);
14a5cf38 2749 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS
2750 FILE *stdio;
2751 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2752 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH
2753 s->stdio);
2754 if (!s->stdio)
2755 return NULL;
2756 s->stdio = stdio;
1751d015 2757 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
2758 return f;
2759 }
2760 else {
2761 if (narg > 0) {
e62f0680 2762 const char *path = SvPV_nolen_const(*args);
3b6c1aba 2763 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
2764 mode++;
2765 fd = PerlLIO_open3(path, imode, perm);
2766 }
2767 else {
95005ad8
GH
2768 FILE *stdio;
2769 bool appended = FALSE;
2770#ifdef __CYGWIN__
2771 /* Cygwin wants its 'b' early. */
2772 appended = TRUE;
2773 mode = PerlIOStdio_mode(mode, tmode);
2774#endif
2775 stdio = PerlSIO_fopen(path, mode);
6f0313ac
JH
2776 if (stdio) {
2777 PerlIOStdio *s;
2778 if (!f) {
2779 f = PerlIO_allocate(aTHX);
2780 }
95005ad8
GH
2781 if (!appended)
2782 mode = PerlIOStdio_mode(mode, tmode);
2783 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2784 if (f) {
6f0313ac
JH
2785 s = PerlIOSelf(f, PerlIOStdio);
2786 s->stdio = stdio;
2787 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2788 }
2789 return f;
2790 }
2791 else {
2792 return NULL;
2793 }
14a5cf38
JH
2794 }
2795 }
2796 if (fd >= 0) {
2797 FILE *stdio = NULL;
2798 int init = 0;
3b6c1aba 2799 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
2800 init = 1;
2801 mode++;
2802 }
2803 if (init) {
2804 switch (fd) {
2805 case 0:
2806 stdio = PerlSIO_stdin;
2807 break;
2808 case 1:
2809 stdio = PerlSIO_stdout;
2810 break;
2811 case 2:
2812 stdio = PerlSIO_stderr;
2813 break;
2814 }
2815 }
2816 else {
2817 stdio = PerlSIO_fdopen(fd, mode =
2818 PerlIOStdio_mode(mode, tmode));
2819 }
2820 if (stdio) {
d9dac8cd
NIS
2821 if (!f) {
2822 f = PerlIO_allocate(aTHX);
2823 }
a33cf58c 2824 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
de009b76 2825 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
a33cf58c
NIS
2826 s->stdio = stdio;
2827 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2828 }
14a5cf38
JH
2829 return f;
2830 }
2831 }
2832 }
ee518936 2833 return NULL;
9e353e3b
NIS
2834}
2835
1751d015 2836PerlIO *
ecdeb87c 2837PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
2838{
2839 /* This assumes no layers underneath - which is what
2840 happens, but is not how I remember it. NI-S 2001/10/16
2841 */
ecdeb87c 2842 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 2843 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 2844 const int fd = fileno(stdio);
9217ff3f 2845 char mode[8];
ecdeb87c 2846 if (flags & PERLIO_DUP_FD) {
de009b76 2847 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
2848 if (dfd >= 0) {
2849 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
2850 goto set_this;
ecdeb87c
NIS
2851 }
2852 else {
2853 /* FIXME: To avoid messy error recovery if dup fails
2854 re-use the existing stdio as though flag was not set
2855 */
2856 }
2857 }
9217ff3f
NIS
2858 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
2859 set_this:
694c95cf
JH
2860 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2861 PerlIOUnix_refcnt_inc(fileno(stdio));
1751d015
NIS
2862 }
2863 return f;
2864}
2865
0d7a5398
NIS
2866static int
2867PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
2868{
2869 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 2870 * PerlIO_set_fileno() support from Configure
0d7a5398 2871 */
ef8eacb8
AT
2872# if defined(__UCLIBC__)
2873 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
2874 f->__filedes = -1;
2875 return 1;
2876# elif defined(__GLIBC__)
0d7a5398 2877 /* There may be a better way for GLIBC:
37725cdc 2878 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
2879 */
2880 f->_fileno = -1;
2881 return 1;
2882# elif defined(__sun__)
2883# if defined(_LP64)
2884 /* On solaris, if _LP64 is defined, the FILE structure is this:
2885 *
2886 * struct FILE {
2887 * long __pad[16];
2888 * };
2889 *
37725cdc 2890 * It turns out that the fd is stored in the top 32 bits of
0d7a5398
NIS
2891 * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears
2892 * to contain a pointer or offset into another structure. All the
2893 * remaining fields are zero.
2894 *
2895 * We set the top bits to -1 (0xFFFFFFFF).
2896 */
2897 f->__pad[4] |= 0xffffffff00000000L;
2898 assert(fileno(f) == 0xffffffff);
2899# else /* !defined(_LP64) */
37725cdc
NIS
2900 /* _file is just a unsigned char :-(
2901 Not clear why we dup() rather than using -1
2902 even if that would be treated as 0xFF - so will
0d7a5398
NIS
2903 a dup fail ...
2904 */
673c27c1 2905 f->_file = PerlLIO_dup(fileno(f));
0d7a5398
NIS
2906# endif /* defined(_LP64) */
2907 return 1;
2908# elif defined(__hpux)
2909 f->__fileH = 0xff;
2910 f->__fileL = 0xff;
2911 return 1;
9837d373 2912 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 2913 your platform does not have special entry try this one.
9837d373
NIS
2914 [For OSF only have confirmation for Tru64 (alpha)
2915 but assume other OSFs will be similar.]
37725cdc 2916 */
9837d373 2917# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
2918 f->_file = -1;
2919 return 1;
2920# elif defined(__FreeBSD__)
2921 /* There may be a better way on FreeBSD:
37725cdc
NIS
2922 - we could insert a dummy func in the _close function entry
2923 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
2924 */
2925 f->_file = -1;
0c49ea6a
SU
2926 return 1;
2927# elif defined(__OpenBSD__)
2928 /* There may be a better way on OpenBSD:
2929 - we could insert a dummy func in the _close function entry
2930 f->_close = (int (*)(void *)) dummy_close;
2931 */
2932 f->_file = -1;
0d7a5398 2933 return 1;
59ad941d
IZ
2934# elif defined(__EMX__)
2935 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
2936 f->_handle = -1;
2937 return 1;
0d7a5398
NIS
2938# elif defined(__CYGWIN__)
2939 /* There may be a better way on CYGWIN:
37725cdc
NIS
2940 - we could insert a dummy func in the _close function entry
2941 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
2942 */
2943 f->_file = -1;
2944 return 1;
2945# elif defined(WIN32)
2946# if defined(__BORLANDC__)
2947 f->fd = PerlLIO_dup(fileno(f));
b475b3e6
JH
2948# elif defined(UNDER_CE)
2949 /* WIN_CE does not have access to FILE internals, it hardly has FILE
2950 structure at all
2951 */
0d7a5398
NIS
2952# else
2953 f->_file = -1;
2954# endif
2955 return 1;
2956# else
2957#if 0
37725cdc 2958 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 2959 (which isn't thread safe) instead
37725cdc 2960 */
0d7a5398
NIS
2961# error "Don't know how to set FILE.fileno on your platform"
2962#endif
8772537c 2963 PERL_UNUSED_ARG(f);
0d7a5398
NIS
2964 return 0;
2965# endif
2966}
2967
1751d015 2968IV
f62ce20a 2969PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 2970{
c4420975 2971 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
2972 if (!stdio) {
2973 errno = EBADF;
2974 return -1;
2975 }
9217ff3f 2976 else {
de009b76 2977 const int fd = fileno(stdio);
0d7a5398
NIS
2978 int socksfd = 0;
2979 int invalidate = 0;
bbfd922f 2980 IV result = 0;
0d7a5398
NIS
2981 int saveerr = 0;
2982 int dupfd = 0;
2983#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
2984 /* Socks lib overrides close() but stdio isn't linked to
2985 that library (though we are) - so we must call close()
2986 on sockets on stdio's behalf.
2987 */
0d7a5398
NIS
2988 int optval;
2989 Sock_size_t optlen = sizeof(int);
2990 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) {
2991 socksfd = 1;
37725cdc 2992 invalidate = 1;
0d7a5398
NIS
2993 }
2994#endif
9217ff3f
NIS
2995 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2996 /* File descriptor still in use */
0d7a5398
NIS
2997 invalidate = 1;
2998 socksfd = 0;
37725cdc 2999 }
0d7a5398 3000 if (invalidate) {
37725cdc
NIS
3001 /* For STD* handles don't close the stdio at all
3002 this is because we have shared the FILE * too
0d7a5398
NIS
3003 */
3004 if (stdio == stdin) {
3005 /* Some stdios are buggy fflush-ing inputs */
3006 return 0;
3007 }
3008 else if (stdio == stdout || stdio == stderr) {
9217ff3f
NIS
3009 return PerlIO_flush(f);
3010 }
37725cdc
NIS
3011 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3012 Use Sarathy's trick from maint-5.6 to invalidate the
3013 fileno slot of the FILE *
3014 */
bbfd922f 3015 result = PerlIO_flush(f);
0d7a5398
NIS
3016 saveerr = errno;
3017 if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
9217ff3f
NIS
3018 dupfd = PerlLIO_dup(fd);
3019 }
37725cdc 3020 }
0d7a5398 3021 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3022 /* We treat error from stdio as success if we invalidated
3023 errno may NOT be expected EBADF
e8529473
NIS
3024 */
3025 if (invalidate && result != 0) {
0d7a5398
NIS
3026 errno = saveerr;
3027 result = 0;
37725cdc 3028 }
0d7a5398
NIS
3029 if (socksfd) {
3030 /* in SOCKS case let close() determine return value */
3031 result = close(fd);
3032 }
3033 if (dupfd) {
3034 PerlLIO_dup2(dupfd,fd);
8a521f28 3035 PerlLIO_close(dupfd);
9217ff3f
NIS
3036 }
3037 return result;
37725cdc 3038 }
1751d015
NIS
3039}
3040
9e353e3b 3041SSize_t
f62ce20a 3042PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3043{
c4420975 3044 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3045 SSize_t got = 0;
4d948241
NIS
3046 for (;;) {
3047 if (count == 1) {
3048 STDCHAR *buf = (STDCHAR *) vbuf;
3049 /*
3050 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3051 * stdio does not do that for fread()
3052 */
de009b76 3053 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3054 if (ch != EOF) {
3055 *buf = ch;
3056 got = 1;
3057 }
14a5cf38 3058 }
4d948241
NIS
3059 else
3060 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3061 if (got == 0 && PerlSIO_ferror(s))
3062 got = -1;
42a7a32f 3063 if (got >= 0 || errno != EINTR)
4d948241
NIS
3064 break;
3065 PERL_ASYNC_CHECK();
42a7a32f 3066 SETERRNO(0,0); /* just in case */
14a5cf38 3067 }
14a5cf38 3068 return got;
9e353e3b
NIS
3069}
3070
3071SSize_t
f62ce20a 3072PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3073{
14a5cf38 3074 SSize_t unread = 0;
c4420975 3075 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3076
313e59c8 3077#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3078 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3079 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3080 STDCHAR *base = PerlIO_get_base(f);
3081 SSize_t cnt = PerlIO_get_cnt(f);
3082 STDCHAR *ptr = PerlIO_get_ptr(f);
3083 SSize_t avail = ptr - base;
3084 if (avail > 0) {
3085 if (avail > count) {
3086 avail = count;
3087 }
3088 ptr -= avail;
3089 Move(buf-avail,ptr,avail,STDCHAR);
3090 count -= avail;
3091 unread += avail;
3092 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3093 if (PerlSIO_feof(s) && unread >= 0)
3094 PerlSIO_clearerr(s);
3095 }
3096 }
313e59c8
NIS
3097 else
3098#endif
3099 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3100 /* We can get pointer to buffer but not its base
3101 Do ungetc() but check chars are ending up in the
3102 buffer
3103 */
3104 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3105 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3106 while (count > 0) {
de009b76 3107 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3108 if (ungetc(ch,s) != ch) {
3109 /* ungetc did not work */
3110 break;
3111 }
3112 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3113 /* Did not change pointer as expected */
3114 fgetc(s); /* get char back again */
3115 break;
3116 }
3117 /* It worked ! */
3118 count--;
3119 unread++;
93679785
NIS
3120 }
3121 }
3122
3123 if (count > 0) {
3124 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3125 }
3126 return unread;
9e353e3b
NIS
3127}
3128
3129SSize_t
f62ce20a 3130PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3131{
4d948241
NIS
3132 SSize_t got;
3133 for (;;) {
3134 got = PerlSIO_fwrite(vbuf, 1, count,
3135 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3136 if (got >= 0 || errno != EINTR)
4d948241
NIS
3137 break;
3138 PERL_ASYNC_CHECK();
42a7a32f 3139 SETERRNO(0,0); /* just in case */
4d948241
NIS
3140 }
3141 return got;
9e353e3b
NIS
3142}
3143
94a175e1 3144IV
f62ce20a 3145PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3146{
c4420975 3147 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
94a175e1 3148 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3149}
3150
3151Off_t
f62ce20a 3152PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3153{
c4420975 3154 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
94a175e1 3155 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3156}
3157
3158IV
f62ce20a 3159PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3160{
c4420975 3161 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38
JH
3162 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3163 return PerlSIO_fflush(stdio);
3164 }
3165 else {
88b61e10 3166#if 0
14a5cf38
JH
3167 /*
3168 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3169 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3170 * design is to do _this_ but not have layer above flush this
71200d45 3171 * layer read-to-read
14a5cf38
JH
3172 */
3173 /*
71200d45 3174 * Not writeable - sync by attempting a seek
14a5cf38
JH
3175 */
3176 int err = errno;
3177 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3178 errno = err;
88b61e10 3179#endif
14a5cf38
JH
3180 }
3181 return 0;
9e353e3b
NIS
3182}
3183
3184IV
f62ce20a 3185PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3186{
14a5cf38 3187 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3188}
3189
3190IV
f62ce20a 3191PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3192{
263df5f1 3193 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3194}
3195
3196void
f62ce20a 3197PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3198{
14a5cf38 3199 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3200}
3201
3202void
f62ce20a 3203PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b
NIS
3204{
3205#ifdef HAS_SETLINEBUF
14a5cf38 3206 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3207#else
14a5cf38 3208 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
9e353e3b
NIS
3209#endif
3210}
3211
3212#ifdef FILE_base
3213STDCHAR *
f62ce20a 3214PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3215{
c4420975 3216 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3217 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS
3218}
3219
3220Size_t
f62ce20a 3221PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3222{
c4420975 3223 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3224 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS
3225}
3226#endif
3227
3228#ifdef USE_STDIO_PTR
3229STDCHAR *
f62ce20a 3230PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3231{
c4420975 3232 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3233 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS
3234}
3235
3236SSize_t
f62ce20a 3237PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3238{
c4420975 3239 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3240 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS
3241}
3242
3243void
f62ce20a 3244PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3245{
c4420975 3246 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3247 if (ptr != NULL) {
9e353e3b 3248#ifdef STDIO_PTR_LVALUE
22569500 3249 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
9e353e3b 3250#ifdef STDIO_PTR_LVAL_SETS_CNT
14a5cf38 3251 if (PerlSIO_get_cnt(stdio) != (cnt)) {
14a5cf38
JH
3252 assert(PerlSIO_get_cnt(stdio) == (cnt));
3253 }
9e353e3b
NIS
3254#endif
3255#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3256 /*
71200d45 3257 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH
3258 */
3259 return;
9e353e3b 3260#endif
22569500 3261#else /* STDIO_PTR_LVALUE */
14a5cf38 3262 PerlProc_abort();
22569500 3263#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH
3264 }
3265 /*
71200d45 3266 * Now (or only) set cnt
14a5cf38 3267 */
9e353e3b 3268#ifdef STDIO_CNT_LVALUE
14a5cf38 3269 PerlSIO_set_cnt(stdio, cnt);
22569500 3270#else /* STDIO_CNT_LVALUE */
9e353e3b 3271#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH
3272 PerlSIO_set_ptr(stdio,
3273 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3274 cnt));
22569500 3275#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3276 PerlProc_abort();
22569500
NIS
3277#endif /* STDIO_PTR_LVAL_SETS_CNT */
3278#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS
3279}
3280
93679785 3281
9e353e3b
NIS
3282#endif
3283
93679785
NIS
3284IV
3285PerlIOStdio_fill(pTHX_ PerlIO *f)
3286{
c4420975 3287 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785
NIS
3288 int c;
3289 /*
3290 * fflush()ing read-only streams can cause trouble on some stdio-s
3291 */
3292 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3293 if (PerlSIO_fflush(stdio) != 0)
3294 return EOF;
3295 }
3296 c = PerlSIO_fgetc(stdio);
3297 if (c == EOF)
3298 return EOF;
3299
3300#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS
3301
3302#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3303 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3304 /* Fake ungetc() to the real buffer in case system's ungetc
3305 goes elsewhere
3306 */
3307 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3308 SSize_t cnt = PerlSIO_get_cnt(stdio);
3309 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3310 if (ptr == base+1) {
3311 *--ptr = (STDCHAR) c;
3312 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3313 if (PerlSIO_feof(stdio))
3314 PerlSIO_clearerr(stdio);
3315 return 0;
3316 }
3317 }
313e59c8
NIS
3318 else
3319#endif
3320 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3321 STDCHAR ch = c;
3322 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3323 return 0;
3324 }
3325 }
93679785
NIS
3326#endif
3327
3328#if defined(VMS)
3329 /* An ungetc()d char is handled separately from the regular
3330 * buffer, so we stuff it in the buffer ourselves.
3331 * Should never get called as should hit code above
3332 */
bad9695d
NIS
3333 *(--((*stdio)->_ptr)) = (unsigned char) c;
3334 (*stdio)->_cnt++;
93679785
NIS
3335#else
3336 /* If buffer snoop scheme above fails fall back to
9f7cd136 3337 using ungetc().
93679785
NIS
3338 */
3339 if (PerlSIO_ungetc(c, stdio) != c)
3340 return EOF;
3341#endif
3342 return 0;
3343}
3344
3345
3346
27da23d5 3347PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3348 sizeof(PerlIO_funcs),
14a5cf38
JH
3349 "stdio",
3350 sizeof(PerlIOStdio),
86e05cf2 3351 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3352 PerlIOStdio_pushed,
44798d05 3353 PerlIOBase_popped,
14a5cf38 3354 PerlIOStdio_open,
86e05cf2 3355 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
3356 NULL,
3357 PerlIOStdio_fileno,
71200d45 3358 PerlIOStdio_dup,
14a5cf38
JH
3359 PerlIOStdio_read,
3360 PerlIOStdio_unread,
3361 PerlIOStdio_write,
3362 PerlIOStdio_seek,
3363 PerlIOStdio_tell,
3364 PerlIOStdio_close,
3365 PerlIOStdio_flush,
3366 PerlIOStdio_fill,
3367 PerlIOStdio_eof,
3368 PerlIOStdio_error,
3369 PerlIOStdio_clearerr,
3370 PerlIOStdio_setlinebuf,
9e353e3b 3371#ifdef FILE_base
14a5cf38
JH
3372 PerlIOStdio_get_base,
3373 PerlIOStdio_get_bufsiz,
9e353e3b 3374#else
14a5cf38
JH
3375 NULL,
3376 NULL,
9e353e3b
NIS
3377#endif
3378#ifdef USE_STDIO_PTR
14a5cf38
JH
3379 PerlIOStdio_get_ptr,
3380 PerlIOStdio_get_cnt,
15b61c98 3381# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
79ed0f43 3382 PerlIOStdio_set_ptrcnt,
15b61c98
JH
3383# else
3384 NULL,
3385# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3386#else
3387 NULL,
14a5cf38
JH
3388 NULL,
3389 NULL,
15b61c98 3390#endif /* USE_STDIO_PTR */
9e353e3b
NIS
3391};
3392
b9d6bf13
JH
3393/* Note that calls to PerlIO_exportFILE() are reversed using
3394 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3395FILE *
81428673 3396PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3397{
e87a358a 3398 dTHX;
81428673
NIS
3399 FILE *stdio = NULL;
3400 if (PerlIOValid(f)) {
3401 char buf[8];
3402 PerlIO_flush(f);
3403 if (!mode || !*mode) {
3404 mode = PerlIO_modestr(f, buf);
3405 }
3406 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3407 if (stdio) {
3408 PerlIOl *l = *f;
9f75cc58 3409 PerlIO *f2;
81428673
NIS
3410 /* De-link any lower layers so new :stdio sticks */
3411 *f = NULL;
27da23d5 3412 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, Nullsv))) {
9f75cc58 3413 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673
NIS
3414 s->stdio = stdio;
3415 /* Link previous lower layers under new one */
3416 *PerlIONext(f) = l;
3417 }
3418 else {
3419 /* restore layers list */
3420 *f = l;
3421 }
a33cf58c 3422 }
14a5cf38
JH
3423 }
3424 return stdio;
9e353e3b
NIS
3425}
3426
81428673 3427
9e353e3b
NIS
3428FILE *
3429PerlIO_findFILE(PerlIO *f)
3430{
14a5cf38
JH
3431 PerlIOl *l = *f;
3432 while (l) {
3433 if (l->tab == &PerlIO_stdio) {
3434 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3435 return s->stdio;
3436 }
3437 l = *PerlIONext(&l);
f7e7eb72 3438 }
4b069b44
NIS
3439 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3440 return PerlIO_exportFILE(f, Nullch);
9e353e3b
NIS
3441}
3442
b9d6bf13 3443/* Use this to reverse PerlIO_exportFILE calls. */
9e353e3b
NIS
3444void
3445PerlIO_releaseFILE(PerlIO *p, FILE *f)
3446{
27da23d5 3447 dVAR;
22569500
NIS
3448 PerlIOl *l;
3449 while ((l = *p)) {
3450 if (l->tab == &PerlIO_stdio) {
3451 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3452 if (s->stdio == f) {
3453 dTHX;
3454 PerlIO_pop(aTHX_ p);
3455 return;
3456 }
3457 }
3458 p = PerlIONext(p);
3459 }
3460 return;
9e353e3b
NIS
3461}
3462
3463/*--------------------------------------------------------------------------------------*/
14a5cf38 3464/*
71200d45 3465 * perlio buffer layer
14a5cf38 3466 */
9e353e3b 3467
5e2ab84b 3468IV
2dc2558e 3469PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 3470{
14a5cf38 3471 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
de009b76 3472 const int fd = PerlIO_fileno(f);
14a5cf38
JH
3473 if (fd >= 0 && PerlLIO_isatty(fd)) {
3474 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3475 }
4b069b44 3476 if (*PerlIONext(f)) {
de009b76 3477 const Off_t posn = PerlIO_tell(PerlIONext(f));
4b069b44
NIS
3478 if (posn != (Off_t) - 1) {
3479 b->posn = posn;
3480 }
14a5cf38 3481 }
2dc2558e 3482 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b
NIS
3483}
3484
9e353e3b 3485PerlIO *
14a5cf38
JH
3486PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3487 IV n, const char *mode, int fd, int imode, int perm,
3488 PerlIO *f, int narg, SV **args)
3489{
04892f78 3490 if (PerlIOValid(f)) {
14a5cf38 3491 PerlIO *next = PerlIONext(f);
67363c0d
JH
3492 PerlIO_funcs *tab =
3493 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3494 if (tab && tab->Open)
3495 next =
3496 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3497 next, narg, args);
2dc2558e 3498 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
14a5cf38
JH
3499 return NULL;
3500 }
3501 }
3502 else {
04892f78 3503 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38 3504 int init = 0;
3b6c1aba 3505 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
3506 init = 1;
3507 /*
71200d45 3508 * mode++;
14a5cf38
JH
3509 */
3510 }
67363c0d
JH
3511 if (tab && tab->Open)
3512 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3513 f, narg, args);
3514 else
3515 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 3516 if (f) {
22569500 3517 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
b26b1ab5
NC
3518 /*
3519 * if push fails during open, open fails. close will pop us.
3520 */
3521 PerlIO_close (f);
3522 return NULL;
3523 } else {
3524 fd = PerlIO_fileno(f);
b26b1ab5
NC
3525 if (init && fd == 2) {
3526 /*
3527 * Initial stderr is unbuffered
3528 */
3529 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3530 }
23b84778
IZ
3531#ifdef PERLIO_USING_CRLF
3532# ifdef PERLIO_IS_BINMODE_FD
3533 if (PERLIO_IS_BINMODE_FD(fd))
5c728af0 3534 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch);
23b84778
IZ
3535 else
3536# endif
3537 /*
3538 * do something about failing setmode()? --jhi
3539 */
3540 PerlLIO_setmode(fd, O_BINARY);
3541#endif
14a5cf38
JH
3542 }
3543 }
ee518936 3544 }
14a5cf38 3545 return f;
9e353e3b
NIS
3546}
3547
14a5cf38
JH
3548/*
3549 * This "flush" is akin to sfio's sync in that it handles files in either
93c2c2ec
IZ
3550 * read or write state. For write state, we put the postponed data through
3551 * the next layers. For read state, we seek() the next layers to the
3552 * offset given by current position in the buffer, and discard the buffer
3553 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3554 * in any case?). Then the pass the stick further in chain.
14a5cf38 3555 */
9e353e3b 3556IV
f62ce20a 3557PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 3558{
14a5cf38
JH
3559 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3560 int code = 0;
04892f78 3561 PerlIO *n = PerlIONext(f);
14a5cf38
JH
3562 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3563 /*
71200d45 3564 * write() the buffer
14a5cf38 3565 */
de009b76
AL
3566 const STDCHAR *buf = b->buf;
3567 const STDCHAR *p = buf;
14a5cf38
JH
3568 while (p < b->ptr) {
3569 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3570 if (count > 0) {
3571 p += count;
3572 }
3573 else if (count < 0 || PerlIO_error(n)) {
3574 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3575 code = -1;
3576 break;
3577 }
3578 }
3579 b->posn += (p - buf);
3580 }
3581 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3582 STDCHAR *buf = PerlIO_get_base(f);
3583 /*
71200d45 3584 * Note position change
14a5cf38
JH
3585 */
3586 b->posn += (b->ptr - buf);
3587 if (b->ptr < b->end) {
4b069b44
NIS
3588 /* We did not consume all of it - try and seek downstream to
3589 our logical position
14a5cf38 3590 */
4b069b44 3591 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
04892f78
NIS
3592 /* Reload n as some layers may pop themselves on seek */
3593 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38 3594 }
ba5c3fe9 3595 else {
4b069b44
NIS
3596 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3597 data is lost for good - so return saying "ok" having undone
3598 the position adjust
3599 */
3600 b->posn -= (b->ptr - buf);
ba5c3fe9
NIS
3601 return code;
3602 }
14a5cf38
JH
3603 }
3604 }
3605 b->ptr = b->end = b->buf;
3606 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78 3607 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
04892f78 3608 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH
3609 code = -1;
3610 return code;
6f9d8c32
NIS
3611}
3612
93c2c2ec
IZ
3613/* This discards the content of the buffer after b->ptr, and rereads
3614 * the buffer from the position off in the layer downstream; here off
3615 * is at offset corresponding to b->ptr - b->buf.
3616 */
06da4f11 3617IV
f62ce20a 3618PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 3619{
14a5cf38
JH
3620 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3621 PerlIO *n = PerlIONext(f);
3622 SSize_t avail;
3623 /*
4b069b44
NIS
3624 * Down-stream flush is defined not to loose read data so is harmless.
3625 * we would not normally be fill'ing if there was data left in anycase.
14a5cf38 3626 */
93c2c2ec 3627 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */