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