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