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
Here be camels
[perl5.git] / perlio.c
CommitLineData
14a5cf38 1/*
5cb43542
RGS		 2 * perlio.c
3 * Copyright (c) 1996-2006, Nick Ing-Simmons
2eee27d7 4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
5cb43542
RGS		 5 *
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
760ac839
LW		 8 */
9
14a5cf38 10/*
d31a8517
AT		 11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
4ac71550
TC		 13 *
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
d31a8517
AT		 15 */
16
166f8a29
DM		 17/* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
21 */
22
d31a8517 23/*
71200d45 24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
14a5cf38 25 * at the dispatch tables, even when we do not need it for other reasons.
71200d45 26 * Invent a dSYS macro to abstract this out
14a5cf38 27 */
7bcba3d4 28#ifdef PERL_IMPLICIT_SYS
d0e4ea4d 29# define dSYS dTHX
7bcba3d4 30#else
d0e4ea4d 31# define dSYS dNOOP
7bcba3d4
NIS		 32#endif
33
6f9d8c32 34#define PERLIO_NOT_STDIO 0
760ac839 35/*
6f9d8c32 36 * This file provides those parts of PerlIO abstraction
88b61e10 37 * which are not #defined in perlio.h.
6f9d8c32 38 * Which these are depends on various Configure #ifdef's
760ac839
LW		 39 */
40
41#include "EXTERN.h"
864dbfa3 42#define PERL_IN_PERLIO_C
760ac839
LW		 43#include "perl.h"
44
32af7c23 45#ifdef PERL_IMPLICIT_CONTEXT
d0e4ea4d
KW		 46# undef dSYS
47# define dSYS dTHX
32af7c23
CL		 48#endif
49
0c4f7ff0
NIS		 50#include "XSUB.h"
51
25bbd826 52#ifdef VMS
d0e4ea4d 53# include <rms.h>
25bbd826
CB		 54#endif
55
abf9167d
DM		 56#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
57
1b7a0411 58/* Call the callback or PerlIOBase, and return failure. */
b32dd47e 59#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
1b7a0411 60 if (PerlIOValid(f)) { \
46c461b5 61 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH		 62 if (tab && tab->callback) \
63 return (*tab->callback) args; \
64 else \
65 return PerlIOBase_ ## base args; \
66 } \
67 else \
68 SETERRNO(EBADF, SS_IVCHAN); \
69 return failure
70
71/* Call the callback or fail, and return failure. */
b32dd47e 72#define Perl_PerlIO_or_fail(f, callback, failure, args) \
1b7a0411 73 if (PerlIOValid(f)) { \
46c461b5 74 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH		 75 if (tab && tab->callback) \
76 return (*tab->callback) args; \
77 SETERRNO(EINVAL, LIB_INVARG); \
78 } \
79 else \
80 SETERRNO(EBADF, SS_IVCHAN); \
81 return failure
82
83/* Call the callback or PerlIOBase, and be void. */
b32dd47e 84#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
1b7a0411 85 if (PerlIOValid(f)) { \
46c461b5 86 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH		 87 if (tab && tab->callback) \
88 (*tab->callback) args; \
89 else \
90 PerlIOBase_ ## base args; \
1b7a0411
JH		 91 } \
92 else \
93 SETERRNO(EBADF, SS_IVCHAN)
94
95/* Call the callback or fail, and be void. */
b32dd47e 96#define Perl_PerlIO_or_fail_void(f, callback, args) \
1b7a0411 97 if (PerlIOValid(f)) { \
46c461b5 98 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
1b7a0411
JH		 99 if (tab && tab->callback) \
100 (*tab->callback) args; \
37725cdc
NIS		 101 else \
102 SETERRNO(EINVAL, LIB_INVARG); \
1b7a0411
JH		 103 } \
104 else \
105 SETERRNO(EBADF, SS_IVCHAN)
106
89a3a251
JH		 107#if defined(__osf__) && _XOPEN_SOURCE < 500
108extern int fseeko(FILE *, off_t, int);
109extern off_t ftello(FILE *);
110#endif
111
76e6dc3a
KW		 112#define NATIVE_0xd CR_NATIVE
113#define NATIVE_0xa LF_NATIVE
114
a0c21aa1
JH		 115EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
116
71ab4674
SP		 117int
118perlsio_binmode(FILE *fp, int iotype, int mode)
119{
120 /*
121 * This used to be contents of do_binmode in doio.c
122 */
123#ifdef DOSISH
71ab4674 124 dTHX;
58c0efa5 125 PERL_UNUSED_ARG(iotype);
d0e4ea4d 126# ifdef NETWARE
71ab4674 127 if (PerlLIO_setmode(fp, mode) != -1) {
d0e4ea4d 128# else
71ab4674 129 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
d0e4ea4d 130# endif
71ab4674
SP		 131 return 1;
132 }
133 else
134 return 0;
71ab4674
SP		 135#else
136# if defined(USEMYBINMODE)
137 dTHX;
58c0efa5
RGS		 138# if defined(__CYGWIN__)
139 PERL_UNUSED_ARG(iotype);
140# endif
71ab4674
SP		 141 if (my_binmode(fp, iotype, mode) != FALSE)
142 return 1;
143 else
144 return 0;
145# else
146 PERL_UNUSED_ARG(fp);
147 PERL_UNUSED_ARG(iotype);
148 PERL_UNUSED_ARG(mode);
149 return 1;
150# endif
151#endif
152}
71ab4674 153
06c7082d 154#ifndef O_ACCMODE
d0e4ea4d 155# define O_ACCMODE 3 /* Assume traditional implementation */
06c7082d
NIS		 156#endif
157
158int
159PerlIO_intmode2str(int rawmode, char *mode, int *writing)
160{
de009b76 161 const int result = rawmode & O_ACCMODE;
06c7082d
NIS		 162 int ix = 0;
163 int ptype;
164 switch (result) {
165 case O_RDONLY:
166 ptype = IoTYPE_RDONLY;
167 break;
168 case O_WRONLY:
169 ptype = IoTYPE_WRONLY;
170 break;
171 case O_RDWR:
172 default:
173 ptype = IoTYPE_RDWR;
174 break;
175 }
176 if (writing)
177 *writing = (result != O_RDONLY);
178
179 if (result == O_RDONLY) {
180 mode[ix++] = 'r';
181 }
182#ifdef O_APPEND
183 else if (rawmode & O_APPEND) {
184 mode[ix++] = 'a';
185 if (result != O_WRONLY)
186 mode[ix++] = '+';
187 }
188#endif
189 else {
190 if (result == O_WRONLY)
191 mode[ix++] = 'w';
192 else {
193 mode[ix++] = 'r';
194 mode[ix++] = '+';
195 }
196 }
43e5477e
JH		 197#if O_BINARY != 0
198 /* Unless O_BINARY is different from zero, bit-and:ing
199 * with it won't do much good. */
06c7082d
NIS		 200 if (rawmode & O_BINARY)
201 mode[ix++] = 'b';
d0e4ea4d 202#endif
06c7082d
NIS		 203 mode[ix] = '\0';
204 return ptype;
205}
206
eb73beca
NIS		 207#ifndef PERLIO_LAYERS
208int
209PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
210{
6874a2de
NIS		 211 if (!names || !*names
212 || strEQ(names, ":crlf")
213 || strEQ(names, ":raw")
214 || strEQ(names, ":bytes")
215 ) {
14a5cf38
JH		 216 return 0;
217 }
218 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
219 /*
71200d45 220 * NOTREACHED
14a5cf38
JH		 221 */
222 return -1;
eb73beca
NIS		 223}
224
13621cfb
NIS		 225void
226PerlIO_destruct(pTHX)
227{
228}
229
f5b9d040
NIS		 230int
231PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
232{
14a5cf38 233 return perlsio_binmode(fp, iotype, mode);
f5b9d040 234}
60382766 235
e0fa5af2 236PerlIO *
ecdeb87c 237PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
e0fa5af2 238{
d0e4ea4d 239# if defined(PERL_MICRO)
0553478e 240 return NULL;
d0e4ea4d 241# elif defined(PERL_IMPLICIT_SYS)
22569500 242 return PerlSIO_fdupopen(f);
d0e4ea4d
KW		 243# else
244# ifdef WIN32
30753f56 245 return win32_fdupopen(f);
d0e4ea4d 246# else
e0fa5af2 247 if (f) {
884fc2d3 248 const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f));
e0fa5af2 249 if (fd >= 0) {
06c7082d 250 char mode[8];
d0e4ea4d 251# ifdef DJGPP
dcda55fc 252 const int omode = djgpp_get_stream_mode(f);
d0e4ea4d 253# else
dcda55fc 254 const int omode = fcntl(fd, F_GETFL);
d0e4ea4d 255# endif
06c7082d 256 PerlIO_intmode2str(omode,mode,NULL);
e0fa5af2 257 /* the r+ is a hack */
06c7082d 258 return PerlIO_fdopen(fd, mode);
e0fa5af2
NIS		 259 }
260 return NULL;
261 }
262 else {
93189314 263 SETERRNO(EBADF, SS_IVCHAN);
e0fa5af2 264 }
d0e4ea4d 265# endif
e0fa5af2 266 return NULL;
d0e4ea4d 267# endif
e0fa5af2
NIS		 268}
269
270
14a5cf38 271/*
71200d45 272 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
14a5cf38 273 */
ee518936
NIS		 274
275PerlIO *
14a5cf38
JH		 276PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
277 int imode, int perm, PerlIO *old, int narg, SV **args)
278{
7cf31beb
NIS		 279 if (narg) {
280 if (narg > 1) {
3b8752bb 281 Perl_croak(aTHX_ "More than one argument to open");
7cf31beb 282 }
14a5cf38
JH		 283 if (*args == &PL_sv_undef)
284 return PerlIO_tmpfile();
285 else {
41188aa0 286 STRLEN len;
74622586 287 const char *name = SvPV_const(*args, len);
41188aa0 288 if (!IS_SAFE_PATHNAME(name, len, "open"))
c8028aa6
TC		 289 return NULL;
290
3b6c1aba 291 if (*mode == IoTYPE_NUMERIC) {
884fc2d3 292 fd = PerlLIO_open3_cloexec(name, imode, perm);
14a5cf38 293 if (fd >= 0)
de009b76 294 return PerlIO_fdopen(fd, mode + 1);
14a5cf38
JH		 295 }
296 else if (old) {
297 return PerlIO_reopen(name, mode, old);
298 }
299 else {
300 return PerlIO_open(name, mode);
301 }
302 }
303 }
304 else {
305 return PerlIO_fdopen(fd, (char *) mode);
306 }
307 return NULL;
ee518936
NIS		 308}
309
15eb3045 310XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
0c4f7ff0
NIS		 311XS(XS_PerlIO__Layer__find)
312{
14a5cf38
JH		 313 dXSARGS;
314 if (items < 2)
315 Perl_croak(aTHX_ "Usage class->find(name[,load])");
316 else {
dcda55fc 317 const char * const name = SvPV_nolen_const(ST(1));
14a5cf38
JH		 318 ST(0) = (strEQ(name, "crlf")
319 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
320 XSRETURN(1);
321 }
0c4f7ff0
NIS		 322}
323
324
325void
326Perl_boot_core_PerlIO(pTHX)
327{
14a5cf38 328 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
0c4f7ff0
NIS		 329}
330
ac27b0f5
NIS		 331#endif
332
32e30700 333
6f9d8c32 334/*======================================================================================*/
14a5cf38 335/*
71200d45 336 * Implement all the PerlIO interface ourselves.
9e353e3b 337 */
760ac839 338
76ced9ad
NIS		 339#include "perliol.h"
340
6f9d8c32 341void
14a5cf38
JH		 342PerlIO_debug(const char *fmt, ...)
343{
14a5cf38
JH		 344 va_list ap;
345 dSYS;
e17bc05a
TC		 346
347 if (!DEBUG_i_TEST)
348 return;
349
d732c5e5
JH		 350 va_start(ap, fmt);
351
582588d2 352 if (!PL_perlio_debug_fd) {
284167a5 353 if (!TAINTING_get &&
985213f2
AB		 354 PerlProc_getuid() == PerlProc_geteuid() &&
355 PerlProc_getgid() == PerlProc_getegid()) {
582588d2
NC		 356 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
357 if (s && *s)
0b5984d3
Z		 358 PL_perlio_debug_fd = PerlLIO_open3_cloexec(s,
359 O_WRONLY | O_CREAT | O_APPEND, 0666);
582588d2 360 else
0b5984d3 361 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
582588d2 362 } else {
64320867
TC		 363 /* tainting or set*id, so ignore the environment and send the
364 debug output to stderr, like other -D switches. */
0b5984d3 365 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
582588d2 366 }
14a5cf38 367 }
27da23d5 368 if (PL_perlio_debug_fd > 0) {
70ace5da 369#ifdef USE_ITHREADS
dcda55fc 370 const char * const s = CopFILE(PL_curcop);
70ace5da
NIS		 371 /* Use fixed buffer as sv_catpvf etc. needs SVs */
372 char buffer[1024];
1208b3dd 373 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
048eef38
TC		 374# ifdef USE_QUADMATH
375# ifdef HAS_VSNPRINTF
376 /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf()
377 should be, otherwise the system isn't likely to support quadmath.
378 Nothing should be calling PerlIO_debug() with floating point anyway.
379 */
380 const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
381# else
382 STATIC_ASSERT_STMT(0);
383# endif
384# else
1208b3dd 385 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
048eef38 386# endif
b469f1e0 387 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
70ace5da 388#else
dcda55fc
AL		 389 const char *s = CopFILE(PL_curcop);
390 STRLEN len;
550e2ce0
NC		 391 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
392 (IV) CopLINE(PL_curcop));
14a5cf38
JH		 393 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
394
b83604b4 395 s = SvPV_const(sv, len);
b469f1e0 396 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
14a5cf38 397 SvREFCNT_dec(sv);
70ace5da 398#endif
14a5cf38
JH		 399 }
400 va_end(ap);
6f9d8c32
NIS		 401}
402
9e353e3b
NIS		 403/*--------------------------------------------------------------------------------------*/
404
14a5cf38 405/*
71200d45 406 * Inner level routines
14a5cf38 407 */
9e353e3b 408
16865ff7
DM		 409/* check that the head field of each layer points back to the head */
410
411#ifdef DEBUGGING
412# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
413static void
414PerlIO_verify_head(pTHX_ PerlIO *f)
415{
416 PerlIOl *head, *p;
417 int seen = 0;
d0e4ea4d 418# ifndef PERL_IMPLICIT_SYS
dd791c72 419 PERL_UNUSED_CONTEXT;
d0e4ea4d 420# endif
16865ff7
DM		 421 if (!PerlIOValid(f))
422 return;
423 p = head = PerlIOBase(f)->head;
424 assert(p);
425 do {
426 assert(p->head == head);
427 if (p == (PerlIOl*)f)
428 seen = 1;
429 p = p->next;
430 } while (p);
431 assert(seen);
432}
433#else
434# define VERIFY_HEAD(f)
435#endif
436
437
14a5cf38 438/*
71200d45 439 * Table of pointers to the PerlIO structs (malloc'ed)
14a5cf38 440 */
05d1247b 441#define PERLIO_TABLE_SIZE 64
6f9d8c32 442
8995e67d
DM		 443static void
444PerlIO_init_table(pTHX)
445{
446 if (PL_perlio)
447 return;
448 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
449}
450
451
452
760ac839 453PerlIO *
5f1a76d0 454PerlIO_allocate(pTHX)
6f9d8c32 455{
14a5cf38 456 /*
71200d45 457 * Find a free slot in the table, allocating new table as necessary
14a5cf38 458 */
303f2dc3
DM		 459 PerlIOl **last;
460 PerlIOl *f;
a1ea730d 461 last = &PL_perlio;
14a5cf38
JH		 462 while ((f = *last)) {
463 int i;
303f2dc3 464 last = (PerlIOl **) (f);
14a5cf38 465 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 466 if (!((++f)->next)) {
4e0ef342 467 goto good_exit;
14a5cf38
JH		 468 }
469 }
470 }
303f2dc3 471 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
14a5cf38
JH		 472 if (!f) {
473 return NULL;
474 }
303f2dc3 475 *last = (PerlIOl*) f++;
4e0ef342
DD		 476
477 good_exit:
abf9167d 478 f->flags = 0; /* lockcnt */
303f2dc3 479 f->tab = NULL;
16865ff7 480 f->head = f;
303f2dc3 481 return (PerlIO*) f;
05d1247b
NIS		 482}
483
a1ea730d
NIS		 484#undef PerlIO_fdupopen
485PerlIO *
ecdeb87c 486PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
a1ea730d 487{
04892f78 488 if (PerlIOValid(f)) {
de009b76 489 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
e17bc05a 490 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
210e727c
JH		 491 if (tab && tab->Dup)
492 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
37725cdc
NIS		 493 else {
494 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
495 }
a1ea730d 496 }
210e727c
JH		 497 else
498 SETERRNO(EBADF, SS_IVCHAN);
499
500 return NULL;
a1ea730d
NIS		 501}
502
503void
303f2dc3 504PerlIO_cleantable(pTHX_ PerlIOl **tablep)
05d1247b 505{
303f2dc3 506 PerlIOl * const table = *tablep;
14a5cf38
JH		 507 if (table) {
508 int i;
303f2dc3 509 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
14a5cf38 510 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
303f2dc3
DM		 511 PerlIOl * const f = table + i;
512 if (f->next) {
513 PerlIO_close(&(f->next));
14a5cf38
JH		 514 }
515 }
3a1ee7e8 516 Safefree(table);
14a5cf38 517 *tablep = NULL;
05d1247b 518 }
05d1247b
NIS		 519}
520
fcf2db38
NIS		 521
522PerlIO_list_t *
3a1ee7e8 523PerlIO_list_alloc(pTHX)
fcf2db38 524{
14a5cf38 525 PerlIO_list_t *list;
96a5add6 526 PERL_UNUSED_CONTEXT;
a02a5408 527 Newxz(list, 1, PerlIO_list_t);
14a5cf38
JH		 528 list->refcnt = 1;
529 return list;
fcf2db38
NIS		 530}
531
532void
3a1ee7e8 533PerlIO_list_free(pTHX_ PerlIO_list_t *list)
fcf2db38 534{
14a5cf38
JH		 535 if (list) {
536 if (--list->refcnt == 0) {
537 if (list->array) {
14a5cf38 538 IV i;
ef8d46e8
VP		 539 for (i = 0; i < list->cur; i++)
540 SvREFCNT_dec(list->array[i].arg);
14a5cf38
JH		 541 Safefree(list->array);
542 }
543 Safefree(list);
544 }
545 }
fcf2db38
NIS		 546}
547
548void
3a1ee7e8 549PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
14a5cf38 550{
334e202e 551 PerlIO_pair_t *p;
b37c2d43
AL		 552 PERL_UNUSED_CONTEXT;
553
14a5cf38 554 if (list->cur >= list->len) {
00195859 555 const IV new_len = list->len + 8;
14a5cf38 556 if (list->array)
00195859 557 Renew(list->array, new_len, PerlIO_pair_t);
14a5cf38 558 else
00195859
HS		 559 Newx(list->array, new_len, PerlIO_pair_t);
560 list->len = new_len;
14a5cf38
JH		 561 }
562 p = &(list->array[list->cur++]);
563 p->funcs = funcs;
564 if ((p->arg = arg)) {
f84c484e 565 SvREFCNT_inc_simple_void_NN(arg);
14a5cf38 566 }
fcf2db38
NIS		 567}
568
3a1ee7e8
NIS		 569PerlIO_list_t *
570PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
571{
b37c2d43 572 PerlIO_list_t *list = NULL;
694c95cf
JH		 573 if (proto) {
574 int i;
575 list = PerlIO_list_alloc(aTHX);
576 for (i=0; i < proto->cur; i++) {
a951d81d 577 SV *arg = proto->array[i].arg;
24d147a6 578#ifdef USE_ITHREADS
a951d81d
BL		 579 if (arg && param)
580 arg = sv_dup(arg, param);
581#else
582 PERL_UNUSED_ARG(param);
583#endif
694c95cf
JH		 584 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
585 }
3a1ee7e8
NIS		 586 }
587 return list;
588}
4a4a6116 589
05d1247b 590void
3a1ee7e8 591PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
9a6404c5 592{
3aaf42a7 593#ifdef USE_ITHREADS
303f2dc3
DM		 594 PerlIOl **table = &proto->Iperlio;
595 PerlIOl *f;
3a1ee7e8
NIS		 596 PL_perlio = NULL;
597 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
598 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
8995e67d 599 PerlIO_init_table(aTHX);
e17bc05a 600 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
3a1ee7e8
NIS		 601 while ((f = *table)) {
602 int i;
303f2dc3 603 table = (PerlIOl **) (f++);
3a1ee7e8 604 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM		 605 if (f->next) {
606 (void) fp_dup(&(f->next), 0, param);
3a1ee7e8
NIS		 607 }
608 f++;
609 }
610 }
1b6737cc 611#else
a25429c6 612 PERL_UNUSED_CONTEXT;
1b6737cc
AL		 613 PERL_UNUSED_ARG(proto);
614 PERL_UNUSED_ARG(param);
3aaf42a7 615#endif
9a6404c5
DM		 616}
617
618void
13621cfb
NIS		 619PerlIO_destruct(pTHX)
620{
303f2dc3
DM		 621 PerlIOl **table = &PL_perlio;
622 PerlIOl *f;
694c95cf 623#ifdef USE_ITHREADS
e17bc05a 624 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
694c95cf 625#endif
14a5cf38
JH		 626 while ((f = *table)) {
627 int i;
303f2dc3 628 table = (PerlIOl **) (f++);
14a5cf38 629 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 630 PerlIO *x = &(f->next);
dcda55fc 631 const PerlIOl *l;
14a5cf38 632 while ((l = *x)) {
cc6623a8 633 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
e17bc05a 634 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
14a5cf38
JH		 635 PerlIO_flush(x);
636 PerlIO_pop(aTHX_ x);
637 }
638 else {
639 x = PerlIONext(x);
640 }
641 }
642 f++;
643 }
644 }
13621cfb
NIS		 645}
646
647void
a999f61b 648PerlIO_pop(pTHX_ PerlIO *f)
760ac839 649{
dcda55fc 650 const PerlIOl *l = *f;
16865ff7 651 VERIFY_HEAD(f);
14a5cf38 652 if (l) {
e17bc05a
TC		 653 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
654 l->tab ? l->tab->name : "(Null)") );
cc6623a8 655 if (l->tab && l->tab->Popped) {
14a5cf38
JH		 656 /*
657 * If popped returns non-zero do not free its layer structure
658 * it has either done so itself, or it is shared and still in
71200d45 659 * use
14a5cf38 660 */
f62ce20a 661 if ((*l->tab->Popped) (aTHX_ f) != 0)
14a5cf38
JH		 662 return;
663 }
abf9167d
DM		 664 if (PerlIO_lockcnt(f)) {
665 /* we're in use; defer freeing the structure */
666 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
667 PerlIOBase(f)->tab = NULL;
668 }
669 else {
670 *f = l->next;
671 Safefree(l);
672 }
673
a8c08ecd 674 }
6f9d8c32
NIS		 675}
676
39f7a870
JH		 677/* Return as an array the stack of layers on a filehandle. Note that
678 * the stack is returned top-first in the array, and there are three
679 * times as many array elements as there are layers in the stack: the
680 * first element of a layer triplet is the name, the second one is the
681 * arguments, and the third one is the flags. */
682
683AV *
684PerlIO_get_layers(pTHX_ PerlIO *f)
685{
dcda55fc 686 AV * const av = newAV();
39f7a870 687
dcda55fc
AL		 688 if (PerlIOValid(f)) {
689 PerlIOl *l = PerlIOBase(f);
690
691 while (l) {
92e45a3e
NC		 692 /* There is some collusion in the implementation of
693 XS_PerlIO_get_layers - it knows that name and flags are
694 generated as fresh SVs here, and takes advantage of that to
695 "copy" them by taking a reference. If it changes here, it needs
696 to change there too. */
dcda55fc
AL		 697 SV * const name = l->tab && l->tab->name ?
698 newSVpv(l->tab->name, 0) : &PL_sv_undef;
699 SV * const arg = l->tab && l->tab->Getarg ?
700 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
701 av_push(av, name);
702 av_push(av, arg);
703 av_push(av, newSViv((IV)l->flags));
704 l = l->next;
705 }
706 }
39f7a870 707
dcda55fc 708 return av;
39f7a870
JH		 709}
710
9e353e3b 711/*--------------------------------------------------------------------------------------*/
14a5cf38 712/*
71200d45 713 * XS Interface for perl code
14a5cf38 714 */
9e353e3b 715
fcf2db38 716PerlIO_funcs *
2edd7e44 717PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
f3862f8b 718{
20b7effb 719
14a5cf38
JH		 720 IV i;
721 if ((SSize_t) len <= 0)
722 len = strlen(name);
3a1ee7e8 723 for (i = 0; i < PL_known_layers->cur; i++) {
46c461b5 724 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
ba90859e
NC		 725 const STRLEN this_len = strlen(f->name);
726 if (this_len == len && memEQ(f->name, name, len)) {
e17bc05a 727 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
14a5cf38
JH		 728 return f;
729 }
730 }
3a1ee7e8
NIS		 731 if (load && PL_subname && PL_def_layerlist
732 && PL_def_layerlist->cur >= 2) {
d7a09b41
SR		 733 if (PL_in_load_module) {
734 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
735 return NULL;
736 } else {
396482e1 737 SV * const pkgsv = newSVpvs("PerlIO");
46c461b5 738 SV * const layer = newSVpvn(name, len);
b96d8cd9 739 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
46c461b5 740 ENTER;
4fa7c2bf 741 SAVEBOOL(PL_in_load_module);
c9bca74a 742 if (cv) {
9cfa90c0 743 SAVEGENERICSV(PL_warnhook);
ad64d0ec 744 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
c9bca74a 745 }
4fa7c2bf 746 PL_in_load_module = TRUE;
d7a09b41
SR		 747 /*
748 * The two SVs are magically freed by load_module
749 */
a0714e2c 750 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
d7a09b41
SR		 751 LEAVE;
752 return PerlIO_find_layer(aTHX_ name, len, 0);
753 }
14a5cf38 754 }
e17bc05a 755 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
14a5cf38 756 return NULL;
f3862f8b
NIS		 757}
758
2a1bc955 759#ifdef USE_ATTRIBUTES_FOR_PERLIO
b13b2135
NIS		 760
761static int
762perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
763{
14a5cf38 764 if (SvROK(sv)) {
159b6efe 765 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
dcda55fc
AL		 766 PerlIO * const ifp = IoIFP(io);
767 PerlIO * const ofp = IoOFP(io);
be2597df
MHM		 768 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
769 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
14a5cf38
JH		 770 }
771 return 0;
b13b2135
NIS		 772}
773
774static int
775perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
776{
14a5cf38 777 if (SvROK(sv)) {
159b6efe 778 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
dcda55fc
AL		 779 PerlIO * const ifp = IoIFP(io);
780 PerlIO * const ofp = IoOFP(io);
be2597df
MHM		 781 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
782 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
14a5cf38
JH		 783 }
784 return 0;
b13b2135
NIS		 785}
786
787static int
788perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
789{
be2597df 790 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
14a5cf38 791 return 0;
b13b2135
NIS		 792}
793
794static int
795perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
796{
be2597df 797 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
14a5cf38 798 return 0;
b13b2135
NIS		 799}
800
801MGVTBL perlio_vtab = {
14a5cf38
JH		 802 perlio_mg_get,
803 perlio_mg_set,
22569500 804 NULL, /* len */
14a5cf38
JH		 805 perlio_mg_clear,
806 perlio_mg_free
b13b2135
NIS		 807};
808
15eb3045 809XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
b13b2135
NIS		 810XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
811{
14a5cf38 812 dXSARGS;
dcda55fc
AL		 813 SV * const sv = SvRV(ST(1));
814 AV * const av = newAV();
14a5cf38
JH		 815 MAGIC *mg;
816 int count = 0;
817 int i;
ad64d0ec 818 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
14a5cf38
JH		 819 SvRMAGICAL_off(sv);
820 mg = mg_find(sv, PERL_MAGIC_ext);
821 mg->mg_virtual = &perlio_vtab;
822 mg_magical(sv);
be2597df 823 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
14a5cf38
JH		 824 for (i = 2; i < items; i++) {
825 STRLEN len;
dcda55fc
AL		 826 const char * const name = SvPV_const(ST(i), len);
827 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
14a5cf38 828 if (layer) {
b37c2d43 829 av_push(av, SvREFCNT_inc_simple_NN(layer));
14a5cf38
JH		 830 }
831 else {
832 ST(count) = ST(i);
833 count++;
834 }
835 }
836 SvREFCNT_dec(av);
837 XSRETURN(count);
838}
839
b8fda935 840#endif /* USE_ATTRIBUTES_FOR_PERLIO */
2a1bc955 841
e3f3bf95
NIS		 842SV *
843PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
f3862f8b 844{
da51bb9b 845 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
46c461b5 846 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
14a5cf38 847 return sv;
e3f3bf95
NIS		 848}
849
15eb3045 850XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
5ca1d77f 851XS(XS_PerlIO__Layer__NoWarnings)
c9bca74a 852{
486ec47a 853 /* This is used as a %SIG{__WARN__} handler to suppress warnings
c9bca74a
NIS		 854 during loading of layers.
855 */
856 dXSARGS;
5347602a 857 PERL_UNUSED_VAR(items);
e17bc05a
TC		 858 DEBUG_i(
859 if (items)
860 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
c9bca74a
NIS		 861 XSRETURN(0);
862}
863
15eb3045 864XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
5ca1d77f 865XS(XS_PerlIO__Layer__find)
0c4f7ff0 866{
14a5cf38
JH		 867 dXSARGS;
868 if (items < 2)
869 Perl_croak(aTHX_ "Usage class->find(name[,load])");
870 else {
de009b76 871 STRLEN len;
46c461b5 872 const char * const name = SvPV_const(ST(1), len);
f814d560 873 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
46c461b5 874 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
14a5cf38
JH		 875 ST(0) =
876 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
877 &PL_sv_undef;
878 XSRETURN(1);
879 }
0c4f7ff0
NIS		 880}
881
e3f3bf95
NIS		 882void
883PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
884{
3a1ee7e8
NIS		 885 if (!PL_known_layers)
886 PL_known_layers = PerlIO_list_alloc(aTHX);
a0714e2c 887 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
e17bc05a 888 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
f3862f8b
NIS		 889}
890
1141d9f8 891int
fcf2db38 892PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1141d9f8 893{
14a5cf38
JH		 894 if (names) {
895 const char *s = names;
896 while (*s) {
897 while (isSPACE(*s) || *s == ':')
898 s++;
899 if (*s) {
900 STRLEN llen = 0;
901 const char *e = s;
bd61b366 902 const char *as = NULL;
14a5cf38
JH		 903 STRLEN alen = 0;
904 if (!isIDFIRST(*s)) {
905 /*
906 * Message is consistent with how attribute lists are
907 * passed. Even though this means "foo : : bar" is
71200d45 908 * seen as an invalid separator character.
14a5cf38 909 */
de009b76 910 const char q = ((*s == '\'') ? '"' : '\'');
a2a5de95
NC		 911 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
912 "Invalid separator character %c%c%c in PerlIO layer specification %s",
913 q, *s, q, s);
93189314 914 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 915 return -1;
916 }
917 do {
918 e++;
0eb30aeb 919 } while (isWORDCHAR(*e));
14a5cf38
JH		 920 llen = e - s;
921 if (*e == '(') {
922 int nesting = 1;
923 as = ++e;
924 while (nesting) {
925 switch (*e++) {
926 case ')':
927 if (--nesting == 0)
928 alen = (e - 1) - as;
929 break;
930 case '(':
931 ++nesting;
932 break;
933 case '\\':
934 /*
935 * It's a nul terminated string, not allowed
936 * to \ the terminating null. Anything other
71200d45 937 * character is passed over.
14a5cf38
JH		 938 */
939 if (*e++) {
940 break;
941 }
2165bd23 942 /* Fall through */
14a5cf38
JH		 943 case '\0':
944 e--;
a2a5de95
NC		 945 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
946 "Argument list not closed for PerlIO layer \"%.*s\"",
947 (int) (e - s), s);
14a5cf38
JH		 948 return -1;
949 default:
950 /*
71200d45 951 * boring.
14a5cf38
JH		 952 */
953 break;
954 }
955 }
956 }
957 if (e > s) {
46c461b5 958 PerlIO_funcs * const layer =
14a5cf38
JH		 959 PerlIO_find_layer(aTHX_ s, llen, 1);
960 if (layer) {
a951d81d
BL		 961 SV *arg = NULL;
962 if (as)
963 arg = newSVpvn(as, alen);
3a1ee7e8 964 PerlIO_list_push(aTHX_ av, layer,
a951d81d 965 (arg) ? arg : &PL_sv_undef);
ef8d46e8 966 SvREFCNT_dec(arg);
14a5cf38
JH		 967 }
968 else {
a2a5de95
NC		 969 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
970 (int) llen, s);
14a5cf38
JH		 971 return -1;
972 }
973 }
974 s = e;
975 }
976 }
977 }
978 return 0;
1141d9f8
NIS		 979}
980
dfebf958 981void
fcf2db38 982PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
dfebf958 983{
27da23d5 984 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
35990314 985#ifdef PERLIO_USING_CRLF
6ce75a77 986 tab = &PerlIO_crlf;
846be114 987#else
6ce75a77 988 if (PerlIO_stdio.Set_ptrcnt)
22569500 989 tab = &PerlIO_stdio;
846be114 990#endif
e17bc05a 991 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
0987d6f3 992 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
dfebf958
NIS		 993}
994
e3f3bf95 995SV *
14a5cf38 996PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
e3f3bf95 997{
14a5cf38 998 return av->array[n].arg;
e3f3bf95
NIS		 999}
1000
f3862f8b 1001PerlIO_funcs *
14a5cf38 1002PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
f3862f8b 1003{
14a5cf38 1004 if (n >= 0 && n < av->cur) {
e17bc05a
TC		 1005 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1006 av->array[n].funcs->name) );
14a5cf38
JH		 1007 return av->array[n].funcs;
1008 }
1009 if (!def)
1010 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1011 return def;
e3f3bf95
NIS		 1012}
1013
4ec2216f
NIS		 1014IV
1015PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1016{
8772537c
AL		 1017 PERL_UNUSED_ARG(mode);
1018 PERL_UNUSED_ARG(arg);
1019 PERL_UNUSED_ARG(tab);
4ec2216f
NIS		 1020 if (PerlIOValid(f)) {
1021 PerlIO_flush(f);
1022 PerlIO_pop(aTHX_ f);
1023 return 0;
1024 }
1025 return -1;
1026}
1027
27da23d5 1028PERLIO_FUNCS_DECL(PerlIO_remove) = {
4ec2216f
NIS		 1029 sizeof(PerlIO_funcs),
1030 "pop",
1031 0,
1032 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1033 PerlIOPop_pushed,
1034 NULL,
c0888ace 1035 PerlIOBase_open,
4ec2216f
NIS		 1036 NULL,
1037 NULL,
1038 NULL,
1039 NULL,
1040 NULL,
1041 NULL,
1042 NULL,
1043 NULL,
de009b76
AL		 1044 NULL,
1045 NULL,
4ec2216f
NIS		 1046 NULL, /* flush */
1047 NULL, /* fill */
1048 NULL,
1049 NULL,
1050 NULL,
1051 NULL,
1052 NULL, /* get_base */
1053 NULL, /* get_bufsiz */
1054 NULL, /* get_ptr */
1055 NULL, /* get_cnt */
1056 NULL, /* set_ptrcnt */
1057};
1058
fcf2db38 1059PerlIO_list_t *
e3f3bf95
NIS		 1060PerlIO_default_layers(pTHX)
1061{
3a1ee7e8 1062 if (!PL_def_layerlist) {
284167a5 1063 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
27da23d5 1064 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
3a1ee7e8 1065 PL_def_layerlist = PerlIO_list_alloc(aTHX);
27da23d5 1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
979e2c82 1067#if defined(WIN32)
27da23d5 1068 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
d0e4ea4d 1069# if 0
14a5cf38 1070 osLayer = &PerlIO_win32;
d0e4ea4d 1071# endif
2f8118af 1072#endif
27da23d5
JH		 1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
27da23d5
JH		 1077 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1078 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1079 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
0987d6f3
TC		 1080 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1081 &PL_sv_undef);
14a5cf38 1082 if (s) {
3a1ee7e8 1083 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
14a5cf38
JH		 1084 }
1085 else {
3a1ee7e8 1086 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
14a5cf38 1087 }
1141d9f8 1088 }
3a1ee7e8
NIS		 1089 if (PL_def_layerlist->cur < 2) {
1090 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
f3862f8b 1091 }
3a1ee7e8 1092 return PL_def_layerlist;
e3f3bf95
NIS		 1093}
1094
0c4f7ff0
NIS		 1095void
1096Perl_boot_core_PerlIO(pTHX)
1097{
1098#ifdef USE_ATTRIBUTES_FOR_PERLIO
14a5cf38
JH		 1099 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1100 __FILE__);
0c4f7ff0 1101#endif
14a5cf38 1102 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
c9bca74a 1103 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
0c4f7ff0 1104}
e3f3bf95
NIS		 1105
1106PerlIO_funcs *
1107PerlIO_default_layer(pTHX_ I32 n)
1108{
46c461b5 1109 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
14a5cf38
JH		 1110 if (n < 0)
1111 n += av->cur;
27da23d5 1112 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
f3862f8b
NIS		 1113}
1114
a999f61b
NIS		 1115#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1116#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
60382766
NIS		 1117
1118void
1141d9f8 1119PerlIO_stdstreams(pTHX)
60382766 1120{
a1ea730d 1121 if (!PL_perlio) {
8995e67d 1122 PerlIO_init_table(aTHX);
14a5cf38
JH		 1123 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1124 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1125 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1126 }
60382766
NIS		 1127}
1128
1129PerlIO *
27da23d5 1130PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
14a5cf38 1131{
16865ff7 1132 VERIFY_HEAD(f);
2dc2558e 1133 if (tab->fsize != sizeof(PerlIO_funcs)) {
0dc17498 1134 Perl_croak( aTHX_
147e3846 1135 "%s (%" UVuf ") does not match %s (%" UVuf ")",
5cf96513
RB		 1136 "PerlIO layer function table size", (UV)tab->fsize,
1137 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
2dc2558e
NIS		 1138 }
1139 if (tab->size) {
b464bac0 1140 PerlIOl *l;
2dc2558e 1141 if (tab->size < sizeof(PerlIOl)) {
0dc17498 1142 Perl_croak( aTHX_
147e3846 1143 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
5cf96513
RB		 1144 "PerlIO layer instance size", (UV)tab->size,
1145 "size expected by this perl", (UV)sizeof(PerlIOl) );
2dc2558e
NIS		 1146 }
1147 /* Real layer with a data area */
002e75cf
JH		 1148 if (f) {
1149 char *temp;
1150 Newxz(temp, tab->size, char);
1151 l = (PerlIOl*)temp;
1152 if (l) {
1153 l->next = *f;
1154 l->tab = (PerlIO_funcs*) tab;
16865ff7 1155 l->head = ((PerlIOl*)f)->head;
002e75cf 1156 *f = l;
e17bc05a
TC		 1157 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1158 (void*)f, tab->name,
1159 (mode) ? mode : "(Null)", (void*)arg) );
002e75cf
JH		 1160 if (*l->tab->Pushed &&
1161 (*l->tab->Pushed)
1162 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1163 PerlIO_pop(aTHX_ f);
1164 return NULL;
1165 }
2dc2558e 1166 }
002e75cf
JH		 1167 else
1168 return NULL;
2dc2558e
NIS		 1169 }
1170 }
1171 else if (f) {
1172 /* Pseudo-layer where push does its own stack adjust */
e17bc05a
TC		 1173 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1174 (mode) ? mode : "(Null)", (void*)arg) );
210e727c 1175 if (tab->Pushed &&
27da23d5 1176 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
210e727c 1177 return NULL;
14a5cf38
JH		 1178 }
1179 }
1180 return f;
60382766
NIS		 1181}
1182
81fe74fb
LT		 1183PerlIO *
1184PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1185 IV n, const char *mode, int fd, int imode, int perm,
1186 PerlIO *old, int narg, SV **args)
1187{
1188 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1189 if (tab && tab->Open) {
1190 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
6d5bdea2 1191 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
81fe74fb
LT		 1192 PerlIO_close(ret);
1193 return NULL;
1194 }
1195 return ret;
1196 }
1197 SETERRNO(EINVAL, LIB_INVARG);
1198 return NULL;
1199}
1200
dfebf958 1201IV
86e05cf2
NIS		 1202PerlIOBase_binmode(pTHX_ PerlIO *f)
1203{
1204 if (PerlIOValid(f)) {
1205 /* Is layer suitable for raw stream ? */
cc6623a8 1206 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
86e05cf2
NIS		 1207 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1208 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1209 }
1210 else {
1211 /* Not suitable - pop it */
1212 PerlIO_pop(aTHX_ f);
1213 }
1214 return 0;
1215 }
1216 return -1;
1217}
1218
1219IV
2dc2558e 1220PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
dfebf958 1221{
8772537c
AL		 1222 PERL_UNUSED_ARG(mode);
1223 PERL_UNUSED_ARG(arg);
1224 PERL_UNUSED_ARG(tab);
86e05cf2 1225
04892f78 1226 if (PerlIOValid(f)) {
86e05cf2 1227 PerlIO *t;
de009b76 1228 const PerlIOl *l;
14a5cf38 1229 PerlIO_flush(f);
86e05cf2
NIS		 1230 /*
1231 * Strip all layers that are not suitable for a raw stream
1232 */
1233 t = f;
1234 while (t && (l = *t)) {
cc6623a8 1235 if (l->tab && l->tab->Binmode) {
86e05cf2 1236 /* Has a handler - normal case */
9d97e8b8 1237 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
86e05cf2
NIS		 1238 if (*t == l) {
1239 /* Layer still there - move down a layer */
1240 t = PerlIONext(t);
1241 }
1242 }
1243 else {
1244 return -1;
1245 }
14a5cf38
JH		 1246 }
1247 else {
86e05cf2
NIS		 1248 /* No handler - pop it */
1249 PerlIO_pop(aTHX_ t);
14a5cf38
JH		 1250 }
1251 }
86e05cf2 1252 if (PerlIOValid(f)) {
e17bc05a
TC		 1253 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1254 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
86e05cf2
NIS		 1255 return 0;
1256 }
14a5cf38
JH		 1257 }
1258 return -1;
dfebf958
NIS		 1259}
1260
ac27b0f5 1261int
14a5cf38 1262PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
d9dac8cd 1263 PerlIO_list_t *layers, IV n, IV max)
14a5cf38 1264{
14a5cf38
JH		 1265 int code = 0;
1266 while (n < max) {
8772537c 1267 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
14a5cf38
JH		 1268 if (tab) {
1269 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1270 code = -1;
1271 break;
1272 }
1273 }
1274 n++;
1275 }
1276 return code;
e3f3bf95
NIS		 1277}
1278
1279int
ac27b0f5
NIS		 1280PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1281{
14a5cf38 1282 int code = 0;
da0fccaa
DG		 1283 ENTER;
1284 save_scalar(PL_errgv);
53f1b6d2 1285 if (f && names) {
8772537c 1286 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
14a5cf38
JH		 1287 code = PerlIO_parse_layers(aTHX_ layers, names);
1288 if (code == 0) {
d9dac8cd 1289 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
14a5cf38 1290 }
3a1ee7e8 1291 PerlIO_list_free(aTHX_ layers);
ac27b0f5 1292 }
da0fccaa 1293 LEAVE;
14a5cf38 1294 return code;
ac27b0f5
NIS		 1295}
1296
f3862f8b 1297
60382766 1298/*--------------------------------------------------------------------------------------*/
14a5cf38 1299/*
71200d45 1300 * Given the abstraction above the public API functions
14a5cf38 1301 */
60382766
NIS		 1302
1303int
f5b9d040 1304PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 1305{
5347602a
DM		 1306 PERL_UNUSED_ARG(iotype);
1307 PERL_UNUSED_ARG(mode);
1308
e17bc05a
TC		 1309 DEBUG_i(
1310 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1311 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1312 PerlIOBase(f)->tab->name : "(Null)",
1313 iotype, mode, (names) ? names : "(Null)") );
68b5363f 1314
03c0554d
NIS		 1315 if (names) {
1316 /* Do not flush etc. if (e.g.) switching encodings.
1317 if a pushed layer knows it needs to flush lower layers
1318 (for example :unix which is never going to call them)
1319 it can do the flush when it is pushed.
1320 */
8298454c 1321 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
03c0554d
NIS		 1322 }
1323 else {
86e05cf2 1324 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
35990314 1325#ifdef PERLIO_USING_CRLF
03c0554d
NIS		 1326 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1327 O_BINARY so we can look for it in mode.
1328 */
1329 if (!(mode & O_BINARY)) {
1330 /* Text mode */
86e05cf2
NIS		 1331 /* FIXME?: Looking down the layer stack seems wrong,
1332 but is a way of reaching past (say) an encoding layer
1333 to flip CRLF-ness of the layer(s) below
1334 */
03c0554d
NIS		 1335 while (*f) {
1336 /* Perhaps we should turn on bottom-most aware layer
1337 e.g. Ilya's idea that UNIX TTY could serve
1338 */
cc6623a8
DM		 1339 if (PerlIOBase(f)->tab &&
1340 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1341 {
03c0554d
NIS		 1342 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1343 /* Not in text mode - flush any pending stuff and flip it */
1344 PerlIO_flush(f);
1345 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1346 }
1347 /* Only need to turn it on in one layer so we are done */
1348 return TRUE;
ed53a2bb 1349 }
03c0554d 1350 f = PerlIONext(f);
14a5cf38 1351 }
03c0554d
NIS		 1352 /* Not finding a CRLF aware layer presumably means we are binary
1353 which is not what was requested - so we failed
1354 We _could_ push :crlf layer but so could caller
1355 */
1356 return FALSE;
14a5cf38 1357 }
6ce75a77 1358#endif
86e05cf2
NIS		 1359 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1360 So code that used to be here is now in PerlIORaw_pushed().
03c0554d 1361 */
8298454c 1362 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
14a5cf38 1363 }
f5b9d040
NIS		 1364}
1365
f5b9d040 1366int
e87a358a 1367PerlIO__close(pTHX_ PerlIO *f)
f5b9d040 1368{
37725cdc 1369 if (PerlIOValid(f)) {
46c461b5 1370 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
37725cdc
NIS		 1371 if (tab && tab->Close)
1372 return (*tab->Close)(aTHX_ f);
1373 else
1374 return PerlIOBase_close(aTHX_ f);
1375 }
14a5cf38 1376 else {
93189314 1377 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH		 1378 return -1;
1379 }
76ced9ad
NIS		 1380}
1381
b931b1d9 1382int
e87a358a 1383Perl_PerlIO_close(pTHX_ PerlIO *f)
b931b1d9 1384{
de009b76 1385 const int code = PerlIO__close(aTHX_ f);
37725cdc
NIS		 1386 while (PerlIOValid(f)) {
1387 PerlIO_pop(aTHX_ f);
abf9167d
DM		 1388 if (PerlIO_lockcnt(f))
1389 /* we're in use; the 'pop' deferred freeing the structure */
1390 f = PerlIONext(f);
f6c77cf1 1391 }
14a5cf38 1392 return code;
b931b1d9
NIS		 1393}
1394
b931b1d9 1395int
e87a358a 1396Perl_PerlIO_fileno(pTHX_ PerlIO *f)
b931b1d9 1397{
20b7effb 1398 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
b931b1d9
NIS		 1399}
1400
1141d9f8 1401
fcf2db38 1402static PerlIO_funcs *
2edd7e44
NIS		 1403PerlIO_layer_from_ref(pTHX_ SV *sv)
1404{
14a5cf38 1405 /*
71200d45 1406 * For any scalar type load the handler which is bundled with perl
14a5cf38 1407 */
526fd1b4 1408 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
75208dda
RGS		 1409 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1410 /* This isn't supposed to happen, since PerlIO::scalar is core,
1411 * but could happen anyway in smaller installs or with PAR */
a2a5de95 1412 if (!f)
dcbac5bb 1413 /* diag_listed_as: Unknown PerlIO layer "%s" */
a2a5de95 1414 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
75208dda
RGS		 1415 return f;
1416 }
14a5cf38
JH		 1417
1418 /*
71200d45 1419 * For other types allow if layer is known but don't try and load it
14a5cf38
JH		 1420 */
1421 switch (SvTYPE(sv)) {
1422 case SVt_PVAV:
6a245ed1 1423 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
14a5cf38 1424 case SVt_PVHV:
6a245ed1 1425 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
14a5cf38 1426 case SVt_PVCV:
6a245ed1 1427 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
14a5cf38 1428 case SVt_PVGV:
6a245ed1 1429 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
42d0e0b7
AL		 1430 default:
1431 return NULL;
14a5cf38 1432 }
2edd7e44
NIS		 1433}
1434
fcf2db38 1435PerlIO_list_t *
14a5cf38
JH		 1436PerlIO_resolve_layers(pTHX_ const char *layers,
1437 const char *mode, int narg, SV **args)
1438{
1439 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1440 int incdef = 1;
a1ea730d 1441 if (!PL_perlio)
14a5cf38
JH		 1442 PerlIO_stdstreams(aTHX);
1443 if (narg) {
dcda55fc 1444 SV * const arg = *args;
14a5cf38 1445 /*
71200d45
NIS		 1446 * If it is a reference but not an object see if we have a handler
1447 * for it
14a5cf38 1448 */
4e0ef342 1449 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
46c461b5 1450 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1451 if (handler) {
3a1ee7e8
NIS		 1452 def = PerlIO_list_alloc(aTHX);
1453 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH		 1454 incdef = 0;
1455 }
1456 /*
e934609f 1457 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1458 * something sensible else we will just stringfy and open
71200d45 1459 * resulting string.
14a5cf38
JH		 1460 */
1461 }
1462 }
9fe371da 1463 if (!layers || !*layers)
11bcd5da 1464 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH		 1465 if (layers && *layers) {
1466 PerlIO_list_t *av;
1467 if (incdef) {
a951d81d 1468 av = PerlIO_clone_list(aTHX_ def, NULL);
14a5cf38
JH		 1469 }
1470 else {
1471 av = def;
1472 }
0cff2cf3
NIS		 1473 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1474 return av;
1475 }
1476 else {
1477 PerlIO_list_free(aTHX_ av);
b37c2d43 1478 return NULL;
0cff2cf3 1479 }
14a5cf38
JH		 1480 }
1481 else {
1482 if (incdef)
1483 def->refcnt++;
1484 return def;
1485 }
ee518936
NIS		 1486}
1487
1488PerlIO *
14a5cf38
JH		 1489PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1490 int imode, int perm, PerlIO *f, int narg, SV **args)
1491{
1492 if (!f && narg == 1 && *args == &PL_sv_undef) {
16bac4a4 1493 imode = PerlIOUnix_oflags(mode);
ae73d7ec
TC		 1494
1495 if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
9fe371da 1496 if (!layers || !*layers)
11bcd5da 1497 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH		 1498 if (layers && *layers)
1499 PerlIO_apply_layers(aTHX_ f, mode, layers);
1500 }
1501 }
1502 else {
de009b76 1503 PerlIO_list_t *layera;
14a5cf38
JH		 1504 IV n;
1505 PerlIO_funcs *tab = NULL;
04892f78 1506 if (PerlIOValid(f)) {
14a5cf38 1507 /*
71200d45
NIS		 1508 * This is "reopen" - it is not tested as perl does not use it
1509 * yet
14a5cf38
JH		 1510 */
1511 PerlIOl *l = *f;
3a1ee7e8 1512 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1513 while (l) {
a951d81d 1514 SV *arg = NULL;
cc6623a8 1515 if (l->tab && l->tab->Getarg)
a951d81d
BL		 1516 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1517 PerlIO_list_push(aTHX_ layera, l->tab,
1518 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1519 SvREFCNT_dec(arg);
14a5cf38
JH		 1520 l = *PerlIONext(&l);
1521 }
1522 }
1523 else {
1524 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS		 1525 if (!layera) {
1526 return NULL;
1527 }
14a5cf38
JH		 1528 }
1529 /*
71200d45 1530 * Start at "top" of layer stack
14a5cf38
JH		 1531 */
1532 n = layera->cur - 1;
1533 while (n >= 0) {
46c461b5 1534 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH		 1535 if (t && t->Open) {
1536 tab = t;
1537 break;
1538 }
1539 n--;
1540 }
1541 if (tab) {
1542 /*
71200d45 1543 * Found that layer 'n' can do opens - call it
14a5cf38 1544 */
7cf31beb 1545 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1546 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1547 }
e17bc05a
TC		 1548 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1549 tab->name, layers ? layers : "(Null)", mode, fd,
1550 imode, perm, (void*)f, narg, (void*)args) );
210e727c
JH		 1551 if (tab->Open)
1552 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1553 f, narg, args);
1554 else {
1555 SETERRNO(EINVAL, LIB_INVARG);
1556 f = NULL;
1557 }
14a5cf38
JH		 1558 if (f) {
1559 if (n + 1 < layera->cur) {
1560 /*
1561 * More layers above the one that we used to open -
71200d45 1562 * apply them now
14a5cf38 1563 */
d9dac8cd
NIS		 1564 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1565 /* If pushing layers fails close the file */
1566 PerlIO_close(f);
14a5cf38
JH		 1567 f = NULL;
1568 }
1569 }
1570 }
1571 }
3a1ee7e8 1572 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH		 1573 }
1574 return f;
ee518936 1575}
b931b1d9
NIS		 1576
1577
9e353e3b 1578SSize_t
e87a358a 1579Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1580{
7918f24d
NC		 1581 PERL_ARGS_ASSERT_PERLIO_READ;
1582
b32dd47e 1583 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1584}
1585
313ca112 1586SSize_t
e87a358a 1587Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1588{
7918f24d
NC		 1589 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1590
b32dd47e 1591 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1592}
1593
9e353e3b 1594SSize_t
e87a358a 1595Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1596{
7918f24d
NC		 1597 PERL_ARGS_ASSERT_PERLIO_WRITE;
1598
b32dd47e 1599 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1600}
1601
6f9d8c32 1602int
e87a358a 1603Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1604{
b32dd47e 1605 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW		 1606}
1607
9e353e3b 1608Off_t
e87a358a 1609Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1610{
b32dd47e 1611 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW		 1612}
1613
6f9d8c32 1614int
e87a358a 1615Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1616{
14a5cf38
JH		 1617 if (f) {
1618 if (*f) {
de009b76 1619 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1620
1621 if (tab && tab->Flush)
f62ce20a 1622 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH		 1623 else
1624 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH		 1625 }
1626 else {
e17bc05a 1627 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
93189314 1628 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH		 1629 return -1;
1630 }
1631 }
1632 else {
1633 /*
1634 * Is it good API design to do flush-all on NULL, a potentially
486ec47a 1635 * erroneous input? Maybe some magical value (PerlIO*
14a5cf38
JH		 1636 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1637 * things on fflush(NULL), but should we be bound by their design
71200d45 1638 * decisions? --jhi
14a5cf38 1639 */
303f2dc3
DM		 1640 PerlIOl **table = &PL_perlio;
1641 PerlIOl *ff;
14a5cf38 1642 int code = 0;
303f2dc3 1643 while ((ff = *table)) {
14a5cf38 1644 int i;
303f2dc3 1645 table = (PerlIOl **) (ff++);
14a5cf38 1646 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 1647 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
14a5cf38 1648 code = -1;
303f2dc3 1649 ff++;
14a5cf38
JH		 1650 }
1651 }
1652 return code;
1653 }
760ac839
LW		 1654}
1655
a9c883f6 1656void
f62ce20a 1657PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1658{
303f2dc3
DM		 1659 PerlIOl **table = &PL_perlio;
1660 PerlIOl *f;
14a5cf38
JH		 1661 while ((f = *table)) {
1662 int i;
303f2dc3 1663 table = (PerlIOl **) (f++);
14a5cf38 1664 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM		 1665 if (f->next
1666 && (PerlIOBase(&(f->next))->
14a5cf38
JH		 1667 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1668 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
303f2dc3 1669 PerlIO_flush(&(f->next));
14a5cf38
JH		 1670 f++;
1671 }
a9c883f6 1672 }
a9c883f6
NIS		 1673}
1674
06da4f11 1675int
e87a358a 1676Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1677{
b32dd47e 1678 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS		 1679}
1680
f3862f8b
NIS		 1681int
1682PerlIO_isutf8(PerlIO *f)
1683{
1b7a0411
JH		 1684 if (PerlIOValid(f))
1685 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1686 else
1687 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1688
1b7a0411 1689 return -1;
f3862f8b
NIS		 1690}
1691
6f9d8c32 1692int
e87a358a 1693Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1694{
b32dd47e 1695 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS		 1696}
1697
9e353e3b 1698int
e87a358a 1699Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1700{
b32dd47e 1701 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS		 1702}
1703
9e353e3b 1704void
e87a358a 1705Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1706{
b32dd47e 1707 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS		 1708}
1709
9e353e3b 1710void
e87a358a 1711Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1712{
b32dd47e 1713 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS		 1714}
1715
9e353e3b
NIS		 1716int
1717PerlIO_has_base(PerlIO *f)
1718{
1b7a0411 1719 if (PerlIOValid(f)) {
46c461b5 1720 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1721
1722 if (tab)
1723 return (tab->Get_base != NULL);
1b7a0411 1724 }
1b7a0411
JH		 1725
1726 return 0;
760ac839
LW		 1727}
1728
9e353e3b
NIS		 1729int
1730PerlIO_fast_gets(PerlIO *f)
760ac839 1731{
d7dfc388
SK		 1732 if (PerlIOValid(f)) {
1733 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1734 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411 1735
d7dfc388
SK		 1736 if (tab)
1737 return (tab->Set_ptrcnt != NULL);
d7dfc388 1738 }
14a5cf38 1739 }
1b7a0411 1740
14a5cf38 1741 return 0;
9e353e3b
NIS		 1742}
1743
9e353e3b
NIS		 1744int
1745PerlIO_has_cntptr(PerlIO *f)
1746{
04892f78 1747 if (PerlIOValid(f)) {
46c461b5 1748 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1749
1750 if (tab)
1751 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
14a5cf38 1752 }
1b7a0411 1753
14a5cf38 1754 return 0;
9e353e3b
NIS		 1755}
1756
9e353e3b
NIS		 1757int
1758PerlIO_canset_cnt(PerlIO *f)
1759{
04892f78 1760 if (PerlIOValid(f)) {
46c461b5 1761 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1762
1763 if (tab)
1764 return (tab->Set_ptrcnt != NULL);
14a5cf38 1765 }
1b7a0411 1766
14a5cf38 1767 return 0;
760ac839
LW		 1768}
1769
888911fc 1770STDCHAR *
e87a358a 1771Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1772{
b32dd47e 1773 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS		 1774}
1775
b66f3475 1776SSize_t
e87a358a 1777Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1778{
b66f3475 1779 /* Note that Get_bufsiz returns a Size_t */
b32dd47e 1780 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS		 1781}
1782
9e353e3b 1783STDCHAR *
e87a358a 1784Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1785{
b32dd47e 1786 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS		 1787}
1788
b66f3475 1789SSize_t
e87a358a 1790Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1791{
b32dd47e 1792 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS		 1793}
1794
9e353e3b 1795void
b66f3475 1796Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
9e353e3b 1797{
b32dd47e 1798 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS		 1799}
1800
9e353e3b 1801void
b66f3475 1802Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 1803{
b32dd47e 1804 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS		 1805}
1806
4ec2216f 1807
9e353e3b 1808/*--------------------------------------------------------------------------------------*/
14a5cf38 1809/*
71200d45 1810 * utf8 and raw dummy layers
14a5cf38 1811 */
dfebf958 1812
26fb694e 1813IV
2dc2558e 1814PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1815{
96a5add6 1816 PERL_UNUSED_CONTEXT;
8772537c
AL		 1817 PERL_UNUSED_ARG(mode);
1818 PERL_UNUSED_ARG(arg);
00f51856 1819 if (PerlIOValid(f)) {
cc6623a8 1820 if (tab && tab->kind & PERLIO_K_UTF8)
14a5cf38
JH		 1821 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1822 else
1823 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1824 return 0;
1825 }
1826 return -1;
26fb694e
NIS		 1827}
1828
27da23d5 1829PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1830 sizeof(PerlIO_funcs),
14a5cf38 1831 "utf8",
2dc2558e 1832 0,
a778d1f5 1833 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
14a5cf38
JH		 1834 PerlIOUtf8_pushed,
1835 NULL,
c0888ace 1836 PerlIOBase_open,
14a5cf38
JH		 1837 NULL,
1838 NULL,
1839 NULL,
1840 NULL,
1841 NULL,
1842 NULL,
1843 NULL,
1844 NULL,
de009b76
AL		 1845 NULL,
1846 NULL,
22569500
NIS		 1847 NULL, /* flush */
1848 NULL, /* fill */
14a5cf38
JH		 1849 NULL,
1850 NULL,
1851 NULL,
1852 NULL,
22569500
NIS		 1853 NULL, /* get_base */
1854 NULL, /* get_bufsiz */
1855 NULL, /* get_ptr */
1856 NULL, /* get_cnt */
1857 NULL, /* set_ptrcnt */
26fb694e
NIS		 1858};
1859
27da23d5 1860PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1861 sizeof(PerlIO_funcs),
14a5cf38 1862 "bytes",
2dc2558e 1863 0,
a778d1f5 1864 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
14a5cf38
JH		 1865 PerlIOUtf8_pushed,
1866 NULL,
c0888ace 1867 PerlIOBase_open,
14a5cf38
JH		 1868 NULL,
1869 NULL,
1870 NULL,
1871 NULL,
1872 NULL,
1873 NULL,
1874 NULL,
1875 NULL,
de009b76
AL		 1876 NULL,
1877 NULL,
22569500
NIS		 1878 NULL, /* flush */
1879 NULL, /* fill */
14a5cf38
JH		 1880 NULL,
1881 NULL,
1882 NULL,
1883 NULL,
22569500
NIS		 1884 NULL, /* get_base */
1885 NULL, /* get_bufsiz */
1886 NULL, /* get_ptr */
1887 NULL, /* get_cnt */
1888 NULL, /* set_ptrcnt */
dfebf958
NIS		 1889};
1890
27da23d5 1891PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 1892 sizeof(PerlIO_funcs),
14a5cf38 1893 "raw",
2dc2558e 1894 0,
14a5cf38
JH		 1895 PERLIO_K_DUMMY,
1896 PerlIORaw_pushed,
1897 PerlIOBase_popped,
ecfd0649 1898 PerlIOBase_open,
14a5cf38
JH		 1899 NULL,
1900 NULL,
1901 NULL,
1902 NULL,
1903 NULL,
1904 NULL,
1905 NULL,
1906 NULL,
de009b76
AL		 1907 NULL,
1908 NULL,
22569500
NIS		 1909 NULL, /* flush */
1910 NULL, /* fill */
14a5cf38
JH		 1911 NULL,
1912 NULL,
1913 NULL,
1914 NULL,
22569500
NIS		 1915 NULL, /* get_base */
1916 NULL, /* get_bufsiz */
1917 NULL, /* get_ptr */
1918 NULL, /* get_cnt */
1919 NULL, /* set_ptrcnt */
dfebf958
NIS		 1920};
1921/*--------------------------------------------------------------------------------------*/
1922/*--------------------------------------------------------------------------------------*/
14a5cf38 1923/*
71200d45 1924 * "Methods" of the "base class"
14a5cf38 1925 */
9e353e3b
NIS		 1926
1927IV
f62ce20a 1928PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 1929{
04892f78 1930 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS		 1931}
1932
f5b9d040 1933char *
81428673 1934PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH		 1935{
1936 char *s = buf;
81428673 1937 if (PerlIOValid(f)) {
de009b76 1938 const IV flags = PerlIOBase(f)->flags;
81428673
NIS		 1939 if (flags & PERLIO_F_APPEND) {
1940 *s++ = 'a';
1941 if (flags & PERLIO_F_CANREAD) {
1942 *s++ = '+';
1943 }
14a5cf38 1944 }
81428673
NIS		 1945 else if (flags & PERLIO_F_CANREAD) {
1946 *s++ = 'r';
1947 if (flags & PERLIO_F_CANWRITE)
1948 *s++ = '+';
1949 }
1950 else if (flags & PERLIO_F_CANWRITE) {
1951 *s++ = 'w';
1952 if (flags & PERLIO_F_CANREAD) {
1953 *s++ = '+';
1954 }
14a5cf38 1955 }
35990314 1956#ifdef PERLIO_USING_CRLF
81428673
NIS		 1957 if (!(flags & PERLIO_F_CRLF))
1958 *s++ = 'b';
5f1a76d0 1959#endif
81428673 1960 }
14a5cf38
JH		 1961 *s = '\0';
1962 return buf;
f5b9d040
NIS		 1963}
1964
81428673 1965
76ced9ad 1966IV
2dc2558e 1967PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 1968{
de009b76 1969 PerlIOl * const l = PerlIOBase(f);
96a5add6 1970 PERL_UNUSED_CONTEXT;
8772537c 1971 PERL_UNUSED_ARG(arg);
de009b76 1972
14a5cf38
JH		 1973 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1974 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
cc6623a8 1975 if (tab && tab->Set_ptrcnt != NULL)
14a5cf38
JH		 1976 l->flags |= PERLIO_F_FASTGETS;
1977 if (mode) {
3b6c1aba 1978 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH		 1979 mode++;
1980 switch (*mode++) {
1981 case 'r':
1982 l->flags |= PERLIO_F_CANREAD;
1983 break;
1984 case 'a':
1985 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1986 break;
1987 case 'w':
1988 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1989 break;
1990 default:
93189314 1991 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 1992 return -1;
1993 }
49fc4906
YK		 1994#ifdef EBCDIC
1995 {
1996 /* The mode variable contains one positional parameter followed by
1997 * optional keyword parameters. The positional parameters must be
1998 * passed as lowercase characters. The keyword parameters can be
1999 * passed in mixed case. They must be separated by commas. Only one
2000 * instance of a keyword can be specified. */
2001 int comma = 0;
2002 while (*mode) {
2003 switch (*mode++) {
2004 case '+':
2005 if(!comma)
2006 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2007 break;
2008 case 'b':
2009 if(!comma)
2010 l->flags &= ~PERLIO_F_CRLF;
2011 break;
2012 case 't':
2013 if(!comma)
2014 l->flags |= PERLIO_F_CRLF;
2015 break;
2016 case ',':
2017 comma = 1;
2018 break;
2019 default:
2020 break;
2021 }
2022 }
2023 }
2024#else
14a5cf38
JH		 2025 while (*mode) {
2026 switch (*mode++) {
2027 case '+':
2028 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2029 break;
2030 case 'b':
2031 l->flags &= ~PERLIO_F_CRLF;
2032 break;
2033 case 't':
2034 l->flags |= PERLIO_F_CRLF;
2035 break;
2036 default:
93189314 2037 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2038 return -1;
2039 }
2040 }
49fc4906 2041#endif
14a5cf38
JH		 2042 }
2043 else {
2044 if (l->next) {
2045 l->flags |= l->next->flags &
2046 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2047 PERLIO_F_APPEND);
2048 }
2049 }
5e2ab84b 2050#if 0
e17bc05a 2051 DEBUG_i(
14a5cf38 2052 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
6c9570dc 2053 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
14a5cf38 2054 l->flags, PerlIO_modestr(f, temp));
e17bc05a 2055 );
5e2ab84b 2056#endif
14a5cf38 2057 return 0;
76ced9ad
NIS		 2058}
2059
2060IV
f62ce20a 2061PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2062{
96a5add6 2063 PERL_UNUSED_CONTEXT;
8772537c 2064 PERL_UNUSED_ARG(f);
14a5cf38 2065 return 0;
760ac839
LW		 2066}
2067
9e353e3b 2068SSize_t
f62ce20a 2069PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2070{
14a5cf38 2071 /*
71200d45 2072 * Save the position as current head considers it
14a5cf38 2073 */
de009b76 2074 const Off_t old = PerlIO_tell(f);
a0714e2c 2075 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2076 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2077 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS		 2078}
2079
f6c77cf1 2080SSize_t
f62ce20a 2081PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2082{
14a5cf38
JH		 2083 STDCHAR *buf = (STDCHAR *) vbuf;
2084 if (f) {
263df5f1
JH		 2085 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2086 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2087 SETERRNO(EBADF, SS_IVCHAN);
0ea86a10 2088 PerlIO_save_errno(f);
263df5f1
JH		 2089 return 0;
2090 }
14a5cf38 2091 while (count > 0) {
93c2c2ec
IZ		 2092 get_cnt:
2093 {
14a5cf38
JH		 2094 SSize_t avail = PerlIO_get_cnt(f);
2095 SSize_t take = 0;
2096 if (avail > 0)
94e529cc 2097 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
14a5cf38
JH		 2098 if (take > 0) {
2099 STDCHAR *ptr = PerlIO_get_ptr(f);
2100 Copy(ptr, buf, take, STDCHAR);
2101 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2102 count -= take;
2103 buf += take;
93c2c2ec
IZ		 2104 if (avail == 0) /* set_ptrcnt could have reset avail */
2105 goto get_cnt;
14a5cf38
JH		 2106 }
2107 if (count > 0 && avail <= 0) {
2108 if (PerlIO_fill(f) != 0)
2109 break;
2110 }
93c2c2ec 2111 }
14a5cf38
JH		 2112 }
2113 return (buf - (STDCHAR *) vbuf);
2114 }
f6c77cf1 2115 return 0;
f6c77cf1
NIS		 2116}
2117
9e353e3b 2118IV
f62ce20a 2119PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2120{
96a5add6 2121 PERL_UNUSED_CONTEXT;
8772537c 2122 PERL_UNUSED_ARG(f);
14a5cf38 2123 return 0;
9e353e3b
NIS		 2124}
2125
2126IV
f62ce20a 2127PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2128{
96a5add6 2129 PERL_UNUSED_CONTEXT;
8772537c 2130 PERL_UNUSED_ARG(f);
14a5cf38 2131 return -1;
06da4f11
NIS		 2132}
2133
2134IV
f62ce20a 2135PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2136{
37725cdc
NIS		 2137 IV code = -1;
2138 if (PerlIOValid(f)) {
2139 PerlIO *n = PerlIONext(f);
2140 code = PerlIO_flush(f);
2141 PerlIOBase(f)->flags &=
2142 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2143 while (PerlIOValid(n)) {
de009b76 2144 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS		 2145 if (tab && tab->Close) {
2146 if ((*tab->Close)(aTHX_ n) != 0)
2147 code = -1;
2148 break;
2149 }
2150 else {
2151 PerlIOBase(n)->flags &=
2152 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2153 }
2154 n = PerlIONext(n);
2155 }
2156 }
2157 else {
2158 SETERRNO(EBADF, SS_IVCHAN);
2159 }
14a5cf38 2160 return code;
9e353e3b
NIS		 2161}
2162
2163IV
f62ce20a 2164PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2165{
96a5add6 2166 PERL_UNUSED_CONTEXT;
04892f78 2167 if (PerlIOValid(f)) {
14a5cf38
JH		 2168 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2169 }
2170 return 1;
9e353e3b
NIS		 2171}
2172
2173IV
f62ce20a 2174PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2175{
96a5add6 2176 PERL_UNUSED_CONTEXT;
04892f78 2177 if (PerlIOValid(f)) {
14a5cf38
JH		 2178 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2179 }
2180 return 1;
9e353e3b
NIS		 2181}
2182
2183void
f62ce20a 2184PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2185{
04892f78 2186 if (PerlIOValid(f)) {
dcda55fc 2187 PerlIO * const n = PerlIONext(f);
14a5cf38 2188 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2189 if (PerlIOValid(n))
14a5cf38
JH		 2190 PerlIO_clearerr(n);
2191 }
9e353e3b
NIS		 2192}
2193
2194void
f62ce20a 2195PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2196{
96a5add6 2197 PERL_UNUSED_CONTEXT;
04892f78 2198 if (PerlIOValid(f)) {
14a5cf38
JH		 2199 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2200 }
9e353e3b
NIS		 2201}
2202
93a8090d
NIS		 2203SV *
2204PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2205{
2206 if (!arg)
a0714e2c 2207 return NULL;
24d147a6 2208#ifdef USE_ITHREADS
93a8090d 2209 if (param) {
a951d81d
BL		 2210 arg = sv_dup(arg, param);
2211 SvREFCNT_inc_simple_void_NN(arg);
2212 return arg;
93a8090d
NIS		 2213 }
2214 else {
2215 return newSVsv(arg);
2216 }
2217#else
1b6737cc 2218 PERL_UNUSED_ARG(param);
93a8090d
NIS		 2219 return newSVsv(arg);
2220#endif
2221}
2222
2223PerlIO *
ecdeb87c 2224PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2225{
1b6737cc 2226 PerlIO * const nexto = PerlIONext(o);
04892f78 2227 if (PerlIOValid(nexto)) {
de009b76 2228 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS		 2229 if (tab && tab->Dup)
2230 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2231 else
2232 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS		 2233 }
2234 if (f) {
dcda55fc 2235 PerlIO_funcs * const self = PerlIOBase(o)->tab;
a951d81d 2236 SV *arg = NULL;
93a8090d 2237 char buf[8];
316ebaf2 2238 assert(self);
e17bc05a
TC		 2239 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2240 self->name,
2241 (void*)f, (void*)o, (void*)param) );
27e6dabe
JH		 2242 if (self->Getarg)
2243 arg = (*self->Getarg)(aTHX_ o, param, flags);
93a8090d 2244 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
df8c7dee 2245 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
f0720f70 2246 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
ef8d46e8 2247 SvREFCNT_dec(arg);
93a8090d
NIS		 2248 }
2249 return f;
2250}
2251
27da23d5 2252/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d 2253
8b84d7dd 2254/* Must be called with PL_perlio_mutex locked. */
22c96fc1 2255static void
ff25d7bc
JH		 2256S_more_refcounted_fds(pTHX_ const int new_fd)
2257 PERL_TSA_REQUIRES(PL_perlio_mutex)
2258{
22c96fc1 2259 const int old_max = PL_perlio_fd_refcnt_size;
f4ae5be6 2260 const int new_max = 16 + (new_fd & ~15);
22c96fc1
NC		 2261 int *new_array;
2262
dd791c72
JH		 2263#ifndef PERL_IMPLICIT_SYS
2264 PERL_UNUSED_CONTEXT;
2265#endif
2266
e17bc05a
TC		 2267 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2268 old_max, new_fd, new_max) );
22c96fc1
NC		 2269
2270 if (new_fd < old_max) {
2271 return;
2272 }
2273
f4ae5be6
NC		 2274 assert (new_max > new_fd);
2275
eae082a0
JH		 2276 /* Use plain realloc() since we need this memory to be really
2277 * global and visible to all the interpreters and/or threads. */
2278 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
22c96fc1
NC		 2279
2280 if (!new_array) {
6cb8cb21 2281 MUTEX_UNLOCK(&PL_perlio_mutex);
4cbe3a7d 2282 croak_no_mem();
22c96fc1
NC		 2283 }
2284
2285 PL_perlio_fd_refcnt_size = new_max;
2286 PL_perlio_fd_refcnt = new_array;
2287
e17bc05a
TC		 2288 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2289 (void*)(new_array + old_max),
2290 new_max - old_max) );
22c96fc1
NC		 2291
2292 Zero(new_array + old_max, new_max - old_max, int);
2293}
2294
2295
93a8090d
NIS		 2296void
2297PerlIO_init(pTHX)
2298{
8b84d7dd 2299 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
96a5add6 2300 PERL_UNUSED_CONTEXT;
93a8090d
NIS		 2301}
2302
168d5872
NIS		 2303void
2304PerlIOUnix_refcnt_inc(int fd)
2305{
27da23d5 2306 dTHX;
22c96fc1 2307 if (fd >= 0) {
22c96fc1 2308
6cb8cb21 2309 MUTEX_LOCK(&PL_perlio_mutex);
22c96fc1
NC		 2310 if (fd >= PL_perlio_fd_refcnt_size)
2311 S_more_refcounted_fds(aTHX_ fd);
2312
27da23d5 2313 PL_perlio_fd_refcnt[fd]++;
8b84d7dd 2314 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2315 /* diag_listed_as: refcnt_inc: fd %d%s */
8b84d7dd
RGS		 2316 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2317 fd, PL_perlio_fd_refcnt[fd]);
2318 }
e17bc05a
TC		 2319 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2320 fd, PL_perlio_fd_refcnt[fd]) );
22c96fc1 2321
6cb8cb21 2322 MUTEX_UNLOCK(&PL_perlio_mutex);
8b84d7dd 2323 } else {
12605ff9 2324 /* diag_listed_as: refcnt_inc: fd %d%s */
8b84d7dd 2325 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
168d5872
NIS		 2326 }
2327}
2328
168d5872
NIS		 2329int
2330PerlIOUnix_refcnt_dec(int fd)
2331{
2332 int cnt = 0;
22c96fc1 2333 if (fd >= 0) {
e17bc05a
TC		 2334#ifdef DEBUGGING
2335 dTHX;
e17bc05a 2336#endif
6cb8cb21 2337 MUTEX_LOCK(&PL_perlio_mutex);
8b84d7dd 2338 if (fd >= PL_perlio_fd_refcnt_size) {
12605ff9 2339 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2340 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
8b84d7dd
RGS		 2341 fd, PL_perlio_fd_refcnt_size);
2342 }
2343 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2344 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2345 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
8b84d7dd
RGS		 2346 fd, PL_perlio_fd_refcnt[fd]);
2347 }
27da23d5 2348 cnt = --PL_perlio_fd_refcnt[fd];
e17bc05a 2349 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
6cb8cb21 2350 MUTEX_UNLOCK(&PL_perlio_mutex);
8b84d7dd 2351 } else {
12605ff9 2352 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2353 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
168d5872
NIS		 2354 }
2355 return cnt;
2356}
2357
2e0cfa16
FC		 2358int
2359PerlIOUnix_refcnt(int fd)
2360{
2361 dTHX;
2362 int cnt = 0;
2363 if (fd >= 0) {
2e0cfa16 2364 MUTEX_LOCK(&PL_perlio_mutex);
2e0cfa16
FC		 2365 if (fd >= PL_perlio_fd_refcnt_size) {
2366 /* diag_listed_as: refcnt: fd %d%s */
2367 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2368 fd, PL_perlio_fd_refcnt_size);
2369 }
2370 if (PL_perlio_fd_refcnt[fd] <= 0) {
2371 /* diag_listed_as: refcnt: fd %d%s */
2372 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2373 fd, PL_perlio_fd_refcnt[fd]);
2374 }
2375 cnt = PL_perlio_fd_refcnt[fd];
2e0cfa16 2376 MUTEX_UNLOCK(&PL_perlio_mutex);
2e0cfa16
FC		 2377 } else {
2378 /* diag_listed_as: refcnt: fd %d%s */
2379 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2380 }
2381 return cnt;
2382}
2383
694c95cf
JH		 2384void
2385PerlIO_cleanup(pTHX)
2386{
2387 int i;
2388#ifdef USE_ITHREADS
e17bc05a 2389 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
9f4bd222 2390#else
e17bc05a 2391 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
694c95cf 2392#endif
e47547a8 2393
694c95cf
JH		 2394 /* Raise STDIN..STDERR refcount so we don't close them */
2395 for (i=0; i < 3; i++)
2396 PerlIOUnix_refcnt_inc(i);
2397 PerlIO_cleantable(aTHX_ &PL_perlio);
2398 /* Restore STDIN..STDERR refcount */
2399 for (i=0; i < 3; i++)
2400 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS		 2401
2402 if (PL_known_layers) {
2403 PerlIO_list_free(aTHX_ PL_known_layers);
2404 PL_known_layers = NULL;
2405 }
27da23d5 2406 if (PL_def_layerlist) {
9f4bd222
NIS		 2407 PerlIO_list_free(aTHX_ PL_def_layerlist);
2408 PL_def_layerlist = NULL;
2409 }
6cb8cb21
RGS		 2410}
2411
0934c9d9 2412void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
6cb8cb21 2413{
4f3da17a
DM		 2414#if 0
2415/* XXX we can't rely on an interpreter being present at this late stage,
2416 XXX so we can't use a function like PerlLIO_write that relies on one
2417 being present (at least in win32) :-(.
2418 Disable for now.
2419*/
d0e4ea4d 2420# ifdef DEBUGGING
6cb8cb21
RGS		 2421 {
2422 /* By now all filehandles should have been closed, so any
2423 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2424 * errors. */
77db880c
JH		 2425#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2426#define PERLIO_TEARDOWN_MESSAGE_FD 2
2427 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
6cb8cb21
RGS		 2428 int i;
2429 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
77db880c
JH		 2430 if (PL_perlio_fd_refcnt[i]) {
2431 const STRLEN len =
2432 my_snprintf(buf, sizeof(buf),
2433 "PerlIO_teardown: fd %d refcnt=%d\n",
2434 i, PL_perlio_fd_refcnt[i]);
2435 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2436 }
6cb8cb21
RGS		 2437 }
2438 }
d0e4ea4d 2439# endif
4f3da17a 2440#endif
eae082a0
JH		 2441 /* Not bothering with PL_perlio_mutex since by now
2442 * all the interpreters are gone. */
1cd82952
RGS		 2443 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2444 && PL_perlio_fd_refcnt) {
eae082a0 2445 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO		 2446 PL_perlio_fd_refcnt = NULL;
2447 PL_perlio_fd_refcnt_size = 0;
1cd82952 2448 }
694c95cf
JH		 2449}
2450
9e353e3b 2451/*--------------------------------------------------------------------------------------*/
14a5cf38 2452/*
71200d45 2453 * Bottom-most level for UNIX-like case
14a5cf38 2454 */
9e353e3b 2455
14a5cf38 2456typedef struct {
22569500
NIS		 2457 struct _PerlIO base; /* The generic part */
2458 int fd; /* UNIX like file descriptor */
2459 int oflags; /* open/fcntl flags */
9e353e3b
NIS		 2460} PerlIOUnix;
2461
abf9167d
DM		 2462static void
2463S_lockcnt_dec(pTHX_ const void* f)
2464{
dd791c72
JH		 2465#ifndef PERL_IMPLICIT_SYS
2466 PERL_UNUSED_CONTEXT;
2467#endif
abf9167d
DM		 2468 PerlIO_lockcnt((PerlIO*)f)--;
2469}
2470
2471
2472/* call the signal handler, and if that handler happens to clear
2473 * this handle, free what we can and return true */
2474
2475static bool
2476S_perlio_async_run(pTHX_ PerlIO* f) {
2477 ENTER;
2478 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2479 PerlIO_lockcnt(f)++;
2480 PERL_ASYNC_CHECK();
be48bbe8
CS		 2481 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2482 LEAVE;
abf9167d 2483 return 0;
be48bbe8 2484 }
abf9167d
DM		 2485 /* we've just run some perl-level code that could have done
2486 * anything, including closing the file or clearing this layer.
2487 * If so, free any lower layers that have already been
2488 * cleared, then return an error. */
2489 while (PerlIOValid(f) &&
2490 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2491 {
2492 const PerlIOl *l = *f;
2493 *f = l->next;
2494 Safefree(l);
2495 }
be48bbe8 2496 LEAVE;
abf9167d
DM		 2497 return 1;
2498}
2499
6f9d8c32 2500int
9e353e3b 2501PerlIOUnix_oflags(const char *mode)
760ac839 2502{
14a5cf38 2503 int oflags = -1;
3b6c1aba 2504 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH		 2505 mode++;
2506 switch (*mode) {
2507 case 'r':
2508 oflags = O_RDONLY;
2509 if (*++mode == '+') {
2510 oflags = O_RDWR;
2511 mode++;
2512 }
2513 break;
2514
2515 case 'w':
2516 oflags = O_CREAT | O_TRUNC;
2517 if (*++mode == '+') {
2518 oflags |= O_RDWR;
2519 mode++;
2520 }
2521 else
2522 oflags |= O_WRONLY;
2523 break;
2524
2525 case 'a':
2526 oflags = O_CREAT | O_APPEND;
2527 if (*++mode == '+') {
2528 oflags |= O_RDWR;
2529 mode++;
2530 }
2531 else
2532 oflags |= O_WRONLY;
2533 break;
2534 }
43e5477e
JH		 2535
2536 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2537
2538 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2539 * of them in, and then bit-and-masking the other them away, won't
2540 * have much of an effect. */
2541 switch (*mode) {
2542 case 'b':
2543#if O_TEXT != O_BINARY
2544 oflags |= O_BINARY;
14a5cf38 2545 oflags &= ~O_TEXT;
43e5477e
JH		 2546#endif
2547 mode++;
2548 break;
2549 case 't':
2550#if O_TEXT != O_BINARY
14a5cf38
JH		 2551 oflags |= O_TEXT;
2552 oflags &= ~O_BINARY;
43e5477e
JH		 2553#endif
2554 mode++;
2555 break;
2556 default:
d0e4ea4d 2557#if O_BINARY != 0
43e5477e 2558 /* bit-or:ing with zero O_BINARY would be useless. */
93f31ee9
PG		 2559 /*
2560 * If neither "t" nor "b" was specified, open the file
2561 * in O_BINARY mode.
43e5477e
JH		 2562 *
2563 * Note that if something else than the zero byte was seen
2564 * here (e.g. bogus mode "rx"), just few lines later we will
2565 * set the errno and invalidate the flags.
93f31ee9
PG		 2566 */
2567 oflags |= O_BINARY;
d0e4ea4d 2568#endif
43e5477e 2569 break;
93f31ee9 2570 }
14a5cf38 2571 if (*mode || oflags == -1) {
93189314 2572 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2573 oflags = -1;
2574 }
2575 return oflags;
9e353e3b
NIS		 2576}
2577
2578IV
f62ce20a 2579PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2580{
96a5add6 2581 PERL_UNUSED_CONTEXT;
14a5cf38 2582 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS		 2583}
2584
aa063c35
NIS		 2585static void
2586PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2587{
de009b76 2588 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2589#if defined(WIN32)
aa063c35
NIS		 2590 Stat_t st;
2591 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2592 if (!S_ISREG(st.st_mode)) {
e17bc05a 2593 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
6caa5a9c
NIS		 2594 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2595 }
aa063c35 2596 else {
e17bc05a 2597 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
aa063c35 2598 }
6caa5a9c
NIS		 2599 }
2600#endif
aa063c35
NIS		 2601 s->fd = fd;
2602 s->oflags = imode;
2603 PerlIOUnix_refcnt_inc(fd);
96a5add6 2604 PERL_UNUSED_CONTEXT;
aa063c35
NIS		 2605}
2606
2607IV
2608PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2609{
2610 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2611 if (*PerlIONext(f)) {
4b069b44 2612 /* We never call down so do any pending stuff now */
03c0554d 2613 PerlIO_flush(PerlIONext(f));
14a5cf38 2614 /*
71200d45 2615 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2616 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2617 * Should the value on NULL mode be 0 or -1?
14a5cf38 2618 */
acbd16bf 2619 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2620 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH		 2621 }
2622 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2623
14a5cf38 2624 return code;
4b803d04
NIS		 2625}
2626
c2fcde81
JH		 2627IV
2628PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2629{
de009b76 2630 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2631 Off_t new_loc;
96a5add6 2632 PERL_UNUSED_CONTEXT;
c2fcde81
JH		 2633 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2634#ifdef ESPIPE
2635 SETERRNO(ESPIPE, LIB_INVARG);
2636#else
2637 SETERRNO(EINVAL, LIB_INVARG);
2638#endif
2639 return -1;
2640 }
0723351e
NC		 2641 new_loc = PerlLIO_lseek(fd, offset, whence);
2642 if (new_loc == (Off_t) - 1)
dcda55fc 2643 return -1;
c2fcde81
JH		 2644 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2645 return 0;
2646}
2647
9e353e3b 2648PerlIO *
14a5cf38
JH		 2649PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2650 IV n, const char *mode, int fd, int imode,
2651 int perm, PerlIO *f, int narg, SV **args)
2652{
884fc2d3 2653 bool known_cloexec = 0;
d9dac8cd 2654 if (PerlIOValid(f)) {
cc6623a8 2655 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2656 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH		 2657 }
2658 if (narg > 0) {
3b6c1aba 2659 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH		 2660 mode++;
2661 else {
2662 imode = PerlIOUnix_oflags(mode);
5e2ce0f3
CB		 2663#ifdef VMS
2664 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2665#else
14a5cf38 2666 perm = 0666;
5e2ce0f3 2667#endif
14a5cf38
JH		 2668 }
2669 if (imode != -1) {
41188aa0
TC		 2670 STRLEN len;
2671 const char *path = SvPV_const(*args, len);
2672 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 2673 return NULL;
884fc2d3
Z		 2674 fd = PerlLIO_open3_cloexec(path, imode, perm);
2675 known_cloexec = 1;
14a5cf38
JH		 2676 }
2677 }
2678 if (fd >= 0) {
884fc2d3
Z		 2679 if (known_cloexec)
2680 setfd_inhexec_for_sysfd(fd);
2681 else
2682 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3b6c1aba 2683 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH		 2684 mode++;
2685 if (!f) {
2686 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS		 2687 }
2688 if (!PerlIOValid(f)) {
a33cf58c 2689 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
0a20f69b 2690 PerlLIO_close(fd);
a33cf58c
NIS		 2691 return NULL;
2692 }
d9dac8cd 2693 }
aa063c35 2694 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2695 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH		 2696 if (*mode == IoTYPE_APPEND)
2697 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH		 2698 return f;
2699 }
2700 else {
2701 if (f) {
6f207bd3 2702 NOOP;
14a5cf38 2703 /*
71200d45 2704 * FIXME: pop layers ???
14a5cf38
JH		 2705 */
2706 }
2707 return NULL;
2708 }
9e353e3b
NIS		 2709}
2710
71200d45 2711PerlIO *
ecdeb87c 2712PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2713{
dcda55fc 2714 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2715 int fd = os->fd;
ecdeb87c 2716 if (flags & PERLIO_DUP_FD) {
884fc2d3
Z		 2717 fd = PerlLIO_dup_cloexec(fd);
2718 if (fd >= 0)
2719 setfd_inhexec_for_sysfd(fd);
ecdeb87c 2720 }
22c96fc1 2721 if (fd >= 0) {
ecdeb87c 2722 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 2723 if (f) {
2724 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2725 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS		 2726 return f;
2727 }
0a20f69b 2728 PerlLIO_close(fd);
71200d45
NIS		 2729 }
2730 return NULL;
2731}
2732
2733
9e353e3b 2734SSize_t
f62ce20a 2735PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2736{
abf9167d
DM		 2737 int fd;
2738 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2739 return -1;
2740 fd = PerlIOSelf(f, PerlIOUnix)->fd;
81428673 2741 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2742 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2743 return 0;
1fd8f4ce 2744 }
14a5cf38 2745 while (1) {
b464bac0 2746 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2747 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS		 2748 if (len < 0) {
2749 if (errno != EAGAIN) {
2750 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 2751 PerlIO_save_errno(f);
ba85f2ea
NIS		 2752 }
2753 }
2754 else if (len == 0 && count != 0) {
14a5cf38 2755 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS		 2756 SETERRNO(0,0);
2757 }
14a5cf38
JH		 2758 return len;
2759 }
abf9167d
DM		 2760 /* EINTR */
2761 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2762 return -1;
14a5cf38 2763 }
e5964223 2764 NOT_REACHED; /*NOTREACHED*/
9e353e3b
NIS		 2765}
2766
2767SSize_t
f62ce20a 2768PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2769{
abf9167d
DM		 2770 int fd;
2771 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2772 return -1;
2773 fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2774 while (1) {
de009b76 2775 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2776 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS		 2777 if (len < 0) {
2778 if (errno != EAGAIN) {
2779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 2780 PerlIO_save_errno(f);
ba85f2ea
NIS		 2781 }
2782 }
14a5cf38
JH		 2783 return len;
2784 }
abf9167d
DM		 2785 /* EINTR */
2786 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2787 return -1;
06da4f11 2788 }
e5964223 2789 NOT_REACHED; /*NOTREACHED*/
9e353e3b
NIS		 2790}
2791
9e353e3b 2792Off_t
f62ce20a 2793PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2794{
96a5add6
AL		 2795 PERL_UNUSED_CONTEXT;
2796
14a5cf38 2797 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS		 2798}
2799
2556f95e
GF		 2800
2801IV
2376d97d 2802PerlIOUnix_close(pTHX_ PerlIO *f)
2556f95e 2803{
de009b76 2804 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2805 int code = 0;
168d5872 2806 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
d55a1461 2807 code = PerlIOBase_close(aTHX_ f);
168d5872 2808 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS		 2809 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2810 return 0;
22569500 2811 }
93a8090d
NIS		 2812 }
2813 else {
93189314 2814 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS		 2815 return -1;
2816 }
14a5cf38
JH		 2817 while (PerlLIO_close(fd) != 0) {
2818 if (errno != EINTR) {
2819 code = -1;
2820 break;
2821 }
abf9167d
DM		 2822 /* EINTR */
2823 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2824 return -1;
14a5cf38
JH		 2825 }
2826 if (code == 0) {
2827 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2828 }
2829 return code;
9e353e3b
NIS		 2830}
2831
27da23d5 2832PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2833 sizeof(PerlIO_funcs),
14a5cf38
JH		 2834 "unix",
2835 sizeof(PerlIOUnix),
2836 PERLIO_K_RAW,
2837 PerlIOUnix_pushed,
2376d97d 2838 PerlIOBase_popped,
14a5cf38 2839 PerlIOUnix_open,
86e05cf2 2840 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 2841 NULL,
2842 PerlIOUnix_fileno,
71200d45 2843 PerlIOUnix_dup,
14a5cf38
JH		 2844 PerlIOUnix_read,
2845 PerlIOBase_unread,
2846 PerlIOUnix_write,
2847 PerlIOUnix_seek,
2848 PerlIOUnix_tell,
2849 PerlIOUnix_close,
22569500
NIS		 2850 PerlIOBase_noop_ok, /* flush */
2851 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH		 2852 PerlIOBase_eof,
2853 PerlIOBase_error,
2854 PerlIOBase_clearerr,
2855 PerlIOBase_setlinebuf,
22569500
NIS		 2856 NULL, /* get_base */
2857 NULL, /* get_bufsiz */
2858 NULL, /* get_ptr */
2859 NULL, /* get_cnt */
2860 NULL, /* set_ptrcnt */
9e353e3b
NIS		 2861};
2862
2863/*--------------------------------------------------------------------------------------*/
14a5cf38 2864/*
71200d45 2865 * stdio as a layer
14a5cf38 2866 */
9e353e3b 2867
313e59c8
NIS		 2868#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2869/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2870 broken by the last second glibc 2.3 fix
2871 */
d0e4ea4d 2872# define STDIO_BUFFER_WRITABLE
313e59c8
NIS		 2873#endif
2874
2875
14a5cf38
JH		 2876typedef struct {
2877 struct _PerlIO base;
22569500 2878 FILE *stdio; /* The stream */
9e353e3b
NIS		 2879} PerlIOStdio;
2880
2881IV
f62ce20a 2882PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2883{
96a5add6
AL		 2884 PERL_UNUSED_CONTEXT;
2885
c4420975
AL		 2886 if (PerlIOValid(f)) {
2887 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2888 if (s)
2889 return PerlSIO_fileno(s);
439ba545
NIS		 2890 }
2891 errno = EBADF;
2892 return -1;
9e353e3b
NIS		 2893}
2894
766a733e 2895char *
14a5cf38
JH		 2896PerlIOStdio_mode(const char *mode, char *tmode)
2897{
de009b76 2898 char * const ret = tmode;
a0625d38
SR		 2899 if (mode) {
2900 while (*mode) {
2901 *tmode++ = *mode++;
2902 }
14a5cf38 2903 }
95005ad8 2904#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH		 2905 *tmode++ = 'b';
2906#endif
14a5cf38
JH		 2907 *tmode = '\0';
2908 return ret;
2909}
2910
4b803d04 2911IV
2dc2558e 2912PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2913{
1fd8f4ce
NIS		 2914 PerlIO *n;
2915 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2916 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS		 2917 if (toptab == tab) {
2918 /* Top is already stdio - pop self (duplicate) and use original */
2919 PerlIO_pop(aTHX_ f);
2920 return 0;
2921 } else {
de009b76 2922 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS		 2923 char tmode[8];
2924 FILE *stdio;
81428673 2925 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS		 2926 mode = PerlIOStdio_mode(mode, tmode)))) {
2927 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2928 /* We never call down so do any pending stuff now */
2929 PerlIO_flush(PerlIONext(f));
2a600bb8 2930 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
81428673 2931 }
1fd8f4ce
NIS		 2932 else {
2933 return -1;
2934 }
2935 }
14a5cf38 2936 }
2dc2558e 2937 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS		 2938}
2939
22569500 2940
9e353e3b 2941PerlIO *
4b069b44 2942PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2943{
14a5cf38
JH		 2944 dTHX;
2945 PerlIO *f = NULL;
ea5bc90f
YK		 2946#ifdef EBCDIC
2947 int rc;
2948 char filename[FILENAME_MAX];
2949 fldata_t fileinfo;
2950#endif
14a5cf38 2951 if (stdio) {
22569500 2952 PerlIOStdio *s;
375ed12a
JH		 2953 int fd0 = fileno(stdio);
2954 if (fd0 < 0) {
ea5bc90f
YK		 2955#ifdef EBCDIC
2956 rc = fldata(stdio,filename,&fileinfo);
2957 if(rc != 0){
2958 return NULL;
2959 }
2960 if(fileinfo.__dsorgHFS){
2961 return NULL;
2962 }
2963 /*This MVS dataset , OK!*/
2964#else
375ed12a 2965 return NULL;
ea5bc90f 2966#endif
375ed12a 2967 }
4b069b44
NIS		 2968 if (!mode || !*mode) {
2969 /* We need to probe to see how we can open the stream
2970 so start with read/write and then try write and read
2971 we dup() so that we can fclose without loosing the fd.
2972
2973 Note that the errno value set by a failing fdopen
2974 varies between stdio implementations.
2975 */
884fc2d3 2976 const int fd = PerlLIO_dup_cloexec(fd0);
375ed12a
JH		 2977 FILE *f2;
2978 if (fd < 0) {
2979 return f;
2980 }
2981 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2982 if (!f2) {
a33cf58c 2983 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS		 2984 }
2985 if (!f2) {
a33cf58c 2986 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS		 2987 }
2988 if (!f2) {
2989 /* Don't seem to be able to open */
2990 PerlLIO_close(fd);
2991 return f;
2992 }
2993 fclose(f2);
22569500 2994 }
de092133 2995 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS		 2996 s = PerlIOSelf(f, PerlIOStdio);
2997 s->stdio = stdio;
884fc2d3
Z		 2998 fd0 = fileno(stdio);
2999 if(fd0 != -1){
3000 PerlIOUnix_refcnt_inc(fd0);
3001 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3002 }
ea5bc90f 3003#ifdef EBCDIC
ea5bc90f
YK		 3004 else{
3005 rc = fldata(stdio,filename,&fileinfo);
3006 if(rc != 0){
3007 PerlIOUnix_refcnt_inc(fd0);
3008 }
3009 if(fileinfo.__dsorgHFS){
3010 PerlIOUnix_refcnt_inc(fd0);
3011 }
3012 /*This MVS dataset , OK!*/
3013 }
ea5bc90f 3014#endif
a33cf58c 3015 }
14a5cf38
JH		 3016 }
3017 return f;
9e353e3b
NIS		 3018}
3019
3020PerlIO *
14a5cf38
JH		 3021PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3022 IV n, const char *mode, int fd, int imode,
3023 int perm, PerlIO *f, int narg, SV **args)
3024{
3025 char tmode[8];
d9dac8cd 3026 if (PerlIOValid(f)) {
41188aa0
TC		 3027 STRLEN len;
3028 const char * const path = SvPV_const(*args, len);
dcda55fc 3029 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015 3030 FILE *stdio;
41188aa0 3031 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 3032 return NULL;
1751d015 3033 PerlIOUnix_refcnt_dec(fileno(s->stdio));
de092133
JH		 3034 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3035 s->stdio);
14a5cf38
JH		 3036 if (!s->stdio)
3037 return NULL;
3038 s->stdio = stdio;
884fc2d3
Z		 3039 fd = fileno(stdio);
3040 PerlIOUnix_refcnt_inc(fd);
3041 setfd_cloexec_or_inhexec_by_sysfdness(fd);
14a5cf38
JH		 3042 return f;
3043 }
3044 else {
3045 if (narg > 0) {
41188aa0
TC		 3046 STRLEN len;
3047 const char * const path = SvPV_const(*args, len);
3048 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 3049 return NULL;
3b6c1aba 3050 if (*mode == IoTYPE_NUMERIC) {
14a5cf38 3051 mode++;
884fc2d3 3052 fd = PerlLIO_open3_cloexec(path, imode, perm);
14a5cf38
JH		 3053 }
3054 else {
95005ad8
GH		 3055 FILE *stdio;
3056 bool appended = FALSE;
3057#ifdef __CYGWIN__
3058 /* Cygwin wants its 'b' early. */
3059 appended = TRUE;
3060 mode = PerlIOStdio_mode(mode, tmode);
3061#endif
3062 stdio = PerlSIO_fopen(path, mode);
6f0313ac 3063 if (stdio) {
6f0313ac
JH		 3064 if (!f) {
3065 f = PerlIO_allocate(aTHX);
3066 }
95005ad8
GH		 3067 if (!appended)
3068 mode = PerlIOStdio_mode(mode, tmode);
3069 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3070 if (f) {
0f0f9e2b 3071 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
884fc2d3
Z		 3072 fd = fileno(stdio);
3073 PerlIOUnix_refcnt_inc(fd);
3074 setfd_cloexec_or_inhexec_by_sysfdness(fd);
0f0f9e2b
JH		 3075 } else {
3076 PerlSIO_fclose(stdio);
6f0313ac
JH		 3077 }
3078 return f;
3079 }
3080 else {
3081 return NULL;
3082 }
14a5cf38
JH		 3083 }
3084 }
3085 if (fd >= 0) {
3086 FILE *stdio = NULL;
3087 int init = 0;
3b6c1aba 3088 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 3089 init = 1;
3090 mode++;
3091 }
3092 if (init) {
3093 switch (fd) {
3094 case 0:
3095 stdio = PerlSIO_stdin;
3096 break;
3097 case 1:
3098 stdio = PerlSIO_stdout;
3099 break;
3100 case 2:
3101 stdio = PerlSIO_stderr;
3102 break;
3103 }
3104 }
3105 else {
3106 stdio = PerlSIO_fdopen(fd, mode =
3107 PerlIOStdio_mode(mode, tmode));
3108 }
3109 if (stdio) {
d9dac8cd
NIS		 3110 if (!f) {
3111 f = PerlIO_allocate(aTHX);
3112 }
a33cf58c 3113 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba 3114 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
884fc2d3
Z		 3115 fd = fileno(stdio);
3116 PerlIOUnix_refcnt_inc(fd);
3117 setfd_cloexec_or_inhexec_by_sysfdness(fd);
a33cf58c 3118 }
14a5cf38
JH		 3119 return f;
3120 }
0a20f69b 3121 PerlLIO_close(fd);
14a5cf38
JH		 3122 }
3123 }
ee518936 3124 return NULL;
9e353e3b
NIS		 3125}
3126
1751d015 3127PerlIO *
ecdeb87c 3128PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS		 3129{
3130 /* This assumes no layers underneath - which is what
3131 happens, but is not how I remember it. NI-S 2001/10/16
3132 */
ecdeb87c 3133 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 3134 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 3135 const int fd = fileno(stdio);
9217ff3f 3136 char mode[8];
ecdeb87c 3137 if (flags & PERLIO_DUP_FD) {
884fc2d3 3138 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
9217ff3f
NIS		 3139 if (dfd >= 0) {
3140 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3141 goto set_this;
ecdeb87c
NIS		 3142 }
3143 else {
6f207bd3 3144 NOOP;
ecdeb87c
NIS		 3145 /* FIXME: To avoid messy error recovery if dup fails
3146 re-use the existing stdio as though flag was not set
3147 */
3148 }
3149 }
9217ff3f
NIS		 3150 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3151 set_this:
694c95cf 3152 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
40596bc5 3153 if(stdio) {
884fc2d3
Z		 3154 int fd = fileno(stdio);
3155 PerlIOUnix_refcnt_inc(fd);
3156 setfd_cloexec_or_inhexec_by_sysfdness(fd);
40596bc5 3157 }
1751d015
NIS		 3158 }
3159 return f;
3160}
3161
0d7a5398
NIS		 3162static int
3163PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3164{
96a5add6
AL		 3165 PERL_UNUSED_CONTEXT;
3166
0d7a5398 3167 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3168 * PerlIO_set_fileno() support from Configure
0d7a5398 3169 */
d0e4ea4d 3170#if defined(HAS_FDCLOSE)
36b1c892 3171 return fdclose(f, NULL) == 0 ? 1 : 0;
d0e4ea4d 3172#elif defined(__UCLIBC__)
ef8eacb8
AT		 3173 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3174 f->__filedes = -1;
3175 return 1;
d0e4ea4d 3176#elif defined(__GLIBC__)
0d7a5398 3177 /* There may be a better way for GLIBC:
37725cdc 3178 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS		 3179 */
3180 f->_fileno = -1;
3181 return 1;
d0e4ea4d 3182#elif defined(__sun)
f5992bc4 3183 PERL_UNUSED_ARG(f);
cfedb851 3184 return 0;
d0e4ea4d 3185#elif defined(__hpux)
0d7a5398
NIS		 3186 f->__fileH = 0xff;
3187 f->__fileL = 0xff;
3188 return 1;
9837d373 3189 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3190 your platform does not have special entry try this one.
9837d373
NIS		 3191 [For OSF only have confirmation for Tru64 (alpha)
3192 but assume other OSFs will be similar.]
37725cdc 3193 */
d0e4ea4d 3194#elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS		 3195 f->_file = -1;
3196 return 1;
d0e4ea4d 3197#elif defined(__FreeBSD__)
0d7a5398 3198 /* There may be a better way on FreeBSD:
37725cdc
NIS		 3199 - we could insert a dummy func in the _close function entry
3200 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS		 3201 */
3202 f->_file = -1;
0c49ea6a 3203 return 1;
d0e4ea4d 3204#elif defined(__OpenBSD__)
0c49ea6a
SU		 3205 /* There may be a better way on OpenBSD:
3206 - we could insert a dummy func in the _close function entry
3207 f->_close = (int (*)(void *)) dummy_close;
3208 */
3209 f->_file = -1;
0d7a5398 3210 return 1;
d0e4ea4d 3211#elif defined(__EMX__)
59ad941d
IZ		 3212 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3213 f->_handle = -1;
3214 return 1;
d0e4ea4d 3215#elif defined(__CYGWIN__)
0d7a5398 3216 /* There may be a better way on CYGWIN:
37725cdc
NIS		 3217 - we could insert a dummy func in the _close function entry
3218 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS		 3219 */
3220 f->_file = -1;
3221 return 1;
d0e4ea4d 3222#elif defined(WIN32)
1f664ef5 3223 PERLIO_FILE_file(f) = -1;
0d7a5398 3224 return 1;
d0e4ea4d
KW		 3225#else
3226# if 0
37725cdc 3227 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3228 (which isn't thread safe) instead
37725cdc 3229 */
0d7a5398 3230# error "Don't know how to set FILE.fileno on your platform"
d0e4ea4d 3231# endif
8772537c 3232 PERL_UNUSED_ARG(f);
0d7a5398 3233 return 0;
d0e4ea4d 3234#endif
0d7a5398
NIS		 3235}
3236
1751d015 3237IV
f62ce20a 3238PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3239{
c4420975 3240 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS		 3241 if (!stdio) {
3242 errno = EBADF;
3243 return -1;
3244 }
9217ff3f 3245 else {
de009b76 3246 const int fd = fileno(stdio);
0d7a5398 3247 int invalidate = 0;
bbfd922f 3248 IV result = 0;
1d791a44 3249 int dupfd = -1;
4ee39169 3250 dSAVEDERRNO;
0d7a5398 3251#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS		 3252 /* Socks lib overrides close() but stdio isn't linked to
3253 that library (though we are) - so we must call close()
3254 on sockets on stdio's behalf.
3255 */
0d7a5398
NIS		 3256 int optval;
3257 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3258 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3259 invalidate = 1;
0d7a5398 3260#endif
d8723f43
NC		 3261 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3262 that a subsequent fileno() on it returns -1. Don't want to croak()
3263 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3264 trying to close an already closed handle which somehow it still has
3265 a reference to. (via.xs, I'm looking at you). */
3266 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3267 /* File descriptor still in use */
0d7a5398 3268 invalidate = 1;
d8723f43 3269 }
0d7a5398 3270 if (invalidate) {
6b4ce6c8
AL		 3271 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3272 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3273 return 0;
3274 if (stdio == stdout || stdio == stderr)
3275 return PerlIO_flush(f);
d88f7f65 3276 }
d88f7f65
JH		 3277 MUTEX_LOCK(&PL_perlio_mutex);
3278 /* Right. We need a mutex here because for a brief while we
3279 will have the situation that fd is actually closed. Hence if
3280 a second thread were to get into this block, its dup() would
3281 likely return our fd as its dupfd. (after all, it is closed)
3282 Then if we get to the dup2() first, we blat the fd back
3283 (messing up its temporary as a side effect) only for it to
3284 then close its dupfd (== our fd) in its close(dupfd) */
3285
3286 /* There is, of course, a race condition, that any other thread
3287 trying to input/output/whatever on this fd will be stuffed
3288 for the duration of this little manoeuvrer. Perhaps we
3289 should hold an IO mutex for the duration of every IO
3290 operation if we know that invalidate doesn't work on this
3291 platform, but that would suck, and could kill performance.
3292
3293 Except that correctness trumps speed.
3294 Advice from klortho #11912. */
d88f7f65 3295 if (invalidate) {
37725cdc
NIS		 3296 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3297 Use Sarathy's trick from maint-5.6 to invalidate the
3298 fileno slot of the FILE *
3299 */
bbfd922f 3300 result = PerlIO_flush(f);
4ee39169 3301 SAVE_ERRNO;
6b4ce6c8 3302 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
711e8db2 3303 if (!invalidate) {
884fc2d3 3304 dupfd = PerlLIO_dup_cloexec(fd);
711e8db2 3305#ifdef USE_ITHREADS
9bab90c0 3306 if (dupfd < 0) {
711e8db2
NC		 3307 /* Oh cXap. This isn't going to go well. Not sure if we can
3308 recover from here, or if closing this particular FILE *
3309 is a good idea now. */
3310 }
3311#endif
3312 }
94ccb807
JH		 3313 } else {
3314 SAVE_ERRNO; /* This is here only to silence compiler warnings */
37725cdc 3315 }
0d7a5398 3316 result = PerlSIO_fclose(stdio);
37725cdc
NIS		 3317 /* We treat error from stdio as success if we invalidated
3318 errno may NOT be expected EBADF
e8529473
NIS		 3319 */
3320 if (invalidate && result != 0) {
4ee39169 3321 RESTORE_ERRNO;
0d7a5398 3322 result = 0;
37725cdc 3323 }
6b4ce6c8
AL		 3324#ifdef SOCKS5_VERSION_NAME
3325 /* in SOCKS' case, let close() determine return value */
3326 result = close(fd);
3327#endif
1d791a44 3328 if (dupfd >= 0) {
884fc2d3
Z		 3329 PerlLIO_dup2_cloexec(dupfd, fd);
3330 setfd_inhexec_for_sysfd(fd);
9bab90c0 3331 PerlLIO_close(dupfd);
d88f7f65 3332 }
d88f7f65 3333 MUTEX_UNLOCK(&PL_perlio_mutex);
9217ff3f 3334 return result;
37725cdc 3335 }
1751d015
NIS		 3336}
3337
9e353e3b 3338SSize_t
f62ce20a 3339PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3340{
abf9167d 3341 FILE * s;
14a5cf38 3342 SSize_t got = 0;
abf9167d
DM		 3343 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3344 return -1;
3345 s = PerlIOSelf(f, PerlIOStdio)->stdio;
4d948241
NIS		 3346 for (;;) {
3347 if (count == 1) {
3348 STDCHAR *buf = (STDCHAR *) vbuf;
3349 /*
3350 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3351 * stdio does not do that for fread()
3352 */
de009b76 3353 const int ch = PerlSIO_fgetc(s);
4d948241
NIS		 3354 if (ch != EOF) {
3355 *buf = ch;
3356 got = 1;
3357 }
14a5cf38 3358 }
4d948241
NIS		 3359 else
3360 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS		 3361 if (got == 0 && PerlSIO_ferror(s))
3362 got = -1;
42a7a32f 3363 if (got >= 0 || errno != EINTR)
4d948241 3364 break;
abf9167d
DM		 3365 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3366 return -1;
42a7a32f 3367 SETERRNO(0,0); /* just in case */
14a5cf38 3368 }
bdae4172
JH		 3369#ifdef __sgi
3370 /* Under some circumstances IRIX stdio fgetc() and fread()
3371 * set the errno to ENOENT, which makes no sense according
3372 * to either IRIX or POSIX. [rt.perl.org #123977] */
3373 if (errno == ENOENT) SETERRNO(0,0);
3374#endif
14a5cf38 3375 return got;
9e353e3b
NIS		 3376}
3377
3378SSize_t
f62ce20a 3379PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3380{
14a5cf38 3381 SSize_t unread = 0;
c4420975 3382 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3383
313e59c8 3384#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3385 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3386 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3387 STDCHAR *base = PerlIO_get_base(f);
3388 SSize_t cnt = PerlIO_get_cnt(f);
3389 STDCHAR *ptr = PerlIO_get_ptr(f);
3390 SSize_t avail = ptr - base;
3391 if (avail > 0) {
3392 if (avail > count) {
3393 avail = count;
3394 }
3395 ptr -= avail;
3396 Move(buf-avail,ptr,avail,STDCHAR);
3397 count -= avail;
3398 unread += avail;
3399 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS		 3400 if (PerlSIO_feof(s) && unread >= 0)
3401 PerlSIO_clearerr(s);
3402 }
3403 }
313e59c8
NIS		 3404 else
3405#endif
3406 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3407 /* We can get pointer to buffer but not its base
3408 Do ungetc() but check chars are ending up in the
3409 buffer
3410 */
3411 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3412 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3413 while (count > 0) {
de009b76 3414 const int ch = *--buf & 0xFF;
9f7cd136
NIS		 3415 if (ungetc(ch,s) != ch) {
3416 /* ungetc did not work */
3417 break;
3418 }
3419 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3420 /* Did not change pointer as expected */
375ed12a
JH		 3421 if (fgetc(s) != EOF) /* get char back again */
3422 break;
9f7cd136
NIS		 3423 }
3424 /* It worked ! */
3425 count--;
3426 unread++;
93679785
NIS		 3427 }
3428 }
3429
3430 if (count > 0) {
3431 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 3432 }
3433 return unread;
9e353e3b
NIS		 3434}
3435
3436SSize_t
f62ce20a 3437PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3438{
4d948241 3439 SSize_t got;
abf9167d
DM		 3440 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3441 return -1;
4d948241
NIS		 3442 for (;;) {
3443 got = PerlSIO_fwrite(vbuf, 1, count,
3444 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3445 if (got >= 0 || errno != EINTR)
4d948241 3446 break;
abf9167d
DM		 3447 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3448 return -1;
42a7a32f 3449 SETERRNO(0,0); /* just in case */
4d948241
NIS		 3450 }
3451 return got;
9e353e3b
NIS		 3452}
3453
94a175e1 3454IV
f62ce20a 3455PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3456{
c4420975 3457 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3458 PERL_UNUSED_CONTEXT;
3459
94a175e1 3460 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS		 3461}
3462
3463Off_t
f62ce20a 3464PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3465{
c4420975 3466 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3467 PERL_UNUSED_CONTEXT;
3468
94a175e1 3469 return PerlSIO_ftell(stdio);
9e353e3b
NIS		 3470}
3471
3472IV
f62ce20a 3473PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3474{
c4420975 3475 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3476 PERL_UNUSED_CONTEXT;
3477
14a5cf38
JH		 3478 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3479 return PerlSIO_fflush(stdio);
3480 }
3481 else {
6f207bd3 3482 NOOP;
88b61e10 3483#if 0
14a5cf38
JH		 3484 /*
3485 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3486 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3487 * design is to do _this_ but not have layer above flush this
71200d45 3488 * layer read-to-read
14a5cf38
JH		 3489 */
3490 /*
71200d45 3491 * Not writeable - sync by attempting a seek
14a5cf38 3492 */
4ee39169 3493 dSAVE_ERRNO;
14a5cf38 3494 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3495 RESTORE_ERRNO;
88b61e10 3496#endif
14a5cf38
JH		 3497 }
3498 return 0;
9e353e3b
NIS		 3499}
3500
3501IV
f62ce20a 3502PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3503{
96a5add6
AL		 3504 PERL_UNUSED_CONTEXT;
3505
14a5cf38 3506 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3507}
3508
3509IV
f62ce20a 3510PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3511{
96a5add6
AL		 3512 PERL_UNUSED_CONTEXT;
3513
263df5f1 3514 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3515}
3516
3517void
f62ce20a 3518PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3519{
96a5add6
AL		 3520 PERL_UNUSED_CONTEXT;
3521
14a5cf38 3522 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3523}
3524
3525void
f62ce20a 3526PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3527{
96a5add6
AL		 3528 PERL_UNUSED_CONTEXT;
3529
9e353e3b 3530#ifdef HAS_SETLINEBUF
14a5cf38 3531 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3532#else
bd61b366 3533 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS		 3534#endif
3535}
3536
3537#ifdef FILE_base
3538STDCHAR *
f62ce20a 3539PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3540{
c4420975 3541 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3542 PERL_UNUSED_CONTEXT;
cc00df79 3543 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS		 3544}
3545
3546Size_t
f62ce20a 3547PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3548{
c4420975 3549 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3550 PERL_UNUSED_CONTEXT;
14a5cf38 3551 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS		 3552}
3553#endif
3554
3555#ifdef USE_STDIO_PTR
3556STDCHAR *
f62ce20a 3557PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3558{
c4420975 3559 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3560 PERL_UNUSED_CONTEXT;
cc00df79 3561 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS		 3562}
3563
3564SSize_t
f62ce20a 3565PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3566{
c4420975 3567 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3568 PERL_UNUSED_CONTEXT;
14a5cf38 3569 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS		 3570}
3571
3572void
f62ce20a 3573PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3574{
c4420975 3575 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3576 PERL_UNUSED_CONTEXT;
14a5cf38 3577 if (ptr != NULL) {
d0e4ea4d 3578# ifdef STDIO_PTR_LVALUE
46f05249
JH		 3579 /* This is a long-standing infamous mess. The root of the
3580 * problem is that one cannot know the signedness of char, and
3581 * more precisely the signedness of FILE._ptr. The following
3582 * things have been tried, and they have all failed (across
3583 * different compilers (remember that core needs to to build
3584 * also with c++) and compiler options:
3585 *
3586 * - casting the RHS to (void*) -- works in *some* places
3587 * - casting the LHS to (void*) -- totally unportable
3588 *
3589 * So let's try silencing the warning at least for gcc. */
7347ee54 3590 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
d06fc7d4 3591 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
7347ee54 3592 GCC_DIAG_RESTORE_STMT;
d0e4ea4d 3593# ifdef STDIO_PTR_LVAL_SETS_CNT
f8a4dbc5 3594 assert(PerlSIO_get_cnt(stdio) == (cnt));
d0e4ea4d
KW		 3595# endif
3596# if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3597 /*
71200d45 3598 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH		 3599 */
3600 return;
d0e4ea4d
KW		 3601# endif
3602# else /* STDIO_PTR_LVALUE */
14a5cf38 3603 PerlProc_abort();
d0e4ea4d 3604# endif /* STDIO_PTR_LVALUE */
14a5cf38
JH		 3605 }
3606 /*
71200d45 3607 * Now (or only) set cnt
14a5cf38 3608 */
d0e4ea4d 3609# ifdef STDIO_CNT_LVALUE
14a5cf38 3610 PerlSIO_set_cnt(stdio, cnt);
d0e4ea4d 3611# elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH		 3612 PerlSIO_set_ptr(stdio,
3613 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3614 cnt));
d0e4ea4d 3615# else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3616 PerlProc_abort();
d0e4ea4d 3617# endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS		 3618}
3619
93679785 3620
9e353e3b
NIS		 3621#endif
3622
93679785
NIS		 3623IV
3624PerlIOStdio_fill(pTHX_ PerlIO *f)
3625{
abf9167d 3626 FILE * stdio;
93679785 3627 int c;
96a5add6 3628 PERL_UNUSED_CONTEXT;
abf9167d
DM		 3629 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3630 return -1;
3631 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6 3632
93679785
NIS		 3633 /*
3634 * fflush()ing read-only streams can cause trouble on some stdio-s
3635 */
3636 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3637 if (PerlSIO_fflush(stdio) != 0)
3638 return EOF;
3639 }
f3be3723
BL		 3640 for (;;) {
3641 c = PerlSIO_fgetc(stdio);
3642 if (c != EOF)
3643 break;
3644 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3645 return EOF;
abf9167d
DM		 3646 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3647 return -1;
f3be3723
BL		 3648 SETERRNO(0,0);
3649 }
93679785
NIS		 3650
3651#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8 3652
d0e4ea4d 3653# ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3654 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3655 /* Fake ungetc() to the real buffer in case system's ungetc
3656 goes elsewhere
3657 */
3658 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3659 SSize_t cnt = PerlSIO_get_cnt(stdio);
3660 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3661 if (ptr == base+1) {
3662 *--ptr = (STDCHAR) c;
3663 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3664 if (PerlSIO_feof(stdio))
3665 PerlSIO_clearerr(stdio);
3666 return 0;
3667 }
3668 }
313e59c8 3669 else
d0e4ea4d 3670# endif
313e59c8 3671 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3672 STDCHAR ch = c;
3673 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3674 return 0;
3675 }
3676 }
93679785
NIS		 3677#endif
3678
93679785 3679 /* If buffer snoop scheme above fails fall back to
9f7cd136 3680 using ungetc().
93679785
NIS		 3681 */
3682 if (PerlSIO_ungetc(c, stdio) != c)
3683 return EOF;
5876737a 3684
93679785
NIS		 3685 return 0;
3686}
3687
3688
3689
27da23d5 3690PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3691 sizeof(PerlIO_funcs),
14a5cf38
JH		 3692 "stdio",
3693 sizeof(PerlIOStdio),
86e05cf2 3694 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3695 PerlIOStdio_pushed,
2376d97d 3696 PerlIOBase_popped,
14a5cf38 3697 PerlIOStdio_open,
86e05cf2 3698 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 3699 NULL,
3700 PerlIOStdio_fileno,
71200d45 3701 PerlIOStdio_dup,
14a5cf38
JH		 3702 PerlIOStdio_read,
3703 PerlIOStdio_unread,
3704 PerlIOStdio_write,
3705 PerlIOStdio_seek,
3706 PerlIOStdio_tell,
3707 PerlIOStdio_close,
3708 PerlIOStdio_flush,
3709 PerlIOStdio_fill,
3710 PerlIOStdio_eof,
3711 PerlIOStdio_error,
3712 PerlIOStdio_clearerr,
3713 PerlIOStdio_setlinebuf,
9e353e3b 3714#ifdef FILE_base
14a5cf38
JH		 3715 PerlIOStdio_get_base,
3716 PerlIOStdio_get_bufsiz,
9e353e3b 3717#else
14a5cf38
JH		 3718 NULL,
3719 NULL,
9e353e3b
NIS		 3720#endif
3721#ifdef USE_STDIO_PTR
14a5cf38
JH		 3722 PerlIOStdio_get_ptr,
3723 PerlIOStdio_get_cnt,
15b61c98 3724# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
79ed0f43 3725 PerlIOStdio_set_ptrcnt,
15b61c98
JH		 3726# else
3727 NULL,
3728# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3729#else
3730 NULL,
14a5cf38
JH		 3731 NULL,
3732 NULL,
15b61c98 3733#endif /* USE_STDIO_PTR */
9e353e3b
NIS		 3734};
3735
b9d6bf13
JH		 3736/* Note that calls to PerlIO_exportFILE() are reversed using
3737 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3738FILE *
81428673 3739PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3740{
e87a358a 3741 dTHX;
81428673
NIS		 3742 FILE *stdio = NULL;
3743 if (PerlIOValid(f)) {
3744 char buf[8];
375ed12a
JH		 3745 int fd = PerlIO_fileno(f);
3746 if (fd < 0) {
3747 return NULL;
3748 }
81428673
NIS		 3749 PerlIO_flush(f);
3750 if (!mode || !*mode) {
3751 mode = PerlIO_modestr(f, buf);
3752 }
3753 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3754 if (stdio) {
3755 PerlIOl *l = *f;
9f75cc58 3756 PerlIO *f2;
81428673
NIS		 3757 /* De-link any lower layers so new :stdio sticks */
3758 *f = NULL;
a0714e2c 3759 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
9f75cc58 3760 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673 3761 s->stdio = stdio;
6b54a403 3762 PerlIOUnix_refcnt_inc(fileno(stdio));
81428673
NIS		 3763 /* Link previous lower layers under new one */
3764 *PerlIONext(f) = l;
3765 }
3766 else {
3767 /* restore layers list */
3768 *f = l;
3769 }
a33cf58c 3770 }
14a5cf38
JH		 3771 }
3772 return stdio;
9e353e3b
NIS		 3773}
3774
81428673 3775
9e353e3b
NIS		 3776FILE *
3777PerlIO_findFILE(PerlIO *f)
3778{
14a5cf38 3779 PerlIOl *l = *f;
bbbc33d0 3780 FILE *stdio;
14a5cf38
JH		 3781 while (l) {
3782 if (l->tab == &PerlIO_stdio) {
3783 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3784 return s->stdio;
3785 }
3786 l = *PerlIONext(&l);
f7e7eb72 3787 }
4b069b44 3788 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
bbbc33d0
NC		 3789 /* However, we're not really exporting a FILE * to someone else (who
3790 becomes responsible for closing it, or calling PerlIO_releaseFILE())
486ec47a 3791 So we need to undo its reference count increase on the underlying file
bbbc33d0
NC		 3792 descriptor. We have to do this, because if the loop above returns you
3793 the FILE *, then *it* didn't increase any reference count. So there's
3794 only one way to be consistent. */
3795 stdio = PerlIO_exportFILE(f, NULL);
3796 if (stdio) {
3797 const int fd = fileno(stdio);
3798 if (fd >= 0)
3799 PerlIOUnix_refcnt_dec(fd);
3800 }
3801 return stdio;
9e353e3b
NIS		 3802}
3803
b9d6bf13 3804/* Use this to reverse PerlIO_exportFILE calls. */
9e353e3b
NIS		 3805void
3806PerlIO_releaseFILE(PerlIO *p, FILE *f)
3807{
22569500
NIS		 3808 PerlIOl *l;
3809 while ((l = *p)) {
3810 if (l->tab == &PerlIO_stdio) {
3811 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2bcd6579 3812 if (s->stdio == f) { /* not in a loop */
6b54a403
NC		 3813 const int fd = fileno(f);
3814 if (fd >= 0)
3815 PerlIOUnix_refcnt_dec(fd);
2bcd6579
DD		 3816 {
3817 dTHX;
3818 PerlIO_pop(aTHX_ p);
3819 }
22569500
NIS		 3820 return;
3821 }
3822 }
3823 p = PerlIONext(p);
3824 }
3825 return;
9e353e3b
NIS		 3826}
3827
3828/*--------------------------------------------------------------------------------------*/
14a5cf38 3829/*
71200d45 3830 * perlio buffer layer
14a5cf38 3831 */
9e353e3b 3832
5e2ab84b 3833IV
2dc2558e 3834PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 3835{
14a5cf38 3836 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
de009b76 3837 const int fd = PerlIO_fileno(f);
14a5cf38
JH		 3838 if (fd >= 0 && PerlLIO_isatty(fd)) {
3839 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3840 }
4b069b44 3841 if (*PerlIONext(f)) {
de009b76 3842 const Off_t posn = PerlIO_tell(PerlIONext(f));
4b069b44
NIS		 3843 if (posn != (Off_t) - 1) {
3844 b->posn = posn;
3845 }
14a5cf38 3846 }
2dc2558e 3847 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b
NIS		 3848}
3849
9e353e3b 3850PerlIO *
14a5cf38
JH		 3851PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3852 IV n, const char *mode, int fd, int imode, int perm,
3853 PerlIO *f, int narg, SV **args)
3854{
04892f78 3855 if (PerlIOValid(f)) {
14a5cf38 3856 PerlIO *next = PerlIONext(f);
67363c0d
JH		 3857 PerlIO_funcs *tab =
3858 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3859 if (tab && tab->Open)
3860 next =
3861 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3862 next, narg, args);
2dc2558e 3863 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
14a5cf38
JH		 3864 return NULL;
3865 }
3866 }
3867 else {
04892f78 3868 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38 3869 int init = 0;
3b6c1aba 3870 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 3871 init = 1;
3872 /*
71200d45 3873 * mode++;
14a5cf38
JH		 3874 */
3875 }
67363c0d
JH		 3876 if (tab && tab->Open)
3877 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3878 f, narg, args);
3879 else
3880 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 3881 if (f) {
22569500 3882 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
b26b1ab5
NC		 3883 /*
3884 * if push fails during open, open fails. close will pop us.
3885 */
3886 PerlIO_close (f);
3887 return NULL;
3888 } else {
3889 fd = PerlIO_fileno(f);
b26b1ab5
NC		 3890 if (init && fd == 2) {
3891 /*
3892 * Initial stderr is unbuffered
3893 */
3894 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3895 }
23b84778
IZ		 3896#ifdef PERLIO_USING_CRLF
3897# ifdef PERLIO_IS_BINMODE_FD
3898 if (PERLIO_IS_BINMODE_FD(fd))
bd61b366 3899 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
23b84778
IZ		 3900 else
3901# endif
3902 /*
3903 * do something about failing setmode()? --jhi
3904 */
3905 PerlLIO_setmode(fd, O_BINARY);
3906#endif
8c8488cd 3907#ifdef VMS
8c8488cd
CB		 3908 /* Enable line buffering with record-oriented regular files
3909 * so we don't introduce an extraneous record boundary when
3910 * the buffer fills up.
3911 */
3912 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3913 Stat_t st;
3914 if (PerlLIO_fstat(fd, &st) == 0
3915 && S_ISREG(st.st_mode)
3916 && (st.st_fab_rfm == FAB$C_VAR
3917 || st.st_fab_rfm == FAB$C_VFC)) {
3918 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3919 }
3920 }
3921#endif
14a5cf38
JH		 3922 }
3923 }
ee518936 3924 }
14a5cf38 3925 return f;
9e353e3b
NIS		 3926}
3927
14a5cf38
JH		 3928/*
3929 * This "flush" is akin to sfio's sync in that it handles files in either
93c2c2ec
IZ		 3930 * read or write state. For write state, we put the postponed data through
3931 * the next layers. For read state, we seek() the next layers to the
3932 * offset given by current position in the buffer, and discard the buffer
3933 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3934 * in any case?). Then the pass the stick further in chain.
14a5cf38 3935 */
9e353e3b 3936IV
f62ce20a 3937PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 3938{
dcda55fc 3939 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3940 int code = 0;
04892f78 3941 PerlIO *n = PerlIONext(f);
14a5cf38
JH		 3942 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3943 /*
71200d45 3944 * write() the buffer
14a5cf38 3945 */
de009b76
AL		 3946 const STDCHAR *buf = b->buf;
3947 const STDCHAR *p = buf;
14a5cf38
JH		 3948 while (p < b->ptr) {
3949 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3950 if (count > 0) {
3951 p += count;
3952 }
3953 else if (count < 0 || PerlIO_error(n)) {
3954 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 3955 PerlIO_save_errno(f);
14a5cf38
JH		 3956 code = -1;
3957 break;
3958 }
3959 }
3960 b->posn += (p - buf);
3961 }
3962 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3963 STDCHAR *buf = PerlIO_get_base(f);
3964 /*
71200d45 3965 * Note position change
14a5cf38
JH		 3966 */
3967 b->posn += (b->ptr - buf);
3968 if (b->ptr < b->end) {
4b069b44
NIS		 3969 /* We did not consume all of it - try and seek downstream to
3970 our logical position
14a5cf38 3971 */
4b069b44 3972 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
04892f78
NIS		 3973 /* Reload n as some layers may pop themselves on seek */
3974 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38 3975 }
ba5c3fe9 3976 else {
4b069b44
NIS		 3977 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3978 data is lost for good - so return saying "ok" having undone
3979 the position adjust
3980 */
3981 b->posn -= (b->ptr - buf);
ba5c3fe9
NIS		 3982 return code;
3983 }
14a5cf38
JH		 3984 }
3985 }
3986 b->ptr = b->end = b->buf;
3987 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78 3988 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
04892f78 3989 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH		 3990 code = -1;
3991 return code;
6f9d8c32
NIS		 3992}
3993
93c2c2ec
IZ		 3994/* This discards the content of the buffer after b->ptr, and rereads
3995 * the buffer from the position off in the layer downstream; here off
3996 * is at offset corresponding to b->ptr - b->buf.
3997 */
06da4f11 3998IV
f62ce20a 3999PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 4000{
dcda55fc 4001 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4002 PerlIO *n = PerlIONext(f);
4003 SSize_t avail;
4004 /*
4b069b44
NIS		 4005 * Down-stream flush is defined not to loose read data so is harmless.
4006 * we would not normally be fill'ing if there was data left in anycase.
14a5cf38 4007 */
93c2c2ec 4008 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
14a5cf38
JH		 4009 return -1;
4010 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
f62ce20a 4011 PerlIOBase_flush_linebuf(aTHX);
14a5cf38
JH		 4012
4013 if (!b->buf)
22569500 4014 PerlIO_get_base(f); /* allocate via vtable */
14a5cf38 4015
0f0eef27 4016 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
ec6fa4f0 4017
14a5cf38 4018 b->ptr = b->end = b->buf;
4b069b44
NIS		 4019
4020 if (!PerlIOValid(n)) {
4021 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4022 return -1;
4023 }
4024
14a5cf38
JH		 4025 if (PerlIO_fast_gets(n)) {
4026 /*
04892f78 4027 * Layer below is also buffered. We do _NOT_ want to call its
14a5cf38
JH		 4028 * ->Read() because that will loop till it gets what we asked for
4029 * which may hang on a pipe etc. Instead take anything it has to
71200d45 4030 * hand, or ask it to fill _once_.
14a5cf38
JH		 4031 */
4032 avail = PerlIO_get_cnt(n);
4033 if (avail <= 0) {
4034 avail = PerlIO_fill(n);
4035 if (avail == 0)
4036 avail = PerlIO_get_cnt(n);
4037 else {
4038 if (!PerlIO_error(n) && PerlIO_eof(n))
4039 avail = 0;
4040 }
4041 }
4042 if (avail > 0) {
4043 STDCHAR *ptr = PerlIO_get_ptr(n);
dcda55fc 4044 const SSize_t cnt = avail;
eb160463 4045 if (avail > (SSize_t)b->bufsiz)
14a5cf38
JH		 4046 avail = b->bufsiz;
4047 Copy(ptr, b->buf, avail, STDCHAR);
4048 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4049 }
4050 }
4051 else {
4052 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4053 }
4054 if (avail <= 0) {
4055 if (avail == 0)
4056 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4057 else
0ea86a10 4058 {
14a5cf38 4059 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10
FC		 4060 PerlIO_save_errno(f);
4061 }
14a5cf38
JH		 4062 return -1;
4063 }
4064 b->end = b->buf + avail;
4065 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4066 return 0;
06da4f11
NIS		 4067}
4068
6f9d8c32 4069SSize_t
f62ce20a 4070PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 4071{
04892f78 4072 if (PerlIOValid(f)) {
dcda55fc 4073 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4074 if (!b->ptr)
4075 PerlIO_get_base(f);
f62ce20a 4076 return PerlIOBase_read(aTHX_ f, vbuf, count);
14a5cf38
JH		 4077 }
4078 return 0;
6f9d8c32
NIS		 4079}
4080
9e353e3b 4081SSize_t
f62ce20a 4082PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 4083{
14a5cf38 4084 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
dcda55fc 4085 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4086 SSize_t unread = 0;
4087 SSize_t avail;
4088 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4089 PerlIO_flush(f);
4090 if (!b->buf)
4091 PerlIO_get_base(f);
4092 if (b->buf) {
4093 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4094 /*
4095 * Buffer is already a read buffer, we can overwrite any chars
71200d45 4096 * which have been read back to buffer start
14a5cf38
JH		 4097 */
4098 avail = (b->ptr - b->buf);
4099 }
4100 else {
4101 /*
4102 * Buffer is idle, set it up so whole buffer is available for
71200d45 4103 * unread
14a5cf38
JH		 4104 */
4105 avail = b->bufsiz;
4106 b->end = b->buf + avail;
4107 b->ptr = b->end;
4108 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4109 /*
71200d45 4110 * Buffer extends _back_ from where we are now
14a5cf38
JH		 4111 */
4112 b->posn -= b->bufsiz;
4113 }
94e529cc 4114 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
14a5cf38 4115 /*
71200d45 4116 * If we have space for more than count, just move count
14a5cf38
JH		 4117 */
4118 avail = count;
4119 }
4120 if (avail > 0) {
4121 b->ptr -= avail;
4122 buf -= avail;
4123 /*
4124 * In simple stdio-like ungetc() case chars will be already
71200d45 4125 * there
14a5cf38
JH		 4126 */
4127 if (buf != b->ptr) {
4128 Copy(buf, b->ptr, avail, STDCHAR);
4129 }
4130 count -= avail;
4131 unread += avail;
4132 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4133 }
4134 }
93679785
NIS		 4135 if (count > 0) {
4136 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4137 }
14a5cf38 4138 return unread;
760ac839
LW		 4139}
4140
9e353e3b 4141SSize_t
f62ce20a 4142PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 4143{
de009b76 4144 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4145 const STDCHAR *buf = (const STDCHAR *) vbuf;
ee56a6b9 4146 const STDCHAR *flushptr = buf;
14a5cf38
JH		 4147 Size_t written = 0;
4148 if (!b->buf)
4149 PerlIO_get_base(f);
4150 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4151 return 0;
0678cb22
NIS		 4152 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4153 if (PerlIO_flush(f) != 0) {
4154 return 0;
4155 }
4156 }
ee56a6b9
CS		 4157 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4158 flushptr = buf + count;
4159 while (flushptr > buf && *(flushptr - 1) != '\n')
4160 --flushptr;
4161 }
14a5cf38
JH		 4162 while (count > 0) {
4163 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
94e529cc 4164 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
14a5cf38 4165 avail = count;
ee56a6b9
CS		 4166 if (flushptr > buf && flushptr <= buf + avail)
4167 avail = flushptr - buf;
14a5cf38 4168 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
ee56a6b9
CS		 4169 if (avail) {
4170 Copy(buf, b->ptr, avail, STDCHAR);
4171 count -= avail;
4172 buf += avail;
4173 written += avail;
4174 b->ptr += avail;
4175 if (buf == flushptr)
4176 PerlIO_flush(f);
14a5cf38
JH		 4177 }
4178 if (b->ptr >= (b->buf + b->bufsiz))
abf9167d
DM		 4179 if (PerlIO_flush(f) == -1)
4180 return -1;
14a5cf38
JH		 4181 }
4182 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4183 PerlIO_flush(f);
4184 return written;
9e353e3b
NIS		 4185}
4186
94a175e1 4187IV
f62ce20a 4188PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 4189{
14a5cf38
JH		 4190 IV code;
4191 if ((code = PerlIO_flush(f)) == 0) {
14a5cf38
JH		 4192 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4193 code = PerlIO_seek(PerlIONext(f), offset, whence);
4194 if (code == 0) {
de009b76 4195 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4196 b->posn = PerlIO_tell(PerlIONext(f));
4197 }
9e353e3b 4198 }
14a5cf38 4199 return code;
9e353e3b
NIS		 4200}
4201
4202Off_t
f62ce20a 4203PerlIOBuf_tell(pTHX_ PerlIO *f)
9e353e3b 4204{
dcda55fc 4205 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4206 /*
71200d45 4207 * b->posn is file position where b->buf was read, or will be written
14a5cf38
JH		 4208 */
4209 Off_t posn = b->posn;
37725cdc 4210 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
0678cb22
NIS		 4211 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4212#if 1
4213 /* As O_APPEND files are normally shared in some sense it is better
4214 to flush :
4215 */
4216 PerlIO_flush(f);
4217#else
37725cdc 4218 /* when file is NOT shared then this is sufficient */
0678cb22
NIS		 4219 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4220#endif
4221 posn = b->posn = PerlIO_tell(PerlIONext(f));
4222 }
14a5cf38
JH		 4223 if (b->buf) {
4224 /*
71200d45 4225 * If buffer is valid adjust position by amount in buffer
14a5cf38
JH		 4226 */
4227 posn += (b->ptr - b->buf);
4228 }
4229 return posn;
9e353e3b
NIS		 4230}
4231
4232IV
44798d05
NIS		 4233PerlIOBuf_popped(pTHX_ PerlIO *f)
4234{
de009b76
AL		 4235 const IV code = PerlIOBase_popped(aTHX_ f);
4236 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
44798d05
NIS		 4237 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4238 Safefree(b->buf);
4239 }
dcda55fc 4240 b->ptr = b->end = b->buf = NULL;
44798d05
NIS		 4241 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4242 return code;
4243}
4244
4245IV
f62ce20a 4246PerlIOBuf_close(pTHX_ PerlIO *f)
9e353e3b 4247{
de009b76
AL		 4248 const IV code = PerlIOBase_close(aTHX_ f);
4249 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4250 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4251 Safefree(b->buf);
14a5cf38 4252 }
dcda55fc 4253 b->ptr = b->end = b->buf = NULL;
14a5cf38
JH		 4254 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4255 return code;
760ac839
LW		 4256}
4257
9e353e3b 4258STDCHAR *
f62ce20a 4259PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
9e353e3b 4260{
dcda55fc 4261 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4262 if (!b->buf)
4263 PerlIO_get_base(f);
4264 return b->ptr;
9e353e3b
NIS		 4265}
4266
05d1247b 4267SSize_t
f62ce20a 4268PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
9e353e3b 4269{
dcda55fc 4270 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4271 if (!b->buf)
4272 PerlIO_get_base(f);
4273 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4274 return (b->end - b->ptr);
4275 return 0;
9e353e3b
NIS		 4276}
4277
4278STDCHAR *
f62ce20a 4279PerlIOBuf_get_base(pTHX_ PerlIO *f)
9e353e3b 4280{
dcda55fc 4281 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
96a5add6
AL		 4282 PERL_UNUSED_CONTEXT;
4283
14a5cf38
JH		 4284 if (!b->buf) {
4285 if (!b->bufsiz)
1810cd7c 4286 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
d09f14bf 4287 Newx(b->buf,b->bufsiz, STDCHAR);
14a5cf38
JH		 4288 if (!b->buf) {
4289 b->buf = (STDCHAR *) & b->oneword;
4290 b->bufsiz = sizeof(b->oneword);
4291 }
dcda55fc 4292 b->end = b->ptr = b->buf;
06da4f11 4293 }
14a5cf38 4294 return b->buf;
9e353e3b
NIS		 4295}
4296
4297Size_t
f62ce20a 4298PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
9e353e3b 4299{
dcda55fc 4300 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4301 if (!b->buf)
4302 PerlIO_get_base(f);
4303 return (b->end - b->buf);
9e353e3b
NIS		 4304}
4305
4306void
f62ce20a 4307PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 4308{
dcda55fc 4309 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
babfacb9
JH		 4310#ifndef DEBUGGING
4311 PERL_UNUSED_ARG(cnt);
4312#endif
14a5cf38
JH		 4313 if (!b->buf)
4314 PerlIO_get_base(f);
4315 b->ptr = ptr;
b727803b
RGS		 4316 assert(PerlIO_get_cnt(f) == cnt);
4317 assert(b->ptr >= b->buf);
14a5cf38 4318 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW		 4319}
4320
71200d45 4321PerlIO *
ecdeb87c 4322PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 4323{
ecdeb87c 4324 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 4325}
4326
4327
4328
27da23d5 4329PERLIO_FUNCS_DECL(PerlIO_perlio) = {
2dc2558e 4330 sizeof(PerlIO_funcs),
14a5cf38
JH		 4331 "perlio",
4332 sizeof(PerlIOBuf),
86e05cf2 4333 PERLIO_K_BUFFERED|PERLIO_K_RAW,
14a5cf38 4334 PerlIOBuf_pushed,
44798d05 4335 PerlIOBuf_popped,
14a5cf38 4336 PerlIOBuf_open,
86e05cf2 4337 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4338 NULL,
4339 PerlIOBase_fileno,
71200d45 4340 PerlIOBuf_dup,
14a5cf38
JH		 4341 PerlIOBuf_read,
4342 PerlIOBuf_unread,
4343 PerlIOBuf_write,
4344 PerlIOBuf_seek,
4345 PerlIOBuf_tell,
4346 PerlIOBuf_close,
4347 PerlIOBuf_flush,
4348 PerlIOBuf_fill,
4349 PerlIOBase_eof,
4350 PerlIOBase_error,
4351 PerlIOBase_clearerr,
4352 PerlIOBase_setlinebuf,
4353 PerlIOBuf_get_base,
4354 PerlIOBuf_bufsiz,
4355 PerlIOBuf_get_ptr,
4356 PerlIOBuf_get_cnt,
4357 PerlIOBuf_set_ptrcnt,
9e353e3b
NIS		 4358};
4359
66ecd56b 4360/*--------------------------------------------------------------------------------------*/
14a5cf38 4361/*
71200d45 4362 * Temp layer to hold unread chars when cannot do it any other way
14a5cf38 4363 */
5e2ab84b
NIS		 4364
4365IV
f62ce20a 4366PerlIOPending_fill(pTHX_ PerlIO *f)
5e2ab84b 4367{
14a5cf38 4368 /*
71200d45 4369 * Should never happen
14a5cf38
JH		 4370 */
4371 PerlIO_flush(f);
4372 return 0;
5e2ab84b
NIS		 4373}
4374
4375IV
f62ce20a 4376PerlIOPending_close(pTHX_ PerlIO *f)
5e2ab84b 4377{
14a5cf38 4378 /*
71200d45 4379 * A tad tricky - flush pops us, then we close new top
14a5cf38
JH		 4380 */
4381 PerlIO_flush(f);
4382 return PerlIO_close(f);
5e2ab84b
NIS		 4383}
4384
94a175e1 4385IV
f62ce20a 4386PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
5e2ab84b 4387{
14a5cf38 4388 /*
71200d45 4389 * A tad tricky - flush pops us, then we seek new top
14a5cf38
JH		 4390 */
4391 PerlIO_flush(f);
4392 return PerlIO_seek(f, offset, whence);
5e2ab84b
NIS		 4393}
4394
4395
4396IV
f62ce20a 4397PerlIOPending_flush(pTHX_ PerlIO *f)
5e2ab84b 4398{
dcda55fc 4399 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4400 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4401 Safefree(b->buf);
14a5cf38
JH		 4402 b->buf = NULL;
4403 }
4404 PerlIO_pop(aTHX_ f);
4405 return 0;
5e2ab84b
NIS		 4406}
4407
4408void
f62ce20a 4409PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
5e2ab84b 4410{
14a5cf38
JH		 4411 if (cnt <= 0) {
4412 PerlIO_flush(f);
4413 }
4414 else {
f62ce20a 4415 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
14a5cf38 4416 }
5e2ab84b
NIS		 4417}
4418
4419IV
2dc2558e 4420PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 4421{
de009b76 4422 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
dcda55fc 4423 PerlIOl * const l = PerlIOBase(f);
14a5cf38 4424 /*
71200d45
NIS		 4425 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4426 * etc. get muddled when it changes mid-string when we auto-pop.
14a5cf38
JH		 4427 */
4428 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4429 (PerlIOBase(PerlIONext(f))->
4430 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4431 return code;
5e2ab84b
NIS		 4432}
4433
4434SSize_t
f62ce20a 4435PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
5e2ab84b 4436{
14a5cf38
JH		 4437 SSize_t avail = PerlIO_get_cnt(f);
4438 SSize_t got = 0;
94e529cc 4439 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
14a5cf38
JH		 4440 avail = count;
4441 if (avail > 0)
f62ce20a 4442 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
eb160463 4443 if (got >= 0 && got < (SSize_t)count) {
de009b76 4444 const SSize_t more =
14a5cf38
JH		 4445 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4446 if (more >= 0 || got == 0)
4447 got += more;
4448 }
4449 return got;
5e2ab84b
NIS		 4450}
4451
27da23d5 4452PERLIO_FUNCS_DECL(PerlIO_pending) = {
2dc2558e 4453 sizeof(PerlIO_funcs),
14a5cf38
JH		 4454 "pending",
4455 sizeof(PerlIOBuf),
86e05cf2 4456 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
14a5cf38 4457 PerlIOPending_pushed,
44798d05 4458 PerlIOBuf_popped,
14a5cf38 4459 NULL,
86e05cf2 4460 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4461 NULL,
4462 PerlIOBase_fileno,
71200d45 4463 PerlIOBuf_dup,
14a5cf38
JH		 4464 PerlIOPending_read,
4465 PerlIOBuf_unread,
4466 PerlIOBuf_write,
4467 PerlIOPending_seek,
4468 PerlIOBuf_tell,
4469 PerlIOPending_close,
4470 PerlIOPending_flush,
4471 PerlIOPending_fill,
4472 PerlIOBase_eof,
4473 PerlIOBase_error,
4474 PerlIOBase_clearerr,
4475 PerlIOBase_setlinebuf,
4476 PerlIOBuf_get_base,
4477 PerlIOBuf_bufsiz,
4478 PerlIOBuf_get_ptr,
4479 PerlIOBuf_get_cnt,
4480 PerlIOPending_set_ptrcnt,
5e2ab84b
NIS		 4481};
4482
4483
4484
4485/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4486/*
4487 * crlf - translation On read translate CR,LF to "\n" we do this by
4488 * overriding ptr/cnt entries to hand back a line at a time and keeping a
71200d45 4489 * record of which nl we "lied" about. On write translate "\n" to CR,LF
93c2c2ec
IZ		 4490 *
4491 * c->nl points on the first byte of CR LF pair when it is temporarily
4492 * replaced by LF, or to the last CR of the buffer. In the former case
4493 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4494 * that it ends at c->nl; these two cases can be distinguished by
4495 * *c->nl. c->nl is set during _getcnt() call, and unset during
4496 * _unread() and _flush() calls.
4497 * It only matters for read operations.
66ecd56b
NIS		 4498 */
4499
14a5cf38 4500typedef struct {
22569500
NIS		 4501 PerlIOBuf base; /* PerlIOBuf stuff */
4502 STDCHAR *nl; /* Position of crlf we "lied" about in the
14a5cf38 4503 * buffer */
99efab12
NIS		 4504} PerlIOCrlf;
4505
ff1e3883
JD		 4506/* Inherit the PERLIO_F_UTF8 flag from previous layer.
4507 * Otherwise the :crlf layer would always revert back to
4508 * raw mode.
4509 */
4510static void
4511S_inherit_utf8_flag(PerlIO *f)
4512{
4513 PerlIO *g = PerlIONext(f);
4514 if (PerlIOValid(g)) {
4515 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4516 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4517 }
4518 }
4519}
4520
f5b9d040 4521IV
2dc2558e 4522PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
f5b9d040 4523{
14a5cf38
JH		 4524 IV code;
4525 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2dc2558e 4526 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b 4527#if 0
e17bc05a 4528 DEBUG_i(
14a5cf38 4529 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
6c9570dc 4530 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
14a5cf38 4531 PerlIOBase(f)->flags);
e17bc05a 4532 );
5e2ab84b 4533#endif
8229d19f 4534 {
5da08ab0
LT		 4535 /* If the old top layer is a CRLF layer, reactivate it (if
4536 * necessary) and remove this new layer from the stack */
8229d19f 4537 PerlIO *g = PerlIONext(f);
7826b36f 4538 if (PerlIOValid(g)) {
8229d19f
JH		 4539 PerlIOl *b = PerlIOBase(g);
4540 if (b && b->tab == &PerlIO_crlf) {
4541 if (!(b->flags & PERLIO_F_CRLF))
4542 b->flags |= PERLIO_F_CRLF;
ff1e3883 4543 S_inherit_utf8_flag(g);
8229d19f
JH		 4544 PerlIO_pop(aTHX_ f);
4545 return code;
7826b36f 4546 }
8229d19f
JH		 4547 }
4548 }
ff1e3883 4549 S_inherit_utf8_flag(f);
14a5cf38 4550 return code;
f5b9d040
NIS		 4551}
4552
4553
99efab12 4554SSize_t
f62ce20a 4555PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4556{
dcda55fc 4557 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
93c2c2ec 4558 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
76e6dc3a 4559 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4560 c->nl = NULL;
4561 }
4562 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4563 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 4564 else {
4565 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4566 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4567 SSize_t unread = 0;
4568 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4569 PerlIO_flush(f);
4570 if (!b->buf)
4571 PerlIO_get_base(f);
4572 if (b->buf) {
4573 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4574 b->end = b->ptr = b->buf + b->bufsiz;
4575 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4576 b->posn -= b->bufsiz;
4577 }
4578 while (count > 0 && b->ptr > b->buf) {
dcda55fc 4579 const int ch = *--buf;
14a5cf38
JH		 4580 if (ch == '\n') {
4581 if (b->ptr - 2 >= b->buf) {
76e6dc3a
KW		 4582 *--(b->ptr) = NATIVE_0xa;
4583 *--(b->ptr) = NATIVE_0xd;
14a5cf38
JH		 4584 unread++;
4585 count--;
4586 }
4587 else {
93c2c2ec 4588 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
76e6dc3a
KW		 4589 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4590 '\r' */
93c2c2ec
IZ		 4591 unread++;
4592 count--;
14a5cf38
JH		 4593 }
4594 }
4595 else {
4596 *--(b->ptr) = ch;
4597 unread++;
4598 count--;
4599 }
4600 }
4601 }
ec1da995
LT		 4602 if (count > 0)
4603 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
14a5cf38
JH		 4604 return unread;
4605 }
99efab12
NIS		 4606}
4607
93c2c2ec 4608/* XXXX This code assumes that buffer size >=2, but does not check it... */
99efab12 4609SSize_t
f62ce20a 4610PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
99efab12 4611{
dcda55fc 4612 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4613 if (!b->buf)
4614 PerlIO_get_base(f);
4615 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
dcda55fc 4616 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
76e6dc3a 4617 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
23b3c6af 4618 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
14a5cf38 4619 scan:
76e6dc3a 4620 while (nl < b->end && *nl != NATIVE_0xd)
14a5cf38 4621 nl++;
76e6dc3a 4622 if (nl < b->end && *nl == NATIVE_0xd) {
14a5cf38
JH		 4623 test:
4624 if (nl + 1 < b->end) {
76e6dc3a 4625 if (nl[1] == NATIVE_0xa) {
14a5cf38
JH		 4626 *nl = '\n';
4627 c->nl = nl;
4628 }
4629 else {
4630 /*
71200d45 4631 * Not CR,LF but just CR
14a5cf38
JH		 4632 */
4633 nl++;
4634 goto scan;
4635 }
4636 }
4637 else {
4638 /*
71200d45 4639 * Blast - found CR as last char in buffer
14a5cf38 4640 */
e87a358a 4641
14a5cf38
JH		 4642 if (b->ptr < nl) {
4643 /*
4644 * They may not care, defer work as long as
71200d45 4645 * possible
14a5cf38 4646 */
a0d1d361 4647 c->nl = nl;
14a5cf38
JH		 4648 return (nl - b->ptr);
4649 }
4650 else {
4651 int code;
22569500 4652 b->ptr++; /* say we have read it as far as
14a5cf38 4653 * flush() is concerned */
22569500 4654 b->buf++; /* Leave space in front of buffer */
e949e37c
NIS		 4655 /* Note as we have moved buf up flush's
4656 posn += ptr-buf
4657 will naturally make posn point at CR
4658 */
22569500
NIS		 4659 b->bufsiz--; /* Buffer is thus smaller */
4660 code = PerlIO_fill(f); /* Fetch some more */
4661 b->bufsiz++; /* Restore size for next time */
4662 b->buf--; /* Point at space */
4663 b->ptr = nl = b->buf; /* Which is what we hand
14a5cf38 4664 * off */
76e6dc3a 4665 *nl = NATIVE_0xd; /* Fill in the CR */
14a5cf38 4666 if (code == 0)
22569500 4667 goto test; /* fill() call worked */
14a5cf38 4668 /*
71200d45 4669 * CR at EOF - just fall through
14a5cf38 4670 */
a0d1d361 4671 /* Should we clear EOF though ??? */
14a5cf38
JH		 4672 }
4673 }
4674 }
4675 }
4676 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4677 }
4678 return 0;
99efab12
NIS		 4679}
4680
4681void
f62ce20a 4682PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
14a5cf38 4683{
dcda55fc
AL		 4684 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4685 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38
JH		 4686 if (!b->buf)
4687 PerlIO_get_base(f);
4688 if (!ptr) {
a0d1d361 4689 if (c->nl) {
14a5cf38 4690 ptr = c->nl + 1;
76e6dc3a 4691 if (ptr == b->end && *c->nl == NATIVE_0xd) {
486ec47a 4692 /* Deferred CR at end of buffer case - we lied about count */
22569500
NIS		 4693 ptr--;
4694 }
4695 }
14a5cf38
JH		 4696 else {
4697 ptr = b->end;
14a5cf38
JH		 4698 }
4699 ptr -= cnt;
4700 }
4701 else {
6f207bd3 4702 NOOP;
3b4bd3fd 4703#if 0
14a5cf38 4704 /*
71200d45 4705 * Test code - delete when it works ...
14a5cf38 4706 */
3b4bd3fd 4707 IV flags = PerlIOBase(f)->flags;
ba7abf9d 4708 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
76e6dc3a 4709 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
486ec47a 4710 /* Deferred CR at end of buffer case - we lied about count */
a0d1d361 4711 chk--;
22569500 4712 }
14a5cf38
JH		 4713 chk -= cnt;
4714
a0d1d361 4715 if (ptr != chk ) {
99ef548b 4716 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
6c9570dc
MHM		 4717 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4718 flags, c->nl, b->end, cnt);
14a5cf38 4719 }
99ef548b 4720#endif
14a5cf38
JH		 4721 }
4722 if (c->nl) {
4723 if (ptr > c->nl) {
4724 /*
71200d45 4725 * They have taken what we lied about
14a5cf38 4726 */
76e6dc3a 4727 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4728 c->nl = NULL;
4729 ptr++;
4730 }
4731 }
4732 b->ptr = ptr;
4733 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
99efab12
NIS		 4734}
4735
4736SSize_t
f62ce20a 4737PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4738{
14a5cf38 4739 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4740 return PerlIOBuf_write(aTHX_ f, vbuf, count);
14a5cf38 4741 else {
dcda55fc 4742 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4743 const STDCHAR *buf = (const STDCHAR *) vbuf;
dcda55fc 4744 const STDCHAR * const ebuf = buf + count;
14a5cf38
JH		 4745 if (!b->buf)
4746 PerlIO_get_base(f);
4747 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4748 return 0;
4749 while (buf < ebuf) {
dcda55fc 4750 const STDCHAR * const eptr = b->buf + b->bufsiz;
14a5cf38
JH		 4751 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4752 while (buf < ebuf && b->ptr < eptr) {
4753 if (*buf == '\n') {
4754 if ((b->ptr + 2) > eptr) {
4755 /*
71200d45 4756 * Not room for both
14a5cf38
JH		 4757 */
4758 PerlIO_flush(f);
4759 break;
4760 }
4761 else {
76e6dc3a
KW		 4762 *(b->ptr)++ = NATIVE_0xd; /* CR */
4763 *(b->ptr)++ = NATIVE_0xa; /* LF */
14a5cf38
JH		 4764 buf++;
4765 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4766 PerlIO_flush(f);
4767 break;
4768 }
4769 }
4770 }
4771 else {
dcda55fc 4772 *(b->ptr)++ = *buf++;
14a5cf38
JH		 4773 }
4774 if (b->ptr >= eptr) {
4775 PerlIO_flush(f);
4776 break;
4777 }
4778 }
4779 }
4780 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4781 PerlIO_flush(f);
4782 return (buf - (STDCHAR *) vbuf);
4783 }
99efab12
NIS		 4784}
4785
4786IV
f62ce20a 4787PerlIOCrlf_flush(pTHX_ PerlIO *f)
99efab12 4788{
dcda55fc 4789 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38 4790 if (c->nl) {
76e6dc3a 4791 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4792 c->nl = NULL;
4793 }
f62ce20a 4794 return PerlIOBuf_flush(aTHX_ f);
99efab12
NIS		 4795}
4796
86e05cf2
NIS		 4797IV
4798PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4799{
4800 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4801 /* In text mode - flush any pending stuff and flip it */
4802 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4803#ifndef PERLIO_USING_CRLF
4804 /* CRLF is unusual case - if this is just the :crlf layer pop it */
5fae6dc1 4805 PerlIO_pop(aTHX_ f);
86e05cf2
NIS		 4806#endif
4807 }
dda4a477 4808 return PerlIOBase_binmode(aTHX_ f);
86e05cf2
NIS		 4809}
4810
27da23d5 4811PERLIO_FUNCS_DECL(PerlIO_crlf) = {
2dc2558e 4812 sizeof(PerlIO_funcs),
14a5cf38
JH		 4813 "crlf",
4814 sizeof(PerlIOCrlf),
86e05cf2 4815 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
14a5cf38 4816 PerlIOCrlf_pushed,
44798d05 4817 PerlIOBuf_popped, /* popped */
14a5cf38 4818 PerlIOBuf_open,
86e05cf2 4819 PerlIOCrlf_binmode, /* binmode */
14a5cf38
JH		 4820 NULL,
4821 PerlIOBase_fileno,
71200d45 4822 PerlIOBuf_dup,
de009b76 4823 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
22569500
NIS		 4824 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4825 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
14a5cf38
JH		 4826 PerlIOBuf_seek,
4827 PerlIOBuf_tell,
4828 PerlIOBuf_close,
4829 PerlIOCrlf_flush,
4830 PerlIOBuf_fill,
4831 PerlIOBase_eof,
4832 PerlIOBase_error,
4833 PerlIOBase_clearerr,
4834 PerlIOBase_setlinebuf,
4835 PerlIOBuf_get_base,
4836 PerlIOBuf_bufsiz,
4837 PerlIOBuf_get_ptr,
4838 PerlIOCrlf_get_cnt,
4839 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS		 4840};
4841
9e353e3b 4842PerlIO *
e87a358a 4843Perl_PerlIO_stdin(pTHX)
9e353e3b 4844{
a1ea730d 4845 if (!PL_perlio) {
14a5cf38
JH		 4846 PerlIO_stdstreams(aTHX);
4847 }
303f2dc3 4848 return (PerlIO*)&PL_perlio[1];
9e353e3b
NIS		 4849}
4850
9e353e3b 4851PerlIO *
e87a358a 4852Perl_PerlIO_stdout(pTHX)
9e353e3b 4853{
a1ea730d 4854 if (!PL_perlio) {
14a5cf38
JH		 4855 PerlIO_stdstreams(aTHX);
4856 }
303f2dc3 4857 return (PerlIO*)&PL_perlio[2];
9e353e3b
NIS		 4858}
4859
9e353e3b 4860PerlIO *
e87a358a 4861Perl_PerlIO_stderr(pTHX)
9e353e3b 4862{
a1ea730d 4863 if (!PL_perlio) {
14a5cf38
JH		 4864 PerlIO_stdstreams(aTHX);
4865 }
303f2dc3 4866 return (PerlIO*)&PL_perlio[3];
9e353e3b
NIS		 4867}
4868
4869/*--------------------------------------------------------------------------------------*/
4870
9e353e3b
NIS		 4871char *
4872PerlIO_getname(PerlIO *f, char *buf)
4873{
a15cef0c 4874#ifdef VMS
dbf7dff6 4875 dTHX;
73d840c0 4876 char *name = NULL;
7659f319 4877 bool exported = FALSE;
14a5cf38 4878 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
7659f319
CB		 4879 if (!stdio) {
4880 stdio = PerlIO_exportFILE(f,0);
4881 exported = TRUE;
4882 }
4883 if (stdio) {
14a5cf38 4884 name = fgetname(stdio, buf);
7659f319
CB		 4885 if (exported) PerlIO_releaseFILE(f,stdio);
4886 }
73d840c0 4887 return name;
a15cef0c 4888#else
8772537c
AL		 4889 PERL_UNUSED_ARG(f);
4890 PERL_UNUSED_ARG(buf);
dbf7dff6 4891 Perl_croak_nocontext("Don't know how to get file name");
bd61b366 4892 return NULL;
a15cef0c 4893#endif
9e353e3b
NIS		 4894}
4895
4896
4897/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4898/*
4899 * Functions which can be called on any kind of PerlIO implemented in
71200d45 4900 * terms of above
14a5cf38 4901 */
9e353e3b 4902
e87a358a
NIS		 4903#undef PerlIO_fdopen
4904PerlIO *
4905PerlIO_fdopen(int fd, const char *mode)
4906{
4907 dTHX;
bd61b366 4908 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
e87a358a
NIS		 4909}
4910
4911#undef PerlIO_open
4912PerlIO *
4913PerlIO_open(const char *path, const char *mode)
4914{
4915 dTHX;
42d9b98d 4916 SV *name = sv_2mortal(newSVpv(path, 0));
bd61b366 4917 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
e87a358a
NIS		 4918}
4919
4920#undef Perlio_reopen
4921PerlIO *
4922PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4923{
4924 dTHX;
42d9b98d 4925 SV *name = sv_2mortal(newSVpv(path,0));
bd61b366 4926 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
e87a358a
NIS		 4927}
4928
9e353e3b 4929#undef PerlIO_getc
6f9d8c32 4930int
9e353e3b 4931PerlIO_getc(PerlIO *f)
760ac839 4932{
e87a358a 4933 dTHX;
14a5cf38 4934 STDCHAR buf[1];
de009b76 4935 if ( 1 == PerlIO_read(f, buf, 1) ) {
14a5cf38
JH		 4936 return (unsigned char) buf[0];
4937 }
4938 return EOF;
313ca112
NIS		 4939}
4940
4941#undef PerlIO_ungetc
4942int
4943PerlIO_ungetc(PerlIO *f, int ch)
4944{
e87a358a 4945 dTHX;
14a5cf38
JH		 4946 if (ch != EOF) {
4947 STDCHAR buf = ch;
4948 if (PerlIO_unread(f, &buf, 1) == 1)
4949 return ch;
4950 }
4951 return EOF;
760ac839
LW		 4952}
4953
9e353e3b
NIS		 4954#undef PerlIO_putc
4955int
4956PerlIO_putc(PerlIO *f, int ch)
760ac839 4957{
e87a358a 4958 dTHX;
14a5cf38
JH		 4959 STDCHAR buf = ch;
4960 return PerlIO_write(f, &buf, 1);
760ac839
LW		 4961}
4962
9e353e3b 4963#undef PerlIO_puts
760ac839 4964int
9e353e3b 4965PerlIO_puts(PerlIO *f, const char *s)
760ac839 4966{
e87a358a 4967 dTHX;
dcda55fc 4968 return PerlIO_write(f, s, strlen(s));
760ac839
LW		 4969}
4970
4971#undef PerlIO_rewind
4972void
c78749f2 4973PerlIO_rewind(PerlIO *f)
760ac839 4974{
e87a358a 4975 dTHX;
14a5cf38
JH		 4976 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4977 PerlIO_clearerr(f);
6f9d8c32
NIS		 4978}
4979
4980#undef PerlIO_vprintf
4981int
4982PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4983{
14a5cf38 4984 dTHX;
53ce71d3 4985 SV * sv;
b83604b4 4986 const char *s;
14a5cf38
JH		 4987 STRLEN len;
4988 SSize_t wrote;
2cc61e15 4989#ifdef NEED_VA_COPY
14a5cf38
JH		 4990 va_list apc;
4991 Perl_va_copy(ap, apc);
53ce71d3 4992 sv = vnewSVpvf(fmt, &apc);
d4825b27 4993 va_end(apc);
2cc61e15 4994#else
53ce71d3 4995 sv = vnewSVpvf(fmt, &ap);
2cc61e15 4996#endif
b83604b4 4997 s = SvPV_const(sv, len);
14a5cf38
JH		 4998 wrote = PerlIO_write(f, s, len);
4999 SvREFCNT_dec(sv);
5000 return wrote;
760ac839
LW		 5001}
5002
5003#undef PerlIO_printf
6f9d8c32 5004int
14a5cf38 5005PerlIO_printf(PerlIO *f, const char *fmt, ...)
760ac839 5006{
14a5cf38
JH		 5007 va_list ap;
5008 int result;
5009 va_start(ap, fmt);
5010 result = PerlIO_vprintf(f, fmt, ap);
5011 va_end(ap);
5012 return result;
760ac839
LW		 5013}
5014
5015#undef PerlIO_stdoutf
6f9d8c32 5016int
14a5cf38 5017PerlIO_stdoutf(const char *fmt, ...)
760ac839 5018{
e87a358a 5019 dTHX;
14a5cf38
JH		 5020 va_list ap;
5021 int result;
5022 va_start(ap, fmt);
5023 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5024 va_end(ap);
5025 return result;
760ac839
LW		 5026}
5027
5028#undef PerlIO_tmpfile
5029PerlIO *
c78749f2 5030PerlIO_tmpfile(void)
760ac839 5031{
ae73d7ec
TC		 5032 return PerlIO_tmpfile_flags(0);
5033}
5034
5035#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
5036#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
5037
5038PerlIO *
5039PerlIO_tmpfile_flags(int imode)
5040{
dbf7dff6 5041#ifndef WIN32
2941a2e1 5042 dTHX;
dbf7dff6 5043#endif
2941a2e1 5044 PerlIO *f = NULL;
2941a2e1 5045#ifdef WIN32
04247234 5046 const int fd = win32_tmpfd_mode(imode);
2941a2e1
JH		 5047 if (fd >= 0)
5048 f = PerlIO_fdopen(fd, "w+b");
74b421cc 5049#elif ! defined(OS2)
0b99e986
RGS		 5050 int fd = -1;
5051 char tempname[] = "/tmp/PerlIO_XXXXXX";
284167a5 5052 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
525f6fe9 5053 SV * sv = NULL;
e57270be 5054 int old_umask = umask(0177);
ae73d7ec 5055 imode &= ~MKOSTEMP_MODE_MASK;
7299ca58 5056 if (tmpdir && *tmpdir) {
0b99e986 5057 /* if TMPDIR is set and not empty, we try that first */
7299ca58 5058 sv = newSVpv(tmpdir, 0);
0b99e986 5059 sv_catpv(sv, tempname + 4);
74b421cc 5060 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
0b99e986
RGS		 5061 }
5062 if (fd < 0) {
e40f8e80 5063 SvREFCNT_dec(sv);
7299ca58 5064 sv = NULL;
0b99e986 5065 /* else we try /tmp */
74b421cc 5066 fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
0b99e986 5067 }
b7561fc9
BF		 5068 if (fd < 0) {
5069 /* Try cwd */
5070 sv = newSVpvs(".");
5071 sv_catpv(sv, tempname + 4);
74b421cc 5072 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
b7561fc9 5073 }
60f7fc1e 5074 umask(old_umask);
2941a2e1 5075 if (fd >= 0) {
ae73d7ec
TC		 5076 /* fdopen() with a numeric mode */
5077 char mode[8];
5078 int writing = 1;
5079 (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
5080 f = PerlIO_fdopen(fd, mode);
2941a2e1
JH		 5081 if (f)
5082 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
d0e4ea4d 5083# ifndef VMS
0b99e986 5084 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
d0e4ea4d 5085# endif
2941a2e1 5086 }
ef8d46e8 5087 SvREFCNT_dec(sv);
faf55891 5088#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
c4420975 5089 FILE * const stdio = PerlSIO_tmpfile();
2941a2e1 5090
085e731f
CB		 5091 if (stdio)
5092 f = PerlIO_fdopen(fileno(stdio), "w+");
5093
2941a2e1
JH		 5094#endif /* else WIN32 */
5095 return f;
760ac839
LW		 5096}
5097
0ea86a10
FC		 5098void
5099Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5100{
e9b8343f 5101 PERL_UNUSED_CONTEXT;
0ea86a10
FC		 5102 if (!PerlIOValid(f))
5103 return;
5104 PerlIOBase(f)->err = errno;
5105#ifdef VMS
5106 PerlIOBase(f)->os_err = vaxc$errno;
5107#elif defined(OS2)
5108 PerlIOBase(f)->os_err = Perl_rc;
5109#elif defined(WIN32)
5110 PerlIOBase(f)->os_err = GetLastError();
5111#endif
5112}
5113
5114void
5115Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5116{
e9b8343f 5117 PERL_UNUSED_CONTEXT;
0ea86a10
FC		 5118 if (!PerlIOValid(f))
5119 return;
5120 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5121#ifdef OS2
5122 Perl_rc = PerlIOBase(f)->os_err);
5123#elif defined(WIN32)
5124 SetLastError(PerlIOBase(f)->os_err);
5125#endif
5126}
5127
6f9d8c32
NIS		 5128#undef HAS_FSETPOS
5129#undef HAS_FGETPOS
5130
760ac839 5131
9e353e3b 5132/*======================================================================================*/
14a5cf38 5133/*
71200d45
NIS		 5134 * Now some functions in terms of above which may be needed even if we are
5135 * not in true PerlIO mode
9e353e3b 5136 */
188f0c84
YO		 5137const char *
5138Perl_PerlIO_context_layers(pTHX_ const char *mode)
5139{
8b850bd5
NC		 5140 const char *direction = NULL;
5141 SV *layers;
188f0c84
YO		 5142 /*
5143 * Need to supply default layer info from open.pm
5144 */
8b850bd5
NC		 5145
5146 if (!PL_curcop)
5147 return NULL;
5148
5149 if (mode && mode[0] != 'r') {
5150 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5151 direction = "open>";
5152 } else {
5153 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5154 direction = "open<";
188f0c84 5155 }
8b850bd5
NC		 5156 if (!direction)
5157 return NULL;
5158
20439bc7 5159 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
8b850bd5
NC		 5160
5161 assert(layers);
5162 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
188f0c84
YO		 5163}
5164
9e353e3b 5165
760ac839 5166#ifndef HAS_FSETPOS
d0e4ea4d 5167# undef PerlIO_setpos
760ac839 5168int
766a733e 5169PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 5170{
14a5cf38 5171 if (SvOK(pos)) {
e1a83e70
DD		 5172 if (f) {
5173 dTHX;
5174 STRLEN len;
5175 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5176 if(len == sizeof(Off_t))
5177 return PerlIO_seek(f, *posn, SEEK_SET);
5178 }
14a5cf38 5179 }
93189314 5180 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5181 return -1;
760ac839 5182}
c411622e 5183#else
d0e4ea4d 5184# undef PerlIO_setpos
c411622e 5185int
766a733e 5186PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 5187{
14a5cf38 5188 if (SvOK(pos)) {
e1a83e70
DD		 5189 if (f) {
5190 dTHX;
5191 STRLEN len;
5192 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5193 if(len == sizeof(Fpos_t))
d0e4ea4d 5194# if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
e1a83e70 5195 return fsetpos64(f, fpos);
d0e4ea4d 5196# else
e1a83e70 5197 return fsetpos(f, fpos);
d0e4ea4d 5198# endif
14a5cf38 5199 }
766a733e 5200 }
93189314 5201 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5202 return -1;
c411622e 5203}
5204#endif
760ac839
LW		 5205
5206#ifndef HAS_FGETPOS
d0e4ea4d 5207# undef PerlIO_getpos
760ac839 5208int
766a733e 5209PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 5210{
14a5cf38
JH		 5211 dTHX;
5212 Off_t posn = PerlIO_tell(f);
5213 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5214 return (posn == (Off_t) - 1) ? -1 : 0;
760ac839 5215}
c411622e 5216#else
d0e4ea4d 5217# undef PerlIO_getpos
c411622e 5218int
766a733e 5219PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 5220{
14a5cf38
JH		 5221 dTHX;
5222 Fpos_t fpos;
5223 int code;
d0e4ea4d 5224# if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 5225 code = fgetpos64(f, &fpos);
d0e4ea4d 5226# else
14a5cf38 5227 code = fgetpos(f, &fpos);
d0e4ea4d 5228# endif
14a5cf38
JH		 5229 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5230 return code;
c411622e 5231}
5232#endif
760ac839 5233
db6e00bd
DD		 5234/* print a failure format string message to stderr and fail exit the process
5235 using only libc without depending on any perl data structures being
5236 initialized.
5237*/
5238
5239void
5240Perl_noperl_die(const char* pat, ...)
5241{
fc917fff 5242 va_list arglist;
db6e00bd
DD		 5243 PERL_ARGS_ASSERT_NOPERL_DIE;
5244 va_start(arglist, pat);
5245 vfprintf(stderr, pat, arglist);
5246 va_end(arglist);
5247 exit(1);
5248}
5249
9cfa90c0 5250/*
14d04a33 5251 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5252 */
Unnamed repository; edit this file 'description' to name the repository.