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