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