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