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