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