This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence another bcc32 compiler warning
[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 {
e62f0680 311 const char *name = SvPV_nolen_const(*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 {
e62f0680 337 const char *name = SvPV_nolen_const(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
b83604b4 487 s = SvPV_const(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;
e62f0680 847 const char *name = SvPV_const(ST(i), len);
14a5cf38
JH
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)
e62f0680 878 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
c9bca74a
NIS
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 888 STRLEN len;
e62f0680 889 const char *name = SvPV_const(ST(1), len);
de009b76 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) {
b464bac0 1163 PerlIOl *l;
2dc2558e
NIS
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;
b83604b4 1391 type = SvPV_const(layers, len);
14a5cf38
JH
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) {
e62f0680 2446 const char *path = SvPV_nolen_const(*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 2509 while (1) {
b464bac0 2510 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 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 }
b464bac0 2525 /*NOTREACHED*/
9e353e3b
NIS
2526}
2527
2528SSize_t
f62ce20a 2529PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2530{
de009b76 2531 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2532#ifdef PERLIO_STD_SPECIAL
2533 if (fd == 1 || fd == 2)
2534 return PERLIO_STD_OUT(fd, vbuf, count);
2535#endif
14a5cf38 2536 while (1) {
de009b76 2537 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2538 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2539 if (len < 0) {
2540 if (errno != EAGAIN) {
2541 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2542 }
2543 }
14a5cf38
JH
2544 return len;
2545 }
2546 PERL_ASYNC_CHECK();
06da4f11 2547 }
9e353e3b
NIS
2548}
2549
9e353e3b 2550Off_t
f62ce20a 2551PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2552{
14a5cf38 2553 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2554}
2555
71200d45 2556
9e353e3b 2557IV
f62ce20a 2558PerlIOUnix_close(pTHX_ PerlIO *f)
9e353e3b 2559{
de009b76 2560 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2561 int code = 0;
168d5872
NIS
2562 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2563 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2564 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2565 return 0;
22569500 2566 }
93a8090d
NIS
2567 }
2568 else {
93189314 2569 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2570 return -1;
2571 }
14a5cf38
JH
2572 while (PerlLIO_close(fd) != 0) {
2573 if (errno != EINTR) {
2574 code = -1;
2575 break;
2576 }
2577 PERL_ASYNC_CHECK();
2578 }
2579 if (code == 0) {
2580 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2581 }
2582 return code;
9e353e3b
NIS
2583}
2584
27da23d5 2585PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2586 sizeof(PerlIO_funcs),
14a5cf38
JH
2587 "unix",
2588 sizeof(PerlIOUnix),
2589 PERLIO_K_RAW,
2590 PerlIOUnix_pushed,
44798d05 2591 PerlIOBase_popped,
14a5cf38 2592 PerlIOUnix_open,
86e05cf2 2593 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2594 NULL,
2595 PerlIOUnix_fileno,
71200d45 2596 PerlIOUnix_dup,
14a5cf38
JH
2597 PerlIOUnix_read,
2598 PerlIOBase_unread,
2599 PerlIOUnix_write,
2600 PerlIOUnix_seek,
2601 PerlIOUnix_tell,
2602 PerlIOUnix_close,
22569500
NIS
2603 PerlIOBase_noop_ok, /* flush */
2604 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2605 PerlIOBase_eof,
2606 PerlIOBase_error,
2607 PerlIOBase_clearerr,
2608 PerlIOBase_setlinebuf,
22569500
NIS
2609 NULL, /* get_base */
2610 NULL, /* get_bufsiz */
2611 NULL, /* get_ptr */
2612 NULL, /* get_cnt */
2613 NULL, /* set_ptrcnt */
9e353e3b
NIS
2614};
2615
2616/*--------------------------------------------------------------------------------------*/
14a5cf38 2617/*
71200d45 2618 * stdio as a layer
14a5cf38 2619 */
9e353e3b 2620
313e59c8
NIS
2621#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2622/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2623 broken by the last second glibc 2.3 fix
2624 */
2625#define STDIO_BUFFER_WRITABLE
2626#endif
2627
2628
14a5cf38
JH
2629typedef struct {
2630 struct _PerlIO base;
22569500 2631 FILE *stdio; /* The stream */
9e353e3b
NIS
2632} PerlIOStdio;
2633
2634IV
f62ce20a 2635PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2636{
439ba545 2637 FILE *s;
81428673 2638 if (PerlIOValid(f) && (s = PerlIOSelf(f, PerlIOStdio)->stdio)) {
439ba545
NIS
2639 return PerlSIO_fileno(s);
2640 }
2641 errno = EBADF;
2642 return -1;
9e353e3b
NIS
2643}
2644
766a733e 2645char *
14a5cf38
JH
2646PerlIOStdio_mode(const char *mode, char *tmode)
2647{
de009b76 2648 char * const ret = tmode;
a0625d38
SR
2649 if (mode) {
2650 while (*mode) {
2651 *tmode++ = *mode++;
2652 }
14a5cf38 2653 }
95005ad8 2654#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2655 *tmode++ = 'b';
2656#endif
14a5cf38
JH
2657 *tmode = '\0';
2658 return ret;
2659}
2660
4b803d04 2661IV
2dc2558e 2662PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2663{
1fd8f4ce
NIS
2664 PerlIO *n;
2665 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2666 PerlIO_funcs *toptab = PerlIOBase(n)->tab;
2667 if (toptab == tab) {
2668 /* Top is already stdio - pop self (duplicate) and use original */
2669 PerlIO_pop(aTHX_ f);
2670 return 0;
2671 } else {
de009b76 2672 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2673 char tmode[8];
2674 FILE *stdio;
81428673 2675 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
2676 mode = PerlIOStdio_mode(mode, tmode)))) {
2677 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2678 /* We never call down so do any pending stuff now */
2679 PerlIO_flush(PerlIONext(f));
81428673 2680 }
1fd8f4ce
NIS
2681 else {
2682 return -1;
2683 }
2684 }
14a5cf38 2685 }
2dc2558e 2686 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
2687}
2688
22569500 2689
9e353e3b 2690PerlIO *
4b069b44 2691PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2692{
14a5cf38
JH
2693 dTHX;
2694 PerlIO *f = NULL;
2695 if (stdio) {
22569500 2696 PerlIOStdio *s;
4b069b44
NIS
2697 if (!mode || !*mode) {
2698 /* We need to probe to see how we can open the stream
2699 so start with read/write and then try write and read
2700 we dup() so that we can fclose without loosing the fd.
2701
2702 Note that the errno value set by a failing fdopen
2703 varies between stdio implementations.
2704 */
de009b76 2705 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 2706 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2707 if (!f2) {
a33cf58c 2708 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
2709 }
2710 if (!f2) {
a33cf58c 2711 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
2712 }
2713 if (!f2) {
2714 /* Don't seem to be able to open */
2715 PerlLIO_close(fd);
2716 return f;
2717 }
2718 fclose(f2);
22569500 2719 }
27da23d5 2720 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, Nullsv))) {
a33cf58c
NIS
2721 s = PerlIOSelf(f, PerlIOStdio);
2722 s->stdio = stdio;
2723 }
14a5cf38
JH
2724 }
2725 return f;
9e353e3b
NIS
2726}
2727
2728PerlIO *
14a5cf38
JH
2729PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2730 IV n, const char *mode, int fd, int imode,
2731 int perm, PerlIO *f, int narg, SV **args)
2732{
2733 char tmode[8];
d9dac8cd 2734 if (PerlIOValid(f)) {
e62f0680 2735 const char *path = SvPV_nolen_const(*args);
14a5cf38 2736 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS
2737 FILE *stdio;
2738 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2739 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH
2740 s->stdio);
2741 if (!s->stdio)
2742 return NULL;
2743 s->stdio = stdio;
1751d015 2744 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
2745 return f;
2746 }
2747 else {
2748 if (narg > 0) {
e62f0680 2749 const char *path = SvPV_nolen_const(*args);
3b6c1aba 2750 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
2751 mode++;
2752 fd = PerlLIO_open3(path, imode, perm);
2753 }
2754 else {
95005ad8
GH
2755 FILE *stdio;
2756 bool appended = FALSE;
2757#ifdef __CYGWIN__
2758 /* Cygwin wants its 'b' early. */
2759 appended = TRUE;
2760 mode = PerlIOStdio_mode(mode, tmode);
2761#endif
2762 stdio = PerlSIO_fopen(path, mode);
6f0313ac
JH
2763 if (stdio) {
2764 PerlIOStdio *s;
2765 if (!f) {
2766 f = PerlIO_allocate(aTHX);
2767 }
95005ad8
GH
2768 if (!appended)
2769 mode = PerlIOStdio_mode(mode, tmode);
2770 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2771 if (f) {
6f0313ac
JH
2772 s = PerlIOSelf(f, PerlIOStdio);
2773 s->stdio = stdio;
2774 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2775 }
2776 return f;
2777 }
2778 else {
2779 return NULL;
2780 }
14a5cf38
JH
2781 }
2782 }
2783 if (fd >= 0) {
2784 FILE *stdio = NULL;
2785 int init = 0;
3b6c1aba 2786 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
2787 init = 1;
2788 mode++;
2789 }
2790 if (init) {
2791 switch (fd) {
2792 case 0:
2793 stdio = PerlSIO_stdin;
2794 break;
2795 case 1:
2796 stdio = PerlSIO_stdout;
2797 break;
2798 case 2:
2799 stdio = PerlSIO_stderr;
2800 break;
2801 }
2802 }
2803 else {
2804 stdio = PerlSIO_fdopen(fd, mode =
2805 PerlIOStdio_mode(mode, tmode));
2806 }
2807 if (stdio) {
d9dac8cd
NIS
2808 if (!f) {
2809 f = PerlIO_allocate(aTHX);
2810 }
a33cf58c 2811 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
de009b76 2812 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
a33cf58c
NIS
2813 s->stdio = stdio;
2814 PerlIOUnix_refcnt_inc(fileno(s->stdio));
2815 }
14a5cf38
JH
2816 return f;
2817 }
2818 }
2819 }
ee518936 2820 return NULL;
9e353e3b
NIS
2821}
2822
1751d015 2823PerlIO *
ecdeb87c 2824PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
2825{
2826 /* This assumes no layers underneath - which is what
2827 happens, but is not how I remember it. NI-S 2001/10/16
2828 */
ecdeb87c 2829 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 2830 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 2831 const int fd = fileno(stdio);
9217ff3f 2832 char mode[8];
ecdeb87c 2833 if (flags & PERLIO_DUP_FD) {
de009b76 2834 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
2835 if (dfd >= 0) {
2836 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
2837 goto set_this;
ecdeb87c
NIS
2838 }
2839 else {
2840 /* FIXME: To avoid messy error recovery if dup fails
2841 re-use the existing stdio as though flag was not set
2842 */
2843 }
2844 }
9217ff3f
NIS
2845 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
2846 set_this:
694c95cf
JH
2847 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2848 PerlIOUnix_refcnt_inc(fileno(stdio));
1751d015
NIS
2849 }
2850 return f;
2851}
2852
0d7a5398
NIS
2853static int
2854PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
2855{
2856 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 2857 * PerlIO_set_fileno() support from Configure
0d7a5398 2858 */
ef8eacb8
AT
2859# if defined(__UCLIBC__)
2860 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
2861 f->__filedes = -1;
2862 return 1;
2863# elif defined(__GLIBC__)
0d7a5398 2864 /* There may be a better way for GLIBC:
37725cdc 2865 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
2866 */
2867 f->_fileno = -1;
2868 return 1;
2869# elif defined(__sun__)
2870# if defined(_LP64)
2871 /* On solaris, if _LP64 is defined, the FILE structure is this:
2872 *
2873 * struct FILE {
2874 * long __pad[16];
2875 * };
2876 *
37725cdc 2877 * It turns out that the fd is stored in the top 32 bits of
0d7a5398
NIS
2878 * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears
2879 * to contain a pointer or offset into another structure. All the
2880 * remaining fields are zero.
2881 *
2882 * We set the top bits to -1 (0xFFFFFFFF).
2883 */
2884 f->__pad[4] |= 0xffffffff00000000L;
2885 assert(fileno(f) == 0xffffffff);
2886# else /* !defined(_LP64) */
37725cdc
NIS
2887 /* _file is just a unsigned char :-(
2888 Not clear why we dup() rather than using -1
2889 even if that would be treated as 0xFF - so will
0d7a5398
NIS
2890 a dup fail ...
2891 */
673c27c1 2892 f->_file = PerlLIO_dup(fileno(f));
0d7a5398
NIS
2893# endif /* defined(_LP64) */
2894 return 1;
2895# elif defined(__hpux)
2896 f->__fileH = 0xff;
2897 f->__fileL = 0xff;
2898 return 1;
9837d373 2899 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 2900 your platform does not have special entry try this one.
9837d373
NIS
2901 [For OSF only have confirmation for Tru64 (alpha)
2902 but assume other OSFs will be similar.]
37725cdc 2903 */
9837d373 2904# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
2905 f->_file = -1;
2906 return 1;
2907# elif defined(__FreeBSD__)
2908 /* There may be a better way on FreeBSD:
37725cdc
NIS
2909 - we could insert a dummy func in the _close function entry
2910 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
2911 */
2912 f->_file = -1;
0c49ea6a
SU
2913 return 1;
2914# elif defined(__OpenBSD__)
2915 /* There may be a better way on OpenBSD:
2916 - we could insert a dummy func in the _close function entry
2917 f->_close = (int (*)(void *)) dummy_close;
2918 */
2919 f->_file = -1;
0d7a5398 2920 return 1;
59ad941d
IZ
2921# elif defined(__EMX__)
2922 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
2923 f->_handle = -1;
2924 return 1;
0d7a5398
NIS
2925# elif defined(__CYGWIN__)
2926 /* There may be a better way on CYGWIN:
37725cdc
NIS
2927 - we could insert a dummy func in the _close function entry
2928 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
2929 */
2930 f->_file = -1;
2931 return 1;
2932# elif defined(WIN32)
2933# if defined(__BORLANDC__)
2934 f->fd = PerlLIO_dup(fileno(f));
b475b3e6
JH
2935# elif defined(UNDER_CE)
2936 /* WIN_CE does not have access to FILE internals, it hardly has FILE
2937 structure at all
2938 */
0d7a5398
NIS
2939# else
2940 f->_file = -1;
2941# endif
2942 return 1;
2943# else
2944#if 0
37725cdc 2945 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 2946 (which isn't thread safe) instead
37725cdc 2947 */
0d7a5398
NIS
2948# error "Don't know how to set FILE.fileno on your platform"
2949#endif
5d7488b2 2950 (void)f;
0d7a5398
NIS
2951 return 0;
2952# endif
2953}
2954
1751d015 2955IV
f62ce20a 2956PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 2957{
1751d015 2958 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
2959 if (!stdio) {
2960 errno = EBADF;
2961 return -1;
2962 }
9217ff3f 2963 else {
de009b76 2964 const int fd = fileno(stdio);
0d7a5398
NIS
2965 int socksfd = 0;
2966 int invalidate = 0;
bbfd922f 2967 IV result = 0;
0d7a5398
NIS
2968 int saveerr = 0;
2969 int dupfd = 0;
2970#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
2971 /* Socks lib overrides close() but stdio isn't linked to
2972 that library (though we are) - so we must call close()
2973 on sockets on stdio's behalf.
2974 */
0d7a5398
NIS
2975 int optval;
2976 Sock_size_t optlen = sizeof(int);
2977 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) {
2978 socksfd = 1;
37725cdc 2979 invalidate = 1;
0d7a5398
NIS
2980 }
2981#endif
9217ff3f
NIS
2982 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2983 /* File descriptor still in use */
0d7a5398
NIS
2984 invalidate = 1;
2985 socksfd = 0;
37725cdc 2986 }
0d7a5398 2987 if (invalidate) {
37725cdc
NIS
2988 /* For STD* handles don't close the stdio at all
2989 this is because we have shared the FILE * too
0d7a5398
NIS
2990 */
2991 if (stdio == stdin) {
2992 /* Some stdios are buggy fflush-ing inputs */
2993 return 0;
2994 }
2995 else if (stdio == stdout || stdio == stderr) {
9217ff3f
NIS
2996 return PerlIO_flush(f);
2997 }
37725cdc
NIS
2998 /* Tricky - must fclose(stdio) to free memory but not close(fd)
2999 Use Sarathy's trick from maint-5.6 to invalidate the
3000 fileno slot of the FILE *
3001 */
bbfd922f 3002 result = PerlIO_flush(f);
0d7a5398
NIS
3003 saveerr = errno;
3004 if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
9217ff3f
NIS
3005 dupfd = PerlLIO_dup(fd);
3006 }
37725cdc 3007 }
0d7a5398 3008 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3009 /* We treat error from stdio as success if we invalidated
3010 errno may NOT be expected EBADF
e8529473
NIS
3011 */
3012 if (invalidate && result != 0) {
0d7a5398
NIS
3013 errno = saveerr;
3014 result = 0;
37725cdc 3015 }
0d7a5398
NIS
3016 if (socksfd) {
3017 /* in SOCKS case let close() determine return value */
3018 result = close(fd);
3019 }
3020 if (dupfd) {
3021 PerlLIO_dup2(dupfd,fd);
8a521f28 3022 PerlLIO_close(dupfd);
9217ff3f
NIS
3023 }
3024 return result;
37725cdc 3025 }
1751d015
NIS
3026}
3027
9e353e3b 3028SSize_t
f62ce20a 3029PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3030{
14a5cf38
JH
3031 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
3032 SSize_t got = 0;
4d948241
NIS
3033 for (;;) {
3034 if (count == 1) {
3035 STDCHAR *buf = (STDCHAR *) vbuf;
3036 /*
3037 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3038 * stdio does not do that for fread()
3039 */
de009b76 3040 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3041 if (ch != EOF) {
3042 *buf = ch;
3043 got = 1;
3044 }
14a5cf38 3045 }
4d948241
NIS
3046 else
3047 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3048 if (got == 0 && PerlSIO_ferror(s))
3049 got = -1;
42a7a32f 3050 if (got >= 0 || errno != EINTR)
4d948241
NIS
3051 break;
3052 PERL_ASYNC_CHECK();
42a7a32f 3053 SETERRNO(0,0); /* just in case */
14a5cf38 3054 }
14a5cf38 3055 return got;
9e353e3b
NIS
3056}
3057
3058SSize_t
f62ce20a 3059PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3060{
14a5cf38 3061 SSize_t unread = 0;
93679785
NIS
3062 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
3063
313e59c8 3064#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3065 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3066 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3067 STDCHAR *base = PerlIO_get_base(f);
3068 SSize_t cnt = PerlIO_get_cnt(f);
3069 STDCHAR *ptr = PerlIO_get_ptr(f);
3070 SSize_t avail = ptr - base;
3071 if (avail > 0) {
3072 if (avail > count) {
3073 avail = count;
3074 }
3075 ptr -= avail;
3076 Move(buf-avail,ptr,avail,STDCHAR);
3077 count -= avail;
3078 unread += avail;
3079 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3080 if (PerlSIO_feof(s) && unread >= 0)
3081 PerlSIO_clearerr(s);
3082 }
3083 }
313e59c8
NIS
3084 else
3085#endif
3086 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3087 /* We can get pointer to buffer but not its base
3088 Do ungetc() but check chars are ending up in the
3089 buffer
3090 */
3091 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3092 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3093 while (count > 0) {
de009b76 3094 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3095 if (ungetc(ch,s) != ch) {
3096 /* ungetc did not work */
3097 break;
3098 }
3099 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3100 /* Did not change pointer as expected */
3101 fgetc(s); /* get char back again */
3102 break;
3103 }
3104 /* It worked ! */
3105 count--;
3106 unread++;
93679785
NIS
3107 }
3108 }
3109
3110 if (count > 0) {
3111 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3112 }
3113 return unread;
9e353e3b
NIS
3114}
3115
3116SSize_t
f62ce20a 3117PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3118{
4d948241
NIS
3119 SSize_t got;
3120 for (;;) {
3121 got = PerlSIO_fwrite(vbuf, 1, count,
3122 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3123 if (got >= 0 || errno != EINTR)
4d948241
NIS
3124 break;
3125 PERL_ASYNC_CHECK();
42a7a32f 3126 SETERRNO(0,0); /* just in case */
4d948241
NIS
3127 }
3128 return got;
9e353e3b
NIS
3129}
3130
94a175e1 3131IV
f62ce20a 3132PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3133{
14a5cf38 3134 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
94a175e1 3135 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3136}
3137
3138Off_t
f62ce20a 3139PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3140{
14a5cf38 3141 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
94a175e1 3142 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3143}
3144
3145IV
f62ce20a 3146PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3147{
14a5cf38
JH
3148 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3149 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3150 return PerlSIO_fflush(stdio);
3151 }
3152 else {
88b61e10 3153#if 0
14a5cf38
JH
3154 /*
3155 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3156 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3157 * design is to do _this_ but not have layer above flush this
71200d45 3158 * layer read-to-read
14a5cf38
JH
3159 */
3160 /*
71200d45 3161 * Not writeable - sync by attempting a seek
14a5cf38
JH
3162 */
3163 int err = errno;
3164 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3165 errno = err;
88b61e10 3166#endif
14a5cf38
JH
3167 }
3168 return 0;
9e353e3b
NIS
3169}
3170
3171IV
f62ce20a 3172PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3173{
14a5cf38 3174 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3175}
3176
3177IV
f62ce20a 3178PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3179{
263df5f1 3180 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3181}
3182
3183void
f62ce20a 3184PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3185{
14a5cf38 3186 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3187}
3188
3189void
f62ce20a 3190PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b
NIS
3191{
3192#ifdef HAS_SETLINEBUF
14a5cf38 3193 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3194#else
14a5cf38 3195 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
9e353e3b
NIS
3196#endif
3197}
3198
3199#ifdef FILE_base
3200STDCHAR *
f62ce20a 3201PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3202{
14a5cf38 3203 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3204 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS
3205}
3206
3207Size_t
f62ce20a 3208PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3209{
14a5cf38
JH
3210 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3211 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS
3212}
3213#endif
3214
3215#ifdef USE_STDIO_PTR
3216STDCHAR *
f62ce20a 3217PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3218{
14a5cf38 3219 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3220 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS
3221}
3222
3223SSize_t
f62ce20a 3224PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3225{
14a5cf38
JH
3226 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3227 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS
3228}
3229
3230void
f62ce20a 3231PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3232{
14a5cf38 3233 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3234 if (ptr != NULL) {
9e353e3b 3235#ifdef STDIO_PTR_LVALUE
22569500 3236 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
9e353e3b 3237#ifdef STDIO_PTR_LVAL_SETS_CNT
14a5cf38 3238 if (PerlSIO_get_cnt(stdio) != (cnt)) {
14a5cf38
JH
3239 assert(PerlSIO_get_cnt(stdio) == (cnt));
3240 }
9e353e3b
NIS
3241#endif
3242#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3243 /*
71200d45 3244 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH
3245 */
3246 return;
9e353e3b 3247#endif
22569500 3248#else /* STDIO_PTR_LVALUE */
14a5cf38 3249 PerlProc_abort();
22569500 3250#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH
3251 }
3252 /*
71200d45 3253 * Now (or only) set cnt
14a5cf38 3254 */
9e353e3b 3255#ifdef STDIO_CNT_LVALUE
14a5cf38 3256 PerlSIO_set_cnt(stdio, cnt);
22569500 3257#else /* STDIO_CNT_LVALUE */
9e353e3b 3258#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH
3259 PerlSIO_set_ptr(stdio,
3260 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3261 cnt));
22569500 3262#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3263 PerlProc_abort();
22569500
NIS
3264#endif /* STDIO_PTR_LVAL_SETS_CNT */
3265#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS
3266}
3267
93679785 3268
9e353e3b
NIS
3269#endif
3270
93679785
NIS
3271IV
3272PerlIOStdio_fill(pTHX_ PerlIO *f)
3273{
3274 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3275 int c;
3276 /*
3277 * fflush()ing read-only streams can cause trouble on some stdio-s
3278 */
3279 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3280 if (PerlSIO_fflush(stdio) != 0)
3281 return EOF;
3282 }
3283 c = PerlSIO_fgetc(stdio);
3284 if (c == EOF)
3285 return EOF;
3286
3287#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS
3288
3289#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3290 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3291 /* Fake ungetc() to the real buffer in case system's ungetc
3292 goes elsewhere
3293 */
3294 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3295 SSize_t cnt = PerlSIO_get_cnt(stdio);
3296 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3297 if (ptr == base+1) {
3298 *--ptr = (STDCHAR) c;
3299 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3300 if (PerlSIO_feof(stdio))
3301 PerlSIO_clearerr(stdio);
3302 return 0;
3303 }
3304 }
313e59c8
NIS
3305 else
3306#endif
3307 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3308 STDCHAR ch = c;
3309 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3310 return 0;
3311 }
3312 }
93679785
NIS
3313#endif
3314
3315#if defined(VMS)
3316 /* An ungetc()d char is handled separately from the regular
3317 * buffer, so we stuff it in the buffer ourselves.
3318 * Should never get called as should hit code above
3319 */
bad9695d
NIS
3320 *(--((*stdio)->_ptr)) = (unsigned char) c;
3321 (*stdio)->_cnt++;
93679785
NIS
3322#else
3323 /* If buffer snoop scheme above fails fall back to
9f7cd136 3324 using ungetc().
93679785
NIS
3325 */
3326 if (PerlSIO_ungetc(c, stdio) != c)
3327 return EOF;
3328#endif
3329 return 0;
3330}
3331
3332
3333
27da23d5 3334PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3335 sizeof(PerlIO_funcs),
14a5cf38
JH
3336 "stdio",
3337 sizeof(PerlIOStdio),
86e05cf2 3338 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3339 PerlIOStdio_pushed,
44798d05 3340 PerlIOBase_popped,
14a5cf38 3341 PerlIOStdio_open,
86e05cf2 3342 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
3343 NULL,
3344 PerlIOStdio_fileno,
71200d45 3345 PerlIOStdio_dup,
14a5cf38
JH
3346 PerlIOStdio_read,
3347 PerlIOStdio_unread,
3348 PerlIOStdio_write,
3349 PerlIOStdio_seek,
3350 PerlIOStdio_tell,
3351 PerlIOStdio_close,
3352 PerlIOStdio_flush,
3353 PerlIOStdio_fill,
3354 PerlIOStdio_eof,
3355 PerlIOStdio_error,
3356 PerlIOStdio_clearerr,
3357 PerlIOStdio_setlinebuf,
9e353e3b 3358#ifdef FILE_base
14a5cf38
JH
3359 PerlIOStdio_get_base,
3360 PerlIOStdio_get_bufsiz,
9e353e3b 3361#else
14a5cf38
JH
3362 NULL,
3363 NULL,
9e353e3b
NIS
3364#endif
3365#ifdef USE_STDIO_PTR
14a5cf38
JH
3366 PerlIOStdio_get_ptr,
3367 PerlIOStdio_get_cnt,
15b61c98 3368# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
79ed0f43 3369 PerlIOStdio_set_ptrcnt,
15b61c98
JH
3370# else
3371 NULL,
3372# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3373#else
3374 NULL,
14a5cf38
JH
3375 NULL,
3376 NULL,
15b61c98 3377#endif /* USE_STDIO_PTR */
9e353e3b
NIS
3378};
3379
b9d6bf13
JH
3380/* Note that calls to PerlIO_exportFILE() are reversed using
3381 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3382FILE *
81428673 3383PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3384{
e87a358a 3385 dTHX;
81428673
NIS
3386 FILE *stdio = NULL;
3387 if (PerlIOValid(f)) {
3388 char buf[8];
3389 PerlIO_flush(f);
3390 if (!mode || !*mode) {
3391 mode = PerlIO_modestr(f, buf);
3392 }
3393 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3394 if (stdio) {
3395 PerlIOl *l = *f;
9f75cc58 3396 PerlIO *f2;
81428673
NIS
3397 /* De-link any lower layers so new :stdio sticks */
3398 *f = NULL;
27da23d5 3399 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, Nullsv))) {
9f75cc58 3400 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673
NIS
3401 s->stdio = stdio;
3402 /* Link previous lower layers under new one */
3403 *PerlIONext(f) = l;
3404 }
3405 else {
3406 /* restore layers list */
3407 *f = l;
3408 }
a33cf58c 3409 }
14a5cf38
JH
3410 }
3411 return stdio;
9e353e3b
NIS
3412}
3413
81428673 3414
9e353e3b
NIS
3415FILE *
3416PerlIO_findFILE(PerlIO *f)
3417{
14a5cf38
JH
3418 PerlIOl *l = *f;
3419 while (l) {
3420 if (l->tab == &PerlIO_stdio) {
3421 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3422 return s->stdio;
3423 }
3424 l = *PerlIONext(&l);
f7e7eb72 3425 }
4b069b44
NIS
3426 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3427 return PerlIO_exportFILE(f, Nullch);
9e353e3b
NIS
3428}
3429
b9d6bf13 3430/* Use this to reverse PerlIO_exportFILE calls. */
9e353e3b
NIS
3431void
3432PerlIO_releaseFILE(PerlIO *p, FILE *f)
3433{
27da23d5 3434 dVAR;
22569500
NIS
3435 PerlIOl *l;
3436 while ((l = *p)) {
3437 if (l->tab == &PerlIO_stdio) {
3438 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3439 if (s->stdio == f) {
3440 dTHX;
3441 PerlIO_pop(aTHX_ p);
3442 return;
3443 }
3444 }
3445 p = PerlIONext(p);
3446 }
3447 return;
9e353e3b
NIS
3448}
3449
3450/*--------------------------------------------------------------------------------------*/
14a5cf38 3451/*
71200d45 3452 * perlio buffer layer
14a5cf38 3453 */
9e353e3b 3454
5e2ab84b 3455IV
2dc2558e 3456PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 3457{
14a5cf38 3458 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
de009b76 3459 const int fd = PerlIO_fileno(f);
14a5cf38
JH
3460 if (fd >= 0 && PerlLIO_isatty(fd)) {
3461 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3462 }
4b069b44 3463 if (*PerlIONext(f)) {
de009b76 3464 const Off_t posn = PerlIO_tell(PerlIONext(f));
4b069b44
NIS
3465 if (posn != (Off_t) - 1) {
3466 b->posn = posn;
3467 }
14a5cf38 3468 }
2dc2558e 3469 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b
NIS
3470}
3471
9e353e3b 3472PerlIO *
14a5cf38
JH
3473PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3474 IV n, const char *mode, int fd, int imode, int perm,
3475 PerlIO *f, int narg, SV **args)
3476{
04892f78 3477 if (PerlIOValid(f)) {
14a5cf38 3478 PerlIO *next = PerlIONext(f);
67363c0d
JH
3479 PerlIO_funcs *tab =
3480 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3481 if (tab && tab->Open)
3482 next =
3483 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3484 next, narg, args);
2dc2558e 3485 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
14a5cf38
JH
3486 return NULL;
3487 }
3488 }
3489 else {
04892f78 3490 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38 3491 int init = 0;
3b6c1aba 3492 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
3493 init = 1;
3494 /*
71200d45 3495 * mode++;
14a5cf38
JH
3496 */
3497 }
67363c0d
JH
3498 if (tab && tab->Open)
3499 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3500 f, narg, args);
3501 else
3502 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 3503 if (f) {
22569500 3504 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
b26b1ab5
NC
3505 /*
3506 * if push fails during open, open fails. close will pop us.
3507 */
3508 PerlIO_close (f);
3509 return NULL;
3510 } else {
3511 fd = PerlIO_fileno(f);
b26b1ab5
NC
3512 if (init && fd == 2) {
3513 /*
3514 * Initial stderr is unbuffered
3515 */
3516 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3517 }
23b84778
IZ
3518#ifdef PERLIO_USING_CRLF
3519# ifdef PERLIO_IS_BINMODE_FD
3520 if (PERLIO_IS_BINMODE_FD(fd))
5c728af0 3521 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, Nullch);
23b84778
IZ
3522 else
3523# endif
3524 /*
3525 * do something about failing setmode()? --jhi
3526 */
3527 PerlLIO_setmode(fd, O_BINARY);
3528#endif
14a5cf38
JH
3529 }
3530 }
ee518936 3531 }
14a5cf38 3532 return f;
9e353e3b
NIS
3533}
3534
14a5cf38
JH
3535/*
3536 * This "flush" is akin to sfio's sync in that it handles files in either
71200d45 3537 * read or write state
14a5cf38 3538 */
9e353e3b 3539IV
f62ce20a 3540PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 3541{
14a5cf38
JH
3542 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3543 int code = 0;
04892f78 3544 PerlIO *n = PerlIONext(f);
14a5cf38
JH
3545 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3546 /*
71200d45 3547 * write() the buffer
14a5cf38 3548 */
de009b76
AL
3549 const STDCHAR *buf = b->buf;
3550 const STDCHAR *p = buf;
14a5cf38
JH
3551 while (p < b->ptr) {
3552 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3553 if (count > 0) {
3554 p += count;
3555 }
3556 else if (count < 0 || PerlIO_error(n)) {
3557 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3558 code = -1;
3559 break;
3560 }
3561 }
3562 b->posn += (p - buf);
3563 }
3564 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3565 STDCHAR *buf = PerlIO_get_base(f);
3566 /*
71200d45 3567 * Note position change
14a5cf38
JH
3568 */
3569 b->posn += (b->ptr - buf);
3570 if (b->ptr < b->end) {
4b069b44
NIS
3571 /* We did not consume all of it - try and seek downstream to
3572 our logical position
14a5cf38 3573 */
4b069b44 3574 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
04892f78
NIS
3575 /* Reload n as some layers may pop themselves on seek */
3576 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38 3577 }
ba5c3fe9 3578 else {
4b069b44
NIS
3579 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3580 data is lost for good - so return saying "ok" having undone
3581 the position adjust
3582 */
3583 b->posn -= (b->ptr - buf);
ba5c3fe9
NIS
3584 return code;
3585 }
14a5cf38
JH
3586 }
3587 }
3588 b->ptr = b->end = b->buf;
3589 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78 3590 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
04892f78 3591 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH
3592 code = -1;
3593 return code;
6f9d8c32
NIS
3594}
3595
06da4f11 3596IV
f62ce20a 3597PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 3598{
14a5cf38
JH
3599 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3600 PerlIO *n = PerlIONext(f);
3601 SSize_t avail;
3602 /*
4b069b44
NIS
3603 * Down-stream flush is defined not to loose read data so is harmless.
3604 * we would not normally be fill'ing if there was data left in anycase.
14a5cf38
JH
3605 */
3606 if (PerlIO_flush(f) != 0)
3607 return -1;
3608 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
f62ce20a 3609 PerlIOBase_flush_linebuf(aTHX);
14a5cf38
JH
3610
3611 if (!b->buf)
22569500 3612 PerlIO_get_base(f); /* allocate via vtable */
14a5cf38
JH
3613
3614 b->ptr = b->end = b->buf;
4b069b44
NIS
3615
3616 if (!PerlIOValid(n)) {
3617 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3618 return -1;
3619 }
3620
14a5cf38
JH
3621 if (PerlIO_fast_gets(n)) {
3622 /*
04892f78 3623 * Layer below is also buffered. We do _NOT_ want to call its
14a5cf38
JH
3624 * ->Read() because that will loop till it gets what we asked for
3625 * which may hang on a pipe etc. Instead take anything it has to
71200d45 3626 * hand, or ask it to fill _once_.
14a5cf38
JH
3627 */
3628 avail = PerlIO_get_cnt(n);
3629 if (avail <= 0) {
3630 avail = PerlIO_fill(n);
3631 if (avail == 0)