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