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
remove unused perldelta sections
[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
NIS		 28#ifdef PERL_IMPLICIT_SYS
29#define dSYS dTHX
30#else
31#define dSYS dNOOP
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
CL		 45#ifdef PERL_IMPLICIT_CONTEXT
46#undef dSYS
47#define dSYS dTHX
48#endif
49
0c4f7ff0
NIS		 50#include "XSUB.h"
51
25bbd826
CB		 52#ifdef VMS
53#include <rms.h>
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);
71ab4674
SP		 126#ifdef NETWARE
127 if (PerlLIO_setmode(fp, mode) != -1) {
128#else
129 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
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
22569500 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';
43e5477e 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{
a0fd4948 239#if defined(PERL_MICRO) || defined(__SYMBIAN32__)
0553478e 240 return NULL;
faf55891 241#elif defined(PERL_IMPLICIT_SYS)
22569500 242 return PerlSIO_fdupopen(f);
0553478e 243#else
faf55891 244# ifdef WIN32
30753f56 245 return win32_fdupopen(f);
faf55891 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];
faf55891 251# ifdef DJGPP
dcda55fc 252 const int omode = djgpp_get_stream_mode(f);
faf55891 253# else
dcda55fc 254 const int omode = fcntl(fd, F_GETFL);
faf55891 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 }
faf55891 265# endif
e0fa5af2 266 return NULL;
0553478e 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;
dd791c72
JH		 418#ifndef PERL_IMPLICIT_SYS
419 PERL_UNUSED_CONTEXT;
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));
2f8118af 1069#if 0
14a5cf38 1070 osLayer = &PerlIO_win32;
0c4128ad 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) {
1493 if ((f = PerlIO_tmpfile())) {
9fe371da 1494 if (!layers || !*layers)
11bcd5da 1495 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH		 1496 if (layers && *layers)
1497 PerlIO_apply_layers(aTHX_ f, mode, layers);
1498 }
1499 }
1500 else {
de009b76 1501 PerlIO_list_t *layera;
14a5cf38
JH		 1502 IV n;
1503 PerlIO_funcs *tab = NULL;
04892f78 1504 if (PerlIOValid(f)) {
14a5cf38 1505 /*
71200d45
NIS		 1506 * This is "reopen" - it is not tested as perl does not use it
1507 * yet
14a5cf38
JH		 1508 */
1509 PerlIOl *l = *f;
3a1ee7e8 1510 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1511 while (l) {
a951d81d 1512 SV *arg = NULL;
cc6623a8 1513 if (l->tab && l->tab->Getarg)
a951d81d
BL		 1514 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1515 PerlIO_list_push(aTHX_ layera, l->tab,
1516 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1517 SvREFCNT_dec(arg);
14a5cf38
JH		 1518 l = *PerlIONext(&l);
1519 }
1520 }
1521 else {
1522 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS		 1523 if (!layera) {
1524 return NULL;
1525 }
14a5cf38
JH		 1526 }
1527 /*
71200d45 1528 * Start at "top" of layer stack
14a5cf38
JH		 1529 */
1530 n = layera->cur - 1;
1531 while (n >= 0) {
46c461b5 1532 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH		 1533 if (t && t->Open) {
1534 tab = t;
1535 break;
1536 }
1537 n--;
1538 }
1539 if (tab) {
1540 /*
71200d45 1541 * Found that layer 'n' can do opens - call it
14a5cf38 1542 */
7cf31beb 1543 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1544 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1545 }
e17bc05a
TC		 1546 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1547 tab->name, layers ? layers : "(Null)", mode, fd,
1548 imode, perm, (void*)f, narg, (void*)args) );
210e727c
JH		 1549 if (tab->Open)
1550 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1551 f, narg, args);
1552 else {
1553 SETERRNO(EINVAL, LIB_INVARG);
1554 f = NULL;
1555 }
14a5cf38
JH		 1556 if (f) {
1557 if (n + 1 < layera->cur) {
1558 /*
1559 * More layers above the one that we used to open -
71200d45 1560 * apply them now
14a5cf38 1561 */
d9dac8cd
NIS		 1562 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1563 /* If pushing layers fails close the file */
1564 PerlIO_close(f);
14a5cf38
JH		 1565 f = NULL;
1566 }
1567 }
1568 }
1569 }
3a1ee7e8 1570 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH		 1571 }
1572 return f;
ee518936 1573}
b931b1d9
NIS		 1574
1575
9e353e3b 1576SSize_t
e87a358a 1577Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1578{
7918f24d
NC		 1579 PERL_ARGS_ASSERT_PERLIO_READ;
1580
b32dd47e 1581 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1582}
1583
313ca112 1584SSize_t
e87a358a 1585Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1586{
7918f24d
NC		 1587 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1588
b32dd47e 1589 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1590}
1591
9e353e3b 1592SSize_t
e87a358a 1593Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1594{
7918f24d
NC		 1595 PERL_ARGS_ASSERT_PERLIO_WRITE;
1596
b32dd47e 1597 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1598}
1599
6f9d8c32 1600int
e87a358a 1601Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1602{
b32dd47e 1603 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW		 1604}
1605
9e353e3b 1606Off_t
e87a358a 1607Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1608{
b32dd47e 1609 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW		 1610}
1611
6f9d8c32 1612int
e87a358a 1613Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1614{
14a5cf38
JH		 1615 if (f) {
1616 if (*f) {
de009b76 1617 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1618
1619 if (tab && tab->Flush)
f62ce20a 1620 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH		 1621 else
1622 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH		 1623 }
1624 else {
e17bc05a 1625 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
93189314 1626 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH		 1627 return -1;
1628 }
1629 }
1630 else {
1631 /*
1632 * Is it good API design to do flush-all on NULL, a potentially
486ec47a 1633 * erroneous input? Maybe some magical value (PerlIO*
14a5cf38
JH		 1634 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1635 * things on fflush(NULL), but should we be bound by their design
71200d45 1636 * decisions? --jhi
14a5cf38 1637 */
303f2dc3
DM		 1638 PerlIOl **table = &PL_perlio;
1639 PerlIOl *ff;
14a5cf38 1640 int code = 0;
303f2dc3 1641 while ((ff = *table)) {
14a5cf38 1642 int i;
303f2dc3 1643 table = (PerlIOl **) (ff++);
14a5cf38 1644 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 1645 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
14a5cf38 1646 code = -1;
303f2dc3 1647 ff++;
14a5cf38
JH		 1648 }
1649 }
1650 return code;
1651 }
760ac839
LW		 1652}
1653
a9c883f6 1654void
f62ce20a 1655PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1656{
303f2dc3
DM		 1657 PerlIOl **table = &PL_perlio;
1658 PerlIOl *f;
14a5cf38
JH		 1659 while ((f = *table)) {
1660 int i;
303f2dc3 1661 table = (PerlIOl **) (f++);
14a5cf38 1662 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM		 1663 if (f->next
1664 && (PerlIOBase(&(f->next))->
14a5cf38
JH		 1665 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1666 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
303f2dc3 1667 PerlIO_flush(&(f->next));
14a5cf38
JH		 1668 f++;
1669 }
a9c883f6 1670 }
a9c883f6
NIS		 1671}
1672
06da4f11 1673int
e87a358a 1674Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1675{
b32dd47e 1676 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS		 1677}
1678
f3862f8b
NIS		 1679int
1680PerlIO_isutf8(PerlIO *f)
1681{
1b7a0411
JH		 1682 if (PerlIOValid(f))
1683 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1684 else
1685 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1686
1b7a0411 1687 return -1;
f3862f8b
NIS		 1688}
1689
6f9d8c32 1690int
e87a358a 1691Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1692{
b32dd47e 1693 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS		 1694}
1695
9e353e3b 1696int
e87a358a 1697Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1698{
b32dd47e 1699 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS		 1700}
1701
9e353e3b 1702void
e87a358a 1703Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1704{
b32dd47e 1705 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS		 1706}
1707
9e353e3b 1708void
e87a358a 1709Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1710{
b32dd47e 1711 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS		 1712}
1713
9e353e3b
NIS		 1714int
1715PerlIO_has_base(PerlIO *f)
1716{
1b7a0411 1717 if (PerlIOValid(f)) {
46c461b5 1718 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1719
1720 if (tab)
1721 return (tab->Get_base != NULL);
1b7a0411 1722 }
1b7a0411
JH		 1723
1724 return 0;
760ac839
LW		 1725}
1726
9e353e3b
NIS		 1727int
1728PerlIO_fast_gets(PerlIO *f)
760ac839 1729{
d7dfc388
SK		 1730 if (PerlIOValid(f)) {
1731 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1732 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411 1733
d7dfc388
SK		 1734 if (tab)
1735 return (tab->Set_ptrcnt != NULL);
d7dfc388 1736 }
14a5cf38 1737 }
1b7a0411 1738
14a5cf38 1739 return 0;
9e353e3b
NIS		 1740}
1741
9e353e3b
NIS		 1742int
1743PerlIO_has_cntptr(PerlIO *f)
1744{
04892f78 1745 if (PerlIOValid(f)) {
46c461b5 1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1747
1748 if (tab)
1749 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
14a5cf38 1750 }
1b7a0411 1751
14a5cf38 1752 return 0;
9e353e3b
NIS		 1753}
1754
9e353e3b
NIS		 1755int
1756PerlIO_canset_cnt(PerlIO *f)
1757{
04892f78 1758 if (PerlIOValid(f)) {
46c461b5 1759 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH		 1760
1761 if (tab)
1762 return (tab->Set_ptrcnt != NULL);
14a5cf38 1763 }
1b7a0411 1764
14a5cf38 1765 return 0;
760ac839
LW		 1766}
1767
888911fc 1768STDCHAR *
e87a358a 1769Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1770{
b32dd47e 1771 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS		 1772}
1773
b66f3475 1774SSize_t
e87a358a 1775Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1776{
b66f3475 1777 /* Note that Get_bufsiz returns a Size_t */
b32dd47e 1778 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS		 1779}
1780
9e353e3b 1781STDCHAR *
e87a358a 1782Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1783{
b32dd47e 1784 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS		 1785}
1786
b66f3475 1787SSize_t
e87a358a 1788Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1789{
b32dd47e 1790 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS		 1791}
1792
9e353e3b 1793void
b66f3475 1794Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
9e353e3b 1795{
b32dd47e 1796 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS		 1797}
1798
9e353e3b 1799void
b66f3475 1800Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 1801{
b32dd47e 1802 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS		 1803}
1804
4ec2216f 1805
9e353e3b 1806/*--------------------------------------------------------------------------------------*/
14a5cf38 1807/*
71200d45 1808 * utf8 and raw dummy layers
14a5cf38 1809 */
dfebf958 1810
26fb694e 1811IV
2dc2558e 1812PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1813{
96a5add6 1814 PERL_UNUSED_CONTEXT;
8772537c
AL		 1815 PERL_UNUSED_ARG(mode);
1816 PERL_UNUSED_ARG(arg);
00f51856 1817 if (PerlIOValid(f)) {
cc6623a8 1818 if (tab && tab->kind & PERLIO_K_UTF8)
14a5cf38
JH		 1819 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1820 else
1821 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1822 return 0;
1823 }
1824 return -1;
26fb694e
NIS		 1825}
1826
27da23d5 1827PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1828 sizeof(PerlIO_funcs),
14a5cf38 1829 "utf8",
2dc2558e 1830 0,
a778d1f5 1831 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
14a5cf38
JH		 1832 PerlIOUtf8_pushed,
1833 NULL,
c0888ace 1834 PerlIOBase_open,
14a5cf38
JH		 1835 NULL,
1836 NULL,
1837 NULL,
1838 NULL,
1839 NULL,
1840 NULL,
1841 NULL,
1842 NULL,
de009b76
AL		 1843 NULL,
1844 NULL,
22569500
NIS		 1845 NULL, /* flush */
1846 NULL, /* fill */
14a5cf38
JH		 1847 NULL,
1848 NULL,
1849 NULL,
1850 NULL,
22569500
NIS		 1851 NULL, /* get_base */
1852 NULL, /* get_bufsiz */
1853 NULL, /* get_ptr */
1854 NULL, /* get_cnt */
1855 NULL, /* set_ptrcnt */
26fb694e
NIS		 1856};
1857
27da23d5 1858PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1859 sizeof(PerlIO_funcs),
14a5cf38 1860 "bytes",
2dc2558e 1861 0,
a778d1f5 1862 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
14a5cf38
JH		 1863 PerlIOUtf8_pushed,
1864 NULL,
c0888ace 1865 PerlIOBase_open,
14a5cf38
JH		 1866 NULL,
1867 NULL,
1868 NULL,
1869 NULL,
1870 NULL,
1871 NULL,
1872 NULL,
1873 NULL,
de009b76
AL		 1874 NULL,
1875 NULL,
22569500
NIS		 1876 NULL, /* flush */
1877 NULL, /* fill */
14a5cf38
JH		 1878 NULL,
1879 NULL,
1880 NULL,
1881 NULL,
22569500
NIS		 1882 NULL, /* get_base */
1883 NULL, /* get_bufsiz */
1884 NULL, /* get_ptr */
1885 NULL, /* get_cnt */
1886 NULL, /* set_ptrcnt */
dfebf958
NIS		 1887};
1888
27da23d5 1889PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 1890 sizeof(PerlIO_funcs),
14a5cf38 1891 "raw",
2dc2558e 1892 0,
14a5cf38
JH		 1893 PERLIO_K_DUMMY,
1894 PerlIORaw_pushed,
1895 PerlIOBase_popped,
ecfd0649 1896 PerlIOBase_open,
14a5cf38
JH		 1897 NULL,
1898 NULL,
1899 NULL,
1900 NULL,
1901 NULL,
1902 NULL,
1903 NULL,
1904 NULL,
de009b76
AL		 1905 NULL,
1906 NULL,
22569500
NIS		 1907 NULL, /* flush */
1908 NULL, /* fill */
14a5cf38
JH		 1909 NULL,
1910 NULL,
1911 NULL,
1912 NULL,
22569500
NIS		 1913 NULL, /* get_base */
1914 NULL, /* get_bufsiz */
1915 NULL, /* get_ptr */
1916 NULL, /* get_cnt */
1917 NULL, /* set_ptrcnt */
dfebf958
NIS		 1918};
1919/*--------------------------------------------------------------------------------------*/
1920/*--------------------------------------------------------------------------------------*/
14a5cf38 1921/*
71200d45 1922 * "Methods" of the "base class"
14a5cf38 1923 */
9e353e3b
NIS		 1924
1925IV
f62ce20a 1926PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 1927{
04892f78 1928 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS		 1929}
1930
f5b9d040 1931char *
81428673 1932PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH		 1933{
1934 char *s = buf;
81428673 1935 if (PerlIOValid(f)) {
de009b76 1936 const IV flags = PerlIOBase(f)->flags;
81428673
NIS		 1937 if (flags & PERLIO_F_APPEND) {
1938 *s++ = 'a';
1939 if (flags & PERLIO_F_CANREAD) {
1940 *s++ = '+';
1941 }
14a5cf38 1942 }
81428673
NIS		 1943 else if (flags & PERLIO_F_CANREAD) {
1944 *s++ = 'r';
1945 if (flags & PERLIO_F_CANWRITE)
1946 *s++ = '+';
1947 }
1948 else if (flags & PERLIO_F_CANWRITE) {
1949 *s++ = 'w';
1950 if (flags & PERLIO_F_CANREAD) {
1951 *s++ = '+';
1952 }
14a5cf38 1953 }
35990314 1954#ifdef PERLIO_USING_CRLF
81428673
NIS		 1955 if (!(flags & PERLIO_F_CRLF))
1956 *s++ = 'b';
5f1a76d0 1957#endif
81428673 1958 }
14a5cf38
JH		 1959 *s = '\0';
1960 return buf;
f5b9d040
NIS		 1961}
1962
81428673 1963
76ced9ad 1964IV
2dc2558e 1965PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 1966{
de009b76 1967 PerlIOl * const l = PerlIOBase(f);
96a5add6 1968 PERL_UNUSED_CONTEXT;
8772537c 1969 PERL_UNUSED_ARG(arg);
de009b76 1970
14a5cf38
JH		 1971 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1972 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
cc6623a8 1973 if (tab && tab->Set_ptrcnt != NULL)
14a5cf38
JH		 1974 l->flags |= PERLIO_F_FASTGETS;
1975 if (mode) {
3b6c1aba 1976 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH		 1977 mode++;
1978 switch (*mode++) {
1979 case 'r':
1980 l->flags |= PERLIO_F_CANREAD;
1981 break;
1982 case 'a':
1983 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1984 break;
1985 case 'w':
1986 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1987 break;
1988 default:
93189314 1989 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 1990 return -1;
1991 }
49fc4906
YK		 1992#ifdef EBCDIC
1993 {
1994 /* The mode variable contains one positional parameter followed by
1995 * optional keyword parameters. The positional parameters must be
1996 * passed as lowercase characters. The keyword parameters can be
1997 * passed in mixed case. They must be separated by commas. Only one
1998 * instance of a keyword can be specified. */
1999 int comma = 0;
2000 while (*mode) {
2001 switch (*mode++) {
2002 case '+':
2003 if(!comma)
2004 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2005 break;
2006 case 'b':
2007 if(!comma)
2008 l->flags &= ~PERLIO_F_CRLF;
2009 break;
2010 case 't':
2011 if(!comma)
2012 l->flags |= PERLIO_F_CRLF;
2013 break;
2014 case ',':
2015 comma = 1;
2016 break;
2017 default:
2018 break;
2019 }
2020 }
2021 }
2022#else
14a5cf38
JH		 2023 while (*mode) {
2024 switch (*mode++) {
2025 case '+':
2026 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2027 break;
2028 case 'b':
2029 l->flags &= ~PERLIO_F_CRLF;
2030 break;
2031 case 't':
2032 l->flags |= PERLIO_F_CRLF;
2033 break;
2034 default:
93189314 2035 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2036 return -1;
2037 }
2038 }
49fc4906 2039#endif
14a5cf38
JH		 2040 }
2041 else {
2042 if (l->next) {
2043 l->flags |= l->next->flags &
2044 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2045 PERLIO_F_APPEND);
2046 }
2047 }
5e2ab84b 2048#if 0
e17bc05a 2049 DEBUG_i(
14a5cf38 2050 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
6c9570dc 2051 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
14a5cf38 2052 l->flags, PerlIO_modestr(f, temp));
e17bc05a 2053 );
5e2ab84b 2054#endif
14a5cf38 2055 return 0;
76ced9ad
NIS		 2056}
2057
2058IV
f62ce20a 2059PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2060{
96a5add6 2061 PERL_UNUSED_CONTEXT;
8772537c 2062 PERL_UNUSED_ARG(f);
14a5cf38 2063 return 0;
760ac839
LW		 2064}
2065
9e353e3b 2066SSize_t
f62ce20a 2067PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2068{
14a5cf38 2069 /*
71200d45 2070 * Save the position as current head considers it
14a5cf38 2071 */
de009b76 2072 const Off_t old = PerlIO_tell(f);
a0714e2c 2073 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2074 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2075 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS		 2076}
2077
f6c77cf1 2078SSize_t
f62ce20a 2079PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2080{
14a5cf38
JH		 2081 STDCHAR *buf = (STDCHAR *) vbuf;
2082 if (f) {
263df5f1
JH		 2083 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2084 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2085 SETERRNO(EBADF, SS_IVCHAN);
0ea86a10 2086 PerlIO_save_errno(f);
263df5f1
JH		 2087 return 0;
2088 }
14a5cf38 2089 while (count > 0) {
93c2c2ec
IZ		 2090 get_cnt:
2091 {
14a5cf38
JH		 2092 SSize_t avail = PerlIO_get_cnt(f);
2093 SSize_t take = 0;
2094 if (avail > 0)
94e529cc 2095 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
14a5cf38
JH		 2096 if (take > 0) {
2097 STDCHAR *ptr = PerlIO_get_ptr(f);
2098 Copy(ptr, buf, take, STDCHAR);
2099 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2100 count -= take;
2101 buf += take;
93c2c2ec
IZ		 2102 if (avail == 0) /* set_ptrcnt could have reset avail */
2103 goto get_cnt;
14a5cf38
JH		 2104 }
2105 if (count > 0 && avail <= 0) {
2106 if (PerlIO_fill(f) != 0)
2107 break;
2108 }
93c2c2ec 2109 }
14a5cf38
JH		 2110 }
2111 return (buf - (STDCHAR *) vbuf);
2112 }
f6c77cf1 2113 return 0;
f6c77cf1
NIS		 2114}
2115
9e353e3b 2116IV
f62ce20a 2117PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2118{
96a5add6 2119 PERL_UNUSED_CONTEXT;
8772537c 2120 PERL_UNUSED_ARG(f);
14a5cf38 2121 return 0;
9e353e3b
NIS		 2122}
2123
2124IV
f62ce20a 2125PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2126{
96a5add6 2127 PERL_UNUSED_CONTEXT;
8772537c 2128 PERL_UNUSED_ARG(f);
14a5cf38 2129 return -1;
06da4f11
NIS		 2130}
2131
2132IV
f62ce20a 2133PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2134{
37725cdc
NIS		 2135 IV code = -1;
2136 if (PerlIOValid(f)) {
2137 PerlIO *n = PerlIONext(f);
2138 code = PerlIO_flush(f);
2139 PerlIOBase(f)->flags &=
2140 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2141 while (PerlIOValid(n)) {
de009b76 2142 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS		 2143 if (tab && tab->Close) {
2144 if ((*tab->Close)(aTHX_ n) != 0)
2145 code = -1;
2146 break;
2147 }
2148 else {
2149 PerlIOBase(n)->flags &=
2150 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2151 }
2152 n = PerlIONext(n);
2153 }
2154 }
2155 else {
2156 SETERRNO(EBADF, SS_IVCHAN);
2157 }
14a5cf38 2158 return code;
9e353e3b
NIS		 2159}
2160
2161IV
f62ce20a 2162PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2163{
96a5add6 2164 PERL_UNUSED_CONTEXT;
04892f78 2165 if (PerlIOValid(f)) {
14a5cf38
JH		 2166 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2167 }
2168 return 1;
9e353e3b
NIS		 2169}
2170
2171IV
f62ce20a 2172PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2173{
96a5add6 2174 PERL_UNUSED_CONTEXT;
04892f78 2175 if (PerlIOValid(f)) {
14a5cf38
JH		 2176 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2177 }
2178 return 1;
9e353e3b
NIS		 2179}
2180
2181void
f62ce20a 2182PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2183{
04892f78 2184 if (PerlIOValid(f)) {
dcda55fc 2185 PerlIO * const n = PerlIONext(f);
14a5cf38 2186 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2187 if (PerlIOValid(n))
14a5cf38
JH		 2188 PerlIO_clearerr(n);
2189 }
9e353e3b
NIS		 2190}
2191
2192void
f62ce20a 2193PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2194{
96a5add6 2195 PERL_UNUSED_CONTEXT;
04892f78 2196 if (PerlIOValid(f)) {
14a5cf38
JH		 2197 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2198 }
9e353e3b
NIS		 2199}
2200
93a8090d
NIS		 2201SV *
2202PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2203{
2204 if (!arg)
a0714e2c 2205 return NULL;
24d147a6 2206#ifdef USE_ITHREADS
93a8090d 2207 if (param) {
a951d81d
BL		 2208 arg = sv_dup(arg, param);
2209 SvREFCNT_inc_simple_void_NN(arg);
2210 return arg;
93a8090d
NIS		 2211 }
2212 else {
2213 return newSVsv(arg);
2214 }
2215#else
1b6737cc 2216 PERL_UNUSED_ARG(param);
93a8090d
NIS		 2217 return newSVsv(arg);
2218#endif
2219}
2220
2221PerlIO *
ecdeb87c 2222PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2223{
1b6737cc 2224 PerlIO * const nexto = PerlIONext(o);
04892f78 2225 if (PerlIOValid(nexto)) {
de009b76 2226 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS		 2227 if (tab && tab->Dup)
2228 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2229 else
2230 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS		 2231 }
2232 if (f) {
dcda55fc 2233 PerlIO_funcs * const self = PerlIOBase(o)->tab;
a951d81d 2234 SV *arg = NULL;
93a8090d 2235 char buf[8];
316ebaf2 2236 assert(self);
e17bc05a
TC		 2237 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2238 self->name,
2239 (void*)f, (void*)o, (void*)param) );
27e6dabe
JH		 2240 if (self->Getarg)
2241 arg = (*self->Getarg)(aTHX_ o, param, flags);
93a8090d 2242 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
df8c7dee 2243 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
f0720f70 2244 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
ef8d46e8 2245 SvREFCNT_dec(arg);
93a8090d
NIS		 2246 }
2247 return f;
2248}
2249
27da23d5 2250/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d 2251
8b84d7dd 2252/* Must be called with PL_perlio_mutex locked. */
22c96fc1 2253static void
ff25d7bc
JH		 2254S_more_refcounted_fds(pTHX_ const int new_fd)
2255 PERL_TSA_REQUIRES(PL_perlio_mutex)
2256{
7a89be66 2257 dVAR;
22c96fc1 2258 const int old_max = PL_perlio_fd_refcnt_size;
f4ae5be6 2259 const int new_max = 16 + (new_fd & ~15);
22c96fc1
NC		 2260 int *new_array;
2261
dd791c72
JH		 2262#ifndef PERL_IMPLICIT_SYS
2263 PERL_UNUSED_CONTEXT;
2264#endif
2265
e17bc05a
TC		 2266 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2267 old_max, new_fd, new_max) );
22c96fc1
NC		 2268
2269 if (new_fd < old_max) {
2270 return;
2271 }
2272
f4ae5be6
NC		 2273 assert (new_max > new_fd);
2274
eae082a0
JH		 2275 /* Use plain realloc() since we need this memory to be really
2276 * global and visible to all the interpreters and/or threads. */
2277 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
22c96fc1
NC		 2278
2279 if (!new_array) {
6cb8cb21 2280 MUTEX_UNLOCK(&PL_perlio_mutex);
4cbe3a7d 2281 croak_no_mem();
22c96fc1
NC		 2282 }
2283
2284 PL_perlio_fd_refcnt_size = new_max;
2285 PL_perlio_fd_refcnt = new_array;
2286
e17bc05a
TC		 2287 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2288 (void*)(new_array + old_max),
2289 new_max - old_max) );
22c96fc1
NC		 2290
2291 Zero(new_array + old_max, new_max - old_max, int);
2292}
2293
2294
93a8090d
NIS		 2295void
2296PerlIO_init(pTHX)
2297{
8b84d7dd 2298 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
96a5add6 2299 PERL_UNUSED_CONTEXT;
93a8090d
NIS		 2300}
2301
168d5872
NIS		 2302void
2303PerlIOUnix_refcnt_inc(int fd)
2304{
27da23d5 2305 dTHX;
22c96fc1 2306 if (fd >= 0) {
97aff369 2307 dVAR;
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;
2336#else
97aff369 2337 dVAR;
e17bc05a 2338#endif
6cb8cb21 2339 MUTEX_LOCK(&PL_perlio_mutex);
8b84d7dd 2340 if (fd >= PL_perlio_fd_refcnt_size) {
12605ff9 2341 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2342 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
8b84d7dd
RGS		 2343 fd, PL_perlio_fd_refcnt_size);
2344 }
2345 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2346 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2347 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
8b84d7dd
RGS		 2348 fd, PL_perlio_fd_refcnt[fd]);
2349 }
27da23d5 2350 cnt = --PL_perlio_fd_refcnt[fd];
e17bc05a 2351 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
6cb8cb21 2352 MUTEX_UNLOCK(&PL_perlio_mutex);
8b84d7dd 2353 } else {
12605ff9 2354 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2355 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
168d5872
NIS		 2356 }
2357 return cnt;
2358}
2359
2e0cfa16
FC		 2360int
2361PerlIOUnix_refcnt(int fd)
2362{
2363 dTHX;
2364 int cnt = 0;
2365 if (fd >= 0) {
2366 dVAR;
2e0cfa16 2367 MUTEX_LOCK(&PL_perlio_mutex);
2e0cfa16
FC		 2368 if (fd >= PL_perlio_fd_refcnt_size) {
2369 /* diag_listed_as: refcnt: fd %d%s */
2370 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2371 fd, PL_perlio_fd_refcnt_size);
2372 }
2373 if (PL_perlio_fd_refcnt[fd] <= 0) {
2374 /* diag_listed_as: refcnt: fd %d%s */
2375 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2376 fd, PL_perlio_fd_refcnt[fd]);
2377 }
2378 cnt = PL_perlio_fd_refcnt[fd];
2e0cfa16 2379 MUTEX_UNLOCK(&PL_perlio_mutex);
2e0cfa16
FC		 2380 } else {
2381 /* diag_listed_as: refcnt: fd %d%s */
2382 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2383 }
2384 return cnt;
2385}
2386
694c95cf
JH		 2387void
2388PerlIO_cleanup(pTHX)
2389{
2390 int i;
2391#ifdef USE_ITHREADS
e17bc05a 2392 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
9f4bd222 2393#else
e17bc05a 2394 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
694c95cf 2395#endif
e47547a8 2396
694c95cf
JH		 2397 /* Raise STDIN..STDERR refcount so we don't close them */
2398 for (i=0; i < 3; i++)
2399 PerlIOUnix_refcnt_inc(i);
2400 PerlIO_cleantable(aTHX_ &PL_perlio);
2401 /* Restore STDIN..STDERR refcount */
2402 for (i=0; i < 3; i++)
2403 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS		 2404
2405 if (PL_known_layers) {
2406 PerlIO_list_free(aTHX_ PL_known_layers);
2407 PL_known_layers = NULL;
2408 }
27da23d5 2409 if (PL_def_layerlist) {
9f4bd222
NIS		 2410 PerlIO_list_free(aTHX_ PL_def_layerlist);
2411 PL_def_layerlist = NULL;
2412 }
6cb8cb21
RGS		 2413}
2414
0934c9d9 2415void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
6cb8cb21 2416{
53d44271 2417 dVAR;
4f3da17a
DM		 2418#if 0
2419/* XXX we can't rely on an interpreter being present at this late stage,
2420 XXX so we can't use a function like PerlLIO_write that relies on one
2421 being present (at least in win32) :-(.
2422 Disable for now.
2423*/
6cb8cb21
RGS		 2424#ifdef DEBUGGING
2425 {
2426 /* By now all filehandles should have been closed, so any
2427 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2428 * errors. */
77db880c
JH		 2429#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2430#define PERLIO_TEARDOWN_MESSAGE_FD 2
2431 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
6cb8cb21
RGS		 2432 int i;
2433 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
77db880c
JH		 2434 if (PL_perlio_fd_refcnt[i]) {
2435 const STRLEN len =
2436 my_snprintf(buf, sizeof(buf),
2437 "PerlIO_teardown: fd %d refcnt=%d\n",
2438 i, PL_perlio_fd_refcnt[i]);
2439 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2440 }
6cb8cb21
RGS		 2441 }
2442 }
2443#endif
4f3da17a 2444#endif
eae082a0
JH		 2445 /* Not bothering with PL_perlio_mutex since by now
2446 * all the interpreters are gone. */
1cd82952
RGS		 2447 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2448 && PL_perlio_fd_refcnt) {
eae082a0 2449 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO		 2450 PL_perlio_fd_refcnt = NULL;
2451 PL_perlio_fd_refcnt_size = 0;
1cd82952 2452 }
694c95cf
JH		 2453}
2454
9e353e3b 2455/*--------------------------------------------------------------------------------------*/
14a5cf38 2456/*
71200d45 2457 * Bottom-most level for UNIX-like case
14a5cf38 2458 */
9e353e3b 2459
14a5cf38 2460typedef struct {
22569500
NIS		 2461 struct _PerlIO base; /* The generic part */
2462 int fd; /* UNIX like file descriptor */
2463 int oflags; /* open/fcntl flags */
9e353e3b
NIS		 2464} PerlIOUnix;
2465
abf9167d
DM		 2466static void
2467S_lockcnt_dec(pTHX_ const void* f)
2468{
dd791c72
JH		 2469#ifndef PERL_IMPLICIT_SYS
2470 PERL_UNUSED_CONTEXT;
2471#endif
abf9167d
DM		 2472 PerlIO_lockcnt((PerlIO*)f)--;
2473}
2474
2475
2476/* call the signal handler, and if that handler happens to clear
2477 * this handle, free what we can and return true */
2478
2479static bool
2480S_perlio_async_run(pTHX_ PerlIO* f) {
2481 ENTER;
2482 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2483 PerlIO_lockcnt(f)++;
2484 PERL_ASYNC_CHECK();
be48bbe8
CS		 2485 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2486 LEAVE;
abf9167d 2487 return 0;
be48bbe8 2488 }
abf9167d
DM		 2489 /* we've just run some perl-level code that could have done
2490 * anything, including closing the file or clearing this layer.
2491 * If so, free any lower layers that have already been
2492 * cleared, then return an error. */
2493 while (PerlIOValid(f) &&
2494 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2495 {
2496 const PerlIOl *l = *f;
2497 *f = l->next;
2498 Safefree(l);
2499 }
be48bbe8 2500 LEAVE;
abf9167d
DM		 2501 return 1;
2502}
2503
6f9d8c32 2504int
9e353e3b 2505PerlIOUnix_oflags(const char *mode)
760ac839 2506{
14a5cf38 2507 int oflags = -1;
3b6c1aba 2508 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH		 2509 mode++;
2510 switch (*mode) {
2511 case 'r':
2512 oflags = O_RDONLY;
2513 if (*++mode == '+') {
2514 oflags = O_RDWR;
2515 mode++;
2516 }
2517 break;
2518
2519 case 'w':
2520 oflags = O_CREAT | O_TRUNC;
2521 if (*++mode == '+') {
2522 oflags |= O_RDWR;
2523 mode++;
2524 }
2525 else
2526 oflags |= O_WRONLY;
2527 break;
2528
2529 case 'a':
2530 oflags = O_CREAT | O_APPEND;
2531 if (*++mode == '+') {
2532 oflags |= O_RDWR;
2533 mode++;
2534 }
2535 else
2536 oflags |= O_WRONLY;
2537 break;
2538 }
43e5477e
JH		 2539
2540 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2541
2542 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2543 * of them in, and then bit-and-masking the other them away, won't
2544 * have much of an effect. */
2545 switch (*mode) {
2546 case 'b':
2547#if O_TEXT != O_BINARY
2548 oflags |= O_BINARY;
14a5cf38 2549 oflags &= ~O_TEXT;
43e5477e
JH		 2550#endif
2551 mode++;
2552 break;
2553 case 't':
2554#if O_TEXT != O_BINARY
14a5cf38
JH		 2555 oflags |= O_TEXT;
2556 oflags &= ~O_BINARY;
43e5477e
JH		 2557#endif
2558 mode++;
2559 break;
2560 default:
2561# if O_BINARY != 0
2562 /* bit-or:ing with zero O_BINARY would be useless. */
93f31ee9
PG		 2563 /*
2564 * If neither "t" nor "b" was specified, open the file
2565 * in O_BINARY mode.
43e5477e
JH		 2566 *
2567 * Note that if something else than the zero byte was seen
2568 * here (e.g. bogus mode "rx"), just few lines later we will
2569 * set the errno and invalidate the flags.
93f31ee9
PG		 2570 */
2571 oflags |= O_BINARY;
43e5477e
JH		 2572# endif
2573 break;
93f31ee9 2574 }
14a5cf38 2575 if (*mode || oflags == -1) {
93189314 2576 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2577 oflags = -1;
2578 }
2579 return oflags;
9e353e3b
NIS		 2580}
2581
2582IV
f62ce20a 2583PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2584{
96a5add6 2585 PERL_UNUSED_CONTEXT;
14a5cf38 2586 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS		 2587}
2588
aa063c35
NIS		 2589static void
2590PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2591{
de009b76 2592 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2593#if defined(WIN32)
aa063c35
NIS		 2594 Stat_t st;
2595 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2596 if (!S_ISREG(st.st_mode)) {
e17bc05a 2597 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
6caa5a9c
NIS		 2598 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2599 }
aa063c35 2600 else {
e17bc05a 2601 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
aa063c35 2602 }
6caa5a9c
NIS		 2603 }
2604#endif
aa063c35
NIS		 2605 s->fd = fd;
2606 s->oflags = imode;
2607 PerlIOUnix_refcnt_inc(fd);
96a5add6 2608 PERL_UNUSED_CONTEXT;
aa063c35
NIS		 2609}
2610
2611IV
2612PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2613{
2614 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2615 if (*PerlIONext(f)) {
4b069b44 2616 /* We never call down so do any pending stuff now */
03c0554d 2617 PerlIO_flush(PerlIONext(f));
14a5cf38 2618 /*
71200d45 2619 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2620 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2621 * Should the value on NULL mode be 0 or -1?
14a5cf38 2622 */
acbd16bf 2623 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2624 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH		 2625 }
2626 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2627
14a5cf38 2628 return code;
4b803d04
NIS		 2629}
2630
c2fcde81
JH		 2631IV
2632PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2633{
de009b76 2634 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2635 Off_t new_loc;
96a5add6 2636 PERL_UNUSED_CONTEXT;
c2fcde81
JH		 2637 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2638#ifdef ESPIPE
2639 SETERRNO(ESPIPE, LIB_INVARG);
2640#else
2641 SETERRNO(EINVAL, LIB_INVARG);
2642#endif
2643 return -1;
2644 }
0723351e
NC		 2645 new_loc = PerlLIO_lseek(fd, offset, whence);
2646 if (new_loc == (Off_t) - 1)
dcda55fc 2647 return -1;
c2fcde81
JH		 2648 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2649 return 0;
2650}
2651
9e353e3b 2652PerlIO *
14a5cf38
JH		 2653PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2654 IV n, const char *mode, int fd, int imode,
2655 int perm, PerlIO *f, int narg, SV **args)
2656{
884fc2d3 2657 bool known_cloexec = 0;
d9dac8cd 2658 if (PerlIOValid(f)) {
cc6623a8 2659 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2660 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH		 2661 }
2662 if (narg > 0) {
3b6c1aba 2663 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH		 2664 mode++;
2665 else {
2666 imode = PerlIOUnix_oflags(mode);
5e2ce0f3
CB		 2667#ifdef VMS
2668 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2669#else
14a5cf38 2670 perm = 0666;
5e2ce0f3 2671#endif
14a5cf38
JH		 2672 }
2673 if (imode != -1) {
41188aa0
TC		 2674 STRLEN len;
2675 const char *path = SvPV_const(*args, len);
2676 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 2677 return NULL;
884fc2d3
Z		 2678 fd = PerlLIO_open3_cloexec(path, imode, perm);
2679 known_cloexec = 1;
14a5cf38
JH		 2680 }
2681 }
2682 if (fd >= 0) {
884fc2d3
Z		 2683 if (known_cloexec)
2684 setfd_inhexec_for_sysfd(fd);
2685 else
2686 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3b6c1aba 2687 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH		 2688 mode++;
2689 if (!f) {
2690 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS		 2691 }
2692 if (!PerlIOValid(f)) {
a33cf58c 2693 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
0a20f69b 2694 PerlLIO_close(fd);
a33cf58c
NIS		 2695 return NULL;
2696 }
d9dac8cd 2697 }
aa063c35 2698 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2699 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH		 2700 if (*mode == IoTYPE_APPEND)
2701 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH		 2702 return f;
2703 }
2704 else {
2705 if (f) {
6f207bd3 2706 NOOP;
14a5cf38 2707 /*
71200d45 2708 * FIXME: pop layers ???
14a5cf38
JH		 2709 */
2710 }
2711 return NULL;
2712 }
9e353e3b
NIS		 2713}
2714
71200d45 2715PerlIO *
ecdeb87c 2716PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2717{
dcda55fc 2718 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2719 int fd = os->fd;
ecdeb87c 2720 if (flags & PERLIO_DUP_FD) {
884fc2d3
Z		 2721 fd = PerlLIO_dup_cloexec(fd);
2722 if (fd >= 0)
2723 setfd_inhexec_for_sysfd(fd);
ecdeb87c 2724 }
22c96fc1 2725 if (fd >= 0) {
ecdeb87c 2726 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 2727 if (f) {
2728 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2729 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS		 2730 return f;
2731 }
0a20f69b 2732 PerlLIO_close(fd);
71200d45
NIS		 2733 }
2734 return NULL;
2735}
2736
2737
9e353e3b 2738SSize_t
f62ce20a 2739PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2740{
abf9167d
DM		 2741 int fd;
2742 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2743 return -1;
2744 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH		 2745#ifdef PERLIO_STD_SPECIAL
2746 if (fd == 0)
2747 return PERLIO_STD_IN(fd, vbuf, count);
2748#endif
81428673 2749 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2750 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2751 return 0;
1fd8f4ce 2752 }
14a5cf38 2753 while (1) {
b464bac0 2754 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2755 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS		 2756 if (len < 0) {
2757 if (errno != EAGAIN) {
2758 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 2759 PerlIO_save_errno(f);
ba85f2ea
NIS		 2760 }
2761 }
2762 else if (len == 0 && count != 0) {
14a5cf38 2763 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS		 2764 SETERRNO(0,0);
2765 }
14a5cf38
JH		 2766 return len;
2767 }
abf9167d
DM		 2768 /* EINTR */
2769 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2770 return -1;
14a5cf38 2771 }
e5964223 2772 NOT_REACHED; /*NOTREACHED*/
9e353e3b
NIS		 2773}
2774
2775SSize_t
f62ce20a 2776PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2777{
abf9167d
DM		 2778 int fd;
2779 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2780 return -1;
2781 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH		 2782#ifdef PERLIO_STD_SPECIAL
2783 if (fd == 1 || fd == 2)
2784 return PERLIO_STD_OUT(fd, vbuf, count);
2785#endif
14a5cf38 2786 while (1) {
de009b76 2787 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2788 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS		 2789 if (len < 0) {
2790 if (errno != EAGAIN) {
2791 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 2792 PerlIO_save_errno(f);
ba85f2ea
NIS		 2793 }
2794 }
14a5cf38
JH		 2795 return len;
2796 }
abf9167d
DM		 2797 /* EINTR */
2798 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2799 return -1;
06da4f11 2800 }
e5964223 2801 NOT_REACHED; /*NOTREACHED*/
9e353e3b
NIS		 2802}
2803
9e353e3b 2804Off_t
f62ce20a 2805PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2806{
96a5add6
AL		 2807 PERL_UNUSED_CONTEXT;
2808
14a5cf38 2809 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS		 2810}
2811
2556f95e
GF		 2812
2813IV
2376d97d 2814PerlIOUnix_close(pTHX_ PerlIO *f)
2556f95e 2815{
de009b76 2816 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2817 int code = 0;
168d5872
NIS		 2818 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2819 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS		 2820 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2821 return 0;
22569500 2822 }
93a8090d
NIS		 2823 }
2824 else {
93189314 2825 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS		 2826 return -1;
2827 }
14a5cf38
JH		 2828 while (PerlLIO_close(fd) != 0) {
2829 if (errno != EINTR) {
2830 code = -1;
2831 break;
2832 }
abf9167d
DM		 2833 /* EINTR */
2834 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2835 return -1;
14a5cf38
JH		 2836 }
2837 if (code == 0) {
2838 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2839 }
2840 return code;
9e353e3b
NIS		 2841}
2842
27da23d5 2843PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2844 sizeof(PerlIO_funcs),
14a5cf38
JH		 2845 "unix",
2846 sizeof(PerlIOUnix),
2847 PERLIO_K_RAW,
2848 PerlIOUnix_pushed,
2376d97d 2849 PerlIOBase_popped,
14a5cf38 2850 PerlIOUnix_open,
86e05cf2 2851 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 2852 NULL,
2853 PerlIOUnix_fileno,
71200d45 2854 PerlIOUnix_dup,
14a5cf38
JH		 2855 PerlIOUnix_read,
2856 PerlIOBase_unread,
2857 PerlIOUnix_write,
2858 PerlIOUnix_seek,
2859 PerlIOUnix_tell,
2860 PerlIOUnix_close,
22569500
NIS		 2861 PerlIOBase_noop_ok, /* flush */
2862 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH		 2863 PerlIOBase_eof,
2864 PerlIOBase_error,
2865 PerlIOBase_clearerr,
2866 PerlIOBase_setlinebuf,
22569500
NIS		 2867 NULL, /* get_base */
2868 NULL, /* get_bufsiz */
2869 NULL, /* get_ptr */
2870 NULL, /* get_cnt */
2871 NULL, /* set_ptrcnt */
9e353e3b
NIS		 2872};
2873
2874/*--------------------------------------------------------------------------------------*/
14a5cf38 2875/*
71200d45 2876 * stdio as a layer
14a5cf38 2877 */
9e353e3b 2878
313e59c8
NIS		 2879#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2880/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2881 broken by the last second glibc 2.3 fix
2882 */
2883#define STDIO_BUFFER_WRITABLE
2884#endif
2885
2886
14a5cf38
JH		 2887typedef struct {
2888 struct _PerlIO base;
22569500 2889 FILE *stdio; /* The stream */
9e353e3b
NIS		 2890} PerlIOStdio;
2891
2892IV
f62ce20a 2893PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2894{
96a5add6
AL		 2895 PERL_UNUSED_CONTEXT;
2896
c4420975
AL		 2897 if (PerlIOValid(f)) {
2898 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2899 if (s)
2900 return PerlSIO_fileno(s);
439ba545
NIS		 2901 }
2902 errno = EBADF;
2903 return -1;
9e353e3b
NIS		 2904}
2905
766a733e 2906char *
14a5cf38
JH		 2907PerlIOStdio_mode(const char *mode, char *tmode)
2908{
de009b76 2909 char * const ret = tmode;
a0625d38
SR		 2910 if (mode) {
2911 while (*mode) {
2912 *tmode++ = *mode++;
2913 }
14a5cf38 2914 }
95005ad8 2915#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH		 2916 *tmode++ = 'b';
2917#endif
14a5cf38
JH		 2918 *tmode = '\0';
2919 return ret;
2920}
2921
4b803d04 2922IV
2dc2558e 2923PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2924{
1fd8f4ce
NIS		 2925 PerlIO *n;
2926 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2927 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS		 2928 if (toptab == tab) {
2929 /* Top is already stdio - pop self (duplicate) and use original */
2930 PerlIO_pop(aTHX_ f);
2931 return 0;
2932 } else {
de009b76 2933 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS		 2934 char tmode[8];
2935 FILE *stdio;
81428673 2936 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS		 2937 mode = PerlIOStdio_mode(mode, tmode)))) {
2938 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2939 /* We never call down so do any pending stuff now */
2940 PerlIO_flush(PerlIONext(f));
2a600bb8 2941 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
81428673 2942 }
1fd8f4ce
NIS		 2943 else {
2944 return -1;
2945 }
2946 }
14a5cf38 2947 }
2dc2558e 2948 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS		 2949}
2950
22569500 2951
9e353e3b 2952PerlIO *
4b069b44 2953PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2954{
14a5cf38
JH		 2955 dTHX;
2956 PerlIO *f = NULL;
ea5bc90f
YK		 2957#ifdef EBCDIC
2958 int rc;
2959 char filename[FILENAME_MAX];
2960 fldata_t fileinfo;
2961#endif
14a5cf38 2962 if (stdio) {
22569500 2963 PerlIOStdio *s;
375ed12a
JH		 2964 int fd0 = fileno(stdio);
2965 if (fd0 < 0) {
ea5bc90f
YK		 2966#ifdef EBCDIC
2967 rc = fldata(stdio,filename,&fileinfo);
2968 if(rc != 0){
2969 return NULL;
2970 }
2971 if(fileinfo.__dsorgHFS){
2972 return NULL;
2973 }
2974 /*This MVS dataset , OK!*/
2975#else
375ed12a 2976 return NULL;
ea5bc90f 2977#endif
375ed12a 2978 }
4b069b44
NIS		 2979 if (!mode || !*mode) {
2980 /* We need to probe to see how we can open the stream
2981 so start with read/write and then try write and read
2982 we dup() so that we can fclose without loosing the fd.
2983
2984 Note that the errno value set by a failing fdopen
2985 varies between stdio implementations.
2986 */
884fc2d3 2987 const int fd = PerlLIO_dup_cloexec(fd0);
375ed12a
JH		 2988 FILE *f2;
2989 if (fd < 0) {
2990 return f;
2991 }
2992 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2993 if (!f2) {
a33cf58c 2994 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS		 2995 }
2996 if (!f2) {
a33cf58c 2997 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS		 2998 }
2999 if (!f2) {
3000 /* Don't seem to be able to open */
3001 PerlLIO_close(fd);
3002 return f;
3003 }
3004 fclose(f2);
22569500 3005 }
de092133 3006 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS		 3007 s = PerlIOSelf(f, PerlIOStdio);
3008 s->stdio = stdio;
884fc2d3
Z		 3009 fd0 = fileno(stdio);
3010 if(fd0 != -1){
3011 PerlIOUnix_refcnt_inc(fd0);
3012 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3013 }
ea5bc90f 3014#ifdef EBCDIC
ea5bc90f
YK		 3015 else{
3016 rc = fldata(stdio,filename,&fileinfo);
3017 if(rc != 0){
3018 PerlIOUnix_refcnt_inc(fd0);
3019 }
3020 if(fileinfo.__dsorgHFS){
3021 PerlIOUnix_refcnt_inc(fd0);
3022 }
3023 /*This MVS dataset , OK!*/
3024 }
ea5bc90f 3025#endif
a33cf58c 3026 }
14a5cf38
JH		 3027 }
3028 return f;
9e353e3b
NIS		 3029}
3030
3031PerlIO *
14a5cf38
JH		 3032PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3033 IV n, const char *mode, int fd, int imode,
3034 int perm, PerlIO *f, int narg, SV **args)
3035{
3036 char tmode[8];
d9dac8cd 3037 if (PerlIOValid(f)) {
41188aa0
TC		 3038 STRLEN len;
3039 const char * const path = SvPV_const(*args, len);
dcda55fc 3040 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015 3041 FILE *stdio;
41188aa0 3042 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 3043 return NULL;
1751d015 3044 PerlIOUnix_refcnt_dec(fileno(s->stdio));
de092133
JH		 3045 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3046 s->stdio);
14a5cf38
JH		 3047 if (!s->stdio)
3048 return NULL;
3049 s->stdio = stdio;
884fc2d3
Z		 3050 fd = fileno(stdio);
3051 PerlIOUnix_refcnt_inc(fd);
3052 setfd_cloexec_or_inhexec_by_sysfdness(fd);
14a5cf38
JH		 3053 return f;
3054 }
3055 else {
3056 if (narg > 0) {
41188aa0
TC		 3057 STRLEN len;
3058 const char * const path = SvPV_const(*args, len);
3059 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 3060 return NULL;
3b6c1aba 3061 if (*mode == IoTYPE_NUMERIC) {
14a5cf38 3062 mode++;
884fc2d3 3063 fd = PerlLIO_open3_cloexec(path, imode, perm);
14a5cf38
JH		 3064 }
3065 else {
95005ad8
GH		 3066 FILE *stdio;
3067 bool appended = FALSE;
3068#ifdef __CYGWIN__
3069 /* Cygwin wants its 'b' early. */
3070 appended = TRUE;
3071 mode = PerlIOStdio_mode(mode, tmode);
3072#endif
3073 stdio = PerlSIO_fopen(path, mode);
6f0313ac 3074 if (stdio) {
6f0313ac
JH		 3075 if (!f) {
3076 f = PerlIO_allocate(aTHX);
3077 }
95005ad8
GH		 3078 if (!appended)
3079 mode = PerlIOStdio_mode(mode, tmode);
3080 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3081 if (f) {
0f0f9e2b 3082 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
884fc2d3
Z		 3083 fd = fileno(stdio);
3084 PerlIOUnix_refcnt_inc(fd);
3085 setfd_cloexec_or_inhexec_by_sysfdness(fd);
0f0f9e2b
JH		 3086 } else {
3087 PerlSIO_fclose(stdio);
6f0313ac
JH		 3088 }
3089 return f;
3090 }
3091 else {
3092 return NULL;
3093 }
14a5cf38
JH		 3094 }
3095 }
3096 if (fd >= 0) {
3097 FILE *stdio = NULL;
3098 int init = 0;
3b6c1aba 3099 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 3100 init = 1;
3101 mode++;
3102 }
3103 if (init) {
3104 switch (fd) {
3105 case 0:
3106 stdio = PerlSIO_stdin;
3107 break;
3108 case 1:
3109 stdio = PerlSIO_stdout;
3110 break;
3111 case 2:
3112 stdio = PerlSIO_stderr;
3113 break;
3114 }
3115 }
3116 else {
3117 stdio = PerlSIO_fdopen(fd, mode =
3118 PerlIOStdio_mode(mode, tmode));
3119 }
3120 if (stdio) {
d9dac8cd
NIS		 3121 if (!f) {
3122 f = PerlIO_allocate(aTHX);
3123 }
a33cf58c 3124 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba 3125 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
884fc2d3
Z		 3126 fd = fileno(stdio);
3127 PerlIOUnix_refcnt_inc(fd);
3128 setfd_cloexec_or_inhexec_by_sysfdness(fd);
a33cf58c 3129 }
14a5cf38
JH		 3130 return f;
3131 }
0a20f69b 3132 PerlLIO_close(fd);
14a5cf38
JH		 3133 }
3134 }
ee518936 3135 return NULL;
9e353e3b
NIS		 3136}
3137
1751d015 3138PerlIO *
ecdeb87c 3139PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS		 3140{
3141 /* This assumes no layers underneath - which is what
3142 happens, but is not how I remember it. NI-S 2001/10/16
3143 */
ecdeb87c 3144 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 3145 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 3146 const int fd = fileno(stdio);
9217ff3f 3147 char mode[8];
ecdeb87c 3148 if (flags & PERLIO_DUP_FD) {
884fc2d3 3149 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
9217ff3f
NIS		 3150 if (dfd >= 0) {
3151 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3152 goto set_this;
ecdeb87c
NIS		 3153 }
3154 else {
6f207bd3 3155 NOOP;
ecdeb87c
NIS		 3156 /* FIXME: To avoid messy error recovery if dup fails
3157 re-use the existing stdio as though flag was not set
3158 */
3159 }
3160 }
9217ff3f
NIS		 3161 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3162 set_this:
694c95cf 3163 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
40596bc5 3164 if(stdio) {
884fc2d3
Z		 3165 int fd = fileno(stdio);
3166 PerlIOUnix_refcnt_inc(fd);
3167 setfd_cloexec_or_inhexec_by_sysfdness(fd);
40596bc5 3168 }
1751d015
NIS		 3169 }
3170 return f;
3171}
3172
0d7a5398
NIS		 3173static int
3174PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3175{
96a5add6
AL		 3176 PERL_UNUSED_CONTEXT;
3177
0d7a5398 3178 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3179 * PerlIO_set_fileno() support from Configure
0d7a5398 3180 */
36b1c892
AD		 3181# if defined(HAS_FDCLOSE)
3182 return fdclose(f, NULL) == 0 ? 1 : 0;
3183# elif defined(__UCLIBC__)
ef8eacb8
AT		 3184 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3185 f->__filedes = -1;
3186 return 1;
3187# elif defined(__GLIBC__)
0d7a5398 3188 /* There may be a better way for GLIBC:
37725cdc 3189 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS		 3190 */
3191 f->_fileno = -1;
3192 return 1;
bdea967c 3193# elif defined(__sun)
f5992bc4 3194 PERL_UNUSED_ARG(f);
cfedb851 3195 return 0;
0d7a5398
NIS		 3196# elif defined(__hpux)
3197 f->__fileH = 0xff;
3198 f->__fileL = 0xff;
3199 return 1;
9837d373 3200 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3201 your platform does not have special entry try this one.
9837d373
NIS		 3202 [For OSF only have confirmation for Tru64 (alpha)
3203 but assume other OSFs will be similar.]
37725cdc 3204 */
9837d373 3205# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS		 3206 f->_file = -1;
3207 return 1;
3208# elif defined(__FreeBSD__)
3209 /* There may be a better way on FreeBSD:
37725cdc
NIS		 3210 - we could insert a dummy func in the _close function entry
3211 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS		 3212 */
3213 f->_file = -1;
0c49ea6a
SU		 3214 return 1;
3215# elif defined(__OpenBSD__)
3216 /* There may be a better way on OpenBSD:
3217 - we could insert a dummy func in the _close function entry
3218 f->_close = (int (*)(void *)) dummy_close;
3219 */
3220 f->_file = -1;
0d7a5398 3221 return 1;
59ad941d
IZ		 3222# elif defined(__EMX__)
3223 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3224 f->_handle = -1;
3225 return 1;
0d7a5398
NIS		 3226# elif defined(__CYGWIN__)
3227 /* There may be a better way on CYGWIN:
37725cdc
NIS		 3228 - we could insert a dummy func in the _close function entry
3229 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS		 3230 */
3231 f->_file = -1;
3232 return 1;
3233# elif defined(WIN32)
1f664ef5 3234 PERLIO_FILE_file(f) = -1;
0d7a5398
NIS		 3235 return 1;
3236# else
3237#if 0
37725cdc 3238 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3239 (which isn't thread safe) instead
37725cdc 3240 */
0d7a5398
NIS		 3241# error "Don't know how to set FILE.fileno on your platform"
3242#endif
8772537c 3243 PERL_UNUSED_ARG(f);
0d7a5398
NIS		 3244 return 0;
3245# endif
3246}
3247
1751d015 3248IV
f62ce20a 3249PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3250{
c4420975 3251 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS		 3252 if (!stdio) {
3253 errno = EBADF;
3254 return -1;
3255 }
9217ff3f 3256 else {
de009b76 3257 const int fd = fileno(stdio);
0d7a5398 3258 int invalidate = 0;
bbfd922f 3259 IV result = 0;
1d791a44 3260 int dupfd = -1;
4ee39169 3261 dSAVEDERRNO;
a2e578da
MHM		 3262#ifdef USE_ITHREADS
3263 dVAR;
3264#endif
0d7a5398 3265#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS		 3266 /* Socks lib overrides close() but stdio isn't linked to
3267 that library (though we are) - so we must call close()
3268 on sockets on stdio's behalf.
3269 */
0d7a5398
NIS		 3270 int optval;
3271 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3272 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3273 invalidate = 1;
0d7a5398 3274#endif
d8723f43
NC		 3275 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3276 that a subsequent fileno() on it returns -1. Don't want to croak()
3277 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3278 trying to close an already closed handle which somehow it still has
3279 a reference to. (via.xs, I'm looking at you). */
3280 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3281 /* File descriptor still in use */
0d7a5398 3282 invalidate = 1;
d8723f43 3283 }
0d7a5398 3284 if (invalidate) {
6b4ce6c8
AL		 3285 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3286 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3287 return 0;
3288 if (stdio == stdout || stdio == stderr)
3289 return PerlIO_flush(f);
d88f7f65 3290 }
d88f7f65
JH		 3291 MUTEX_LOCK(&PL_perlio_mutex);
3292 /* Right. We need a mutex here because for a brief while we
3293 will have the situation that fd is actually closed. Hence if
3294 a second thread were to get into this block, its dup() would
3295 likely return our fd as its dupfd. (after all, it is closed)
3296 Then if we get to the dup2() first, we blat the fd back
3297 (messing up its temporary as a side effect) only for it to
3298 then close its dupfd (== our fd) in its close(dupfd) */
3299
3300 /* There is, of course, a race condition, that any other thread
3301 trying to input/output/whatever on this fd will be stuffed
3302 for the duration of this little manoeuvrer. Perhaps we
3303 should hold an IO mutex for the duration of every IO
3304 operation if we know that invalidate doesn't work on this
3305 platform, but that would suck, and could kill performance.
3306
3307 Except that correctness trumps speed.
3308 Advice from klortho #11912. */
d88f7f65 3309 if (invalidate) {
37725cdc
NIS		 3310 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3311 Use Sarathy's trick from maint-5.6 to invalidate the
3312 fileno slot of the FILE *
3313 */
bbfd922f 3314 result = PerlIO_flush(f);
4ee39169 3315 SAVE_ERRNO;
6b4ce6c8 3316 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
711e8db2 3317 if (!invalidate) {
884fc2d3 3318 dupfd = PerlLIO_dup_cloexec(fd);
711e8db2 3319#ifdef USE_ITHREADS
9bab90c0 3320 if (dupfd < 0) {
711e8db2
NC		 3321 /* Oh cXap. This isn't going to go well. Not sure if we can
3322 recover from here, or if closing this particular FILE *
3323 is a good idea now. */
3324 }
3325#endif
3326 }
94ccb807
JH		 3327 } else {
3328 SAVE_ERRNO; /* This is here only to silence compiler warnings */
37725cdc 3329 }
0d7a5398 3330 result = PerlSIO_fclose(stdio);
37725cdc
NIS		 3331 /* We treat error from stdio as success if we invalidated
3332 errno may NOT be expected EBADF
e8529473
NIS		 3333 */
3334 if (invalidate && result != 0) {
4ee39169 3335 RESTORE_ERRNO;
0d7a5398 3336 result = 0;
37725cdc 3337 }
6b4ce6c8
AL		 3338#ifdef SOCKS5_VERSION_NAME
3339 /* in SOCKS' case, let close() determine return value */
3340 result = close(fd);
3341#endif
1d791a44 3342 if (dupfd >= 0) {
884fc2d3
Z		 3343 PerlLIO_dup2_cloexec(dupfd, fd);
3344 setfd_inhexec_for_sysfd(fd);
9bab90c0 3345 PerlLIO_close(dupfd);
d88f7f65 3346 }
d88f7f65 3347 MUTEX_UNLOCK(&PL_perlio_mutex);
9217ff3f 3348 return result;
37725cdc 3349 }
1751d015
NIS		 3350}
3351
9e353e3b 3352SSize_t
f62ce20a 3353PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3354{
abf9167d 3355 FILE * s;
14a5cf38 3356 SSize_t got = 0;
abf9167d
DM		 3357 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3358 return -1;
3359 s = PerlIOSelf(f, PerlIOStdio)->stdio;
4d948241
NIS		 3360 for (;;) {
3361 if (count == 1) {
3362 STDCHAR *buf = (STDCHAR *) vbuf;
3363 /*
3364 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3365 * stdio does not do that for fread()
3366 */
de009b76 3367 const int ch = PerlSIO_fgetc(s);
4d948241
NIS		 3368 if (ch != EOF) {
3369 *buf = ch;
3370 got = 1;
3371 }
14a5cf38 3372 }
4d948241
NIS		 3373 else
3374 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS		 3375 if (got == 0 && PerlSIO_ferror(s))
3376 got = -1;
42a7a32f 3377 if (got >= 0 || errno != EINTR)
4d948241 3378 break;
abf9167d
DM		 3379 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3380 return -1;
42a7a32f 3381 SETERRNO(0,0); /* just in case */
14a5cf38 3382 }
bdae4172
JH		 3383#ifdef __sgi
3384 /* Under some circumstances IRIX stdio fgetc() and fread()
3385 * set the errno to ENOENT, which makes no sense according
3386 * to either IRIX or POSIX. [rt.perl.org #123977] */
3387 if (errno == ENOENT) SETERRNO(0,0);
3388#endif
14a5cf38 3389 return got;
9e353e3b
NIS		 3390}
3391
3392SSize_t
f62ce20a 3393PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3394{
14a5cf38 3395 SSize_t unread = 0;
c4420975 3396 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3397
313e59c8 3398#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3399 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3400 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3401 STDCHAR *base = PerlIO_get_base(f);
3402 SSize_t cnt = PerlIO_get_cnt(f);
3403 STDCHAR *ptr = PerlIO_get_ptr(f);
3404 SSize_t avail = ptr - base;
3405 if (avail > 0) {
3406 if (avail > count) {
3407 avail = count;
3408 }
3409 ptr -= avail;
3410 Move(buf-avail,ptr,avail,STDCHAR);
3411 count -= avail;
3412 unread += avail;
3413 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS		 3414 if (PerlSIO_feof(s) && unread >= 0)
3415 PerlSIO_clearerr(s);
3416 }
3417 }
313e59c8
NIS		 3418 else
3419#endif
3420 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3421 /* We can get pointer to buffer but not its base
3422 Do ungetc() but check chars are ending up in the
3423 buffer
3424 */
3425 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3426 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3427 while (count > 0) {
de009b76 3428 const int ch = *--buf & 0xFF;
9f7cd136
NIS		 3429 if (ungetc(ch,s) != ch) {
3430 /* ungetc did not work */
3431 break;
3432 }
3433 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3434 /* Did not change pointer as expected */
375ed12a
JH		 3435 if (fgetc(s) != EOF) /* get char back again */
3436 break;
9f7cd136
NIS		 3437 }
3438 /* It worked ! */
3439 count--;
3440 unread++;
93679785
NIS		 3441 }
3442 }
3443
3444 if (count > 0) {
3445 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 3446 }
3447 return unread;
9e353e3b
NIS		 3448}
3449
3450SSize_t
f62ce20a 3451PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3452{
4d948241 3453 SSize_t got;
abf9167d
DM		 3454 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3455 return -1;
4d948241
NIS		 3456 for (;;) {
3457 got = PerlSIO_fwrite(vbuf, 1, count,
3458 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3459 if (got >= 0 || errno != EINTR)
4d948241 3460 break;
abf9167d
DM		 3461 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3462 return -1;
42a7a32f 3463 SETERRNO(0,0); /* just in case */
4d948241
NIS		 3464 }
3465 return got;
9e353e3b
NIS		 3466}
3467
94a175e1 3468IV
f62ce20a 3469PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3470{
c4420975 3471 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3472 PERL_UNUSED_CONTEXT;
3473
94a175e1 3474 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS		 3475}
3476
3477Off_t
f62ce20a 3478PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3479{
c4420975 3480 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3481 PERL_UNUSED_CONTEXT;
3482
94a175e1 3483 return PerlSIO_ftell(stdio);
9e353e3b
NIS		 3484}
3485
3486IV
f62ce20a 3487PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3488{
c4420975 3489 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3490 PERL_UNUSED_CONTEXT;
3491
14a5cf38
JH		 3492 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3493 return PerlSIO_fflush(stdio);
3494 }
3495 else {
6f207bd3 3496 NOOP;
88b61e10 3497#if 0
14a5cf38
JH		 3498 /*
3499 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3500 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3501 * design is to do _this_ but not have layer above flush this
71200d45 3502 * layer read-to-read
14a5cf38
JH		 3503 */
3504 /*
71200d45 3505 * Not writeable - sync by attempting a seek
14a5cf38 3506 */
4ee39169 3507 dSAVE_ERRNO;
14a5cf38 3508 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3509 RESTORE_ERRNO;
88b61e10 3510#endif
14a5cf38
JH		 3511 }
3512 return 0;
9e353e3b
NIS		 3513}
3514
3515IV
f62ce20a 3516PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3517{
96a5add6
AL		 3518 PERL_UNUSED_CONTEXT;
3519
14a5cf38 3520 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3521}
3522
3523IV
f62ce20a 3524PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3525{
96a5add6
AL		 3526 PERL_UNUSED_CONTEXT;
3527
263df5f1 3528 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3529}
3530
3531void
f62ce20a 3532PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3533{
96a5add6
AL		 3534 PERL_UNUSED_CONTEXT;
3535
14a5cf38 3536 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3537}
3538
3539void
f62ce20a 3540PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3541{
96a5add6
AL		 3542 PERL_UNUSED_CONTEXT;
3543
9e353e3b 3544#ifdef HAS_SETLINEBUF
14a5cf38 3545 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3546#else
bd61b366 3547 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS		 3548#endif
3549}
3550
3551#ifdef FILE_base
3552STDCHAR *
f62ce20a 3553PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3554{
c4420975 3555 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3556 PERL_UNUSED_CONTEXT;
cc00df79 3557 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS		 3558}
3559
3560Size_t
f62ce20a 3561PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3562{
c4420975 3563 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3564 PERL_UNUSED_CONTEXT;
14a5cf38 3565 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS		 3566}
3567#endif
3568
3569#ifdef USE_STDIO_PTR
3570STDCHAR *
f62ce20a 3571PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3572{
c4420975 3573 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3574 PERL_UNUSED_CONTEXT;
cc00df79 3575 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS		 3576}
3577
3578SSize_t
f62ce20a 3579PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3580{
c4420975 3581 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3582 PERL_UNUSED_CONTEXT;
14a5cf38 3583 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS		 3584}
3585
3586void
f62ce20a 3587PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3588{
c4420975 3589 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
e9b8343f 3590 PERL_UNUSED_CONTEXT;
14a5cf38 3591 if (ptr != NULL) {
9e353e3b 3592#ifdef STDIO_PTR_LVALUE
46f05249
JH		 3593 /* This is a long-standing infamous mess. The root of the
3594 * problem is that one cannot know the signedness of char, and
3595 * more precisely the signedness of FILE._ptr. The following
3596 * things have been tried, and they have all failed (across
3597 * different compilers (remember that core needs to to build
3598 * also with c++) and compiler options:
3599 *
3600 * - casting the RHS to (void*) -- works in *some* places
3601 * - casting the LHS to (void*) -- totally unportable
3602 *
3603 * So let's try silencing the warning at least for gcc. */
7347ee54 3604 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
d06fc7d4 3605 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
7347ee54 3606 GCC_DIAG_RESTORE_STMT;
9e353e3b 3607#ifdef STDIO_PTR_LVAL_SETS_CNT
f8a4dbc5 3608 assert(PerlSIO_get_cnt(stdio) == (cnt));
9e353e3b
NIS		 3609#endif
3610#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3611 /*
71200d45 3612 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH		 3613 */
3614 return;
9e353e3b 3615#endif
22569500 3616#else /* STDIO_PTR_LVALUE */
14a5cf38 3617 PerlProc_abort();
22569500 3618#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH		 3619 }
3620 /*
71200d45 3621 * Now (or only) set cnt
14a5cf38 3622 */
9e353e3b 3623#ifdef STDIO_CNT_LVALUE
14a5cf38 3624 PerlSIO_set_cnt(stdio, cnt);
faf55891 3625#elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH		 3626 PerlSIO_set_ptr(stdio,
3627 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3628 cnt));
22569500 3629#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3630 PerlProc_abort();
22569500 3631#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS		 3632}
3633
93679785 3634
9e353e3b
NIS		 3635#endif
3636
93679785
NIS		 3637IV
3638PerlIOStdio_fill(pTHX_ PerlIO *f)
3639{
abf9167d 3640 FILE * stdio;
93679785 3641 int c;
96a5add6 3642 PERL_UNUSED_CONTEXT;
abf9167d
DM		 3643 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3644 return -1;
3645 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6 3646
93679785
NIS		 3647 /*
3648 * fflush()ing read-only streams can cause trouble on some stdio-s
3649 */
3650 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3651 if (PerlSIO_fflush(stdio) != 0)
3652 return EOF;
3653 }
f3be3723
BL		 3654 for (;;) {
3655 c = PerlSIO_fgetc(stdio);
3656 if (c != EOF)
3657 break;
3658 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3659 return EOF;
abf9167d
DM		 3660 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3661 return -1;
f3be3723
BL		 3662 SETERRNO(0,0);
3663 }
93679785
NIS		 3664
3665#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS		 3666
3667#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3668 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3669 /* Fake ungetc() to the real buffer in case system's ungetc
3670 goes elsewhere
3671 */
3672 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3673 SSize_t cnt = PerlSIO_get_cnt(stdio);
3674 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3675 if (ptr == base+1) {
3676 *--ptr = (STDCHAR) c;
3677 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3678 if (PerlSIO_feof(stdio))
3679 PerlSIO_clearerr(stdio);
3680 return 0;
3681 }
3682 }
313e59c8
NIS		 3683 else
3684#endif
3685 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3686 STDCHAR ch = c;
3687 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3688 return 0;
3689 }
3690 }
93679785
NIS		 3691#endif
3692
93679785 3693 /* If buffer snoop scheme above fails fall back to
9f7cd136 3694 using ungetc().
93679785
NIS		 3695 */
3696 if (PerlSIO_ungetc(c, stdio) != c)
3697 return EOF;
5876737a 3698
93679785
NIS		 3699 return 0;
3700}
3701
3702
3703
27da23d5 3704PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3705 sizeof(PerlIO_funcs),
14a5cf38
JH		 3706 "stdio",
3707 sizeof(PerlIOStdio),
86e05cf2 3708 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3709 PerlIOStdio_pushed,
2376d97d 3710 PerlIOBase_popped,
14a5cf38 3711 PerlIOStdio_open,
86e05cf2 3712 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 3713 NULL,
3714 PerlIOStdio_fileno,
71200d45 3715 PerlIOStdio_dup,
14a5cf38
JH		 3716 PerlIOStdio_read,
3717 PerlIOStdio_unread,
3718 PerlIOStdio_write,
3719 PerlIOStdio_seek,
3720 PerlIOStdio_tell,
3721 PerlIOStdio_close,
3722 PerlIOStdio_flush,
3723 PerlIOStdio_fill,
3724 PerlIOStdio_eof,
3725 PerlIOStdio_error,
3726 PerlIOStdio_clearerr,
3727 PerlIOStdio_setlinebuf,
9e353e3b 3728#ifdef FILE_base
14a5cf38
JH		 3729 PerlIOStdio_get_base,
3730 PerlIOStdio_get_bufsiz,
9e353e3b 3731#else
14a5cf38
JH		 3732 NULL,
3733 NULL,
9e353e3b
NIS		 3734#endif
3735#ifdef USE_STDIO_PTR
14a5cf38
JH		 3736 PerlIOStdio_get_ptr,
3737 PerlIOStdio_get_cnt,
15b61c98 3738# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
79ed0f43 3739 PerlIOStdio_set_ptrcnt,
15b61c98
JH		 3740# else
3741 NULL,
3742# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3743#else
3744 NULL,
14a5cf38
JH		 3745 NULL,
3746 NULL,
15b61c98 3747#endif /* USE_STDIO_PTR */
9e353e3b
NIS		 3748};
3749
b9d6bf13
JH		 3750/* Note that calls to PerlIO_exportFILE() are reversed using
3751 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3752FILE *
81428673 3753PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3754{
e87a358a 3755 dTHX;
81428673
NIS		 3756 FILE *stdio = NULL;
3757 if (PerlIOValid(f)) {
3758 char buf[8];
375ed12a
JH		 3759 int fd = PerlIO_fileno(f);
3760 if (fd < 0) {
3761 return NULL;
3762 }
81428673
NIS		 3763 PerlIO_flush(f);
3764 if (!mode || !*mode) {
3765 mode = PerlIO_modestr(f, buf);
3766 }
3767 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3768 if (stdio) {
3769 PerlIOl *l = *f;
9f75cc58 3770 PerlIO *f2;
81428673
NIS		 3771 /* De-link any lower layers so new :stdio sticks */
3772 *f = NULL;
a0714e2c 3773 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
9f75cc58 3774 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673 3775 s->stdio = stdio;
6b54a403 3776 PerlIOUnix_refcnt_inc(fileno(stdio));
81428673
NIS		 3777 /* Link previous lower layers under new one */
3778 *PerlIONext(f) = l;
3779 }
3780 else {
3781 /* restore layers list */
3782 *f = l;
3783 }
a33cf58c 3784 }
14a5cf38
JH		 3785 }
3786 return stdio;
9e353e3b
NIS		 3787}
3788
81428673 3789
9e353e3b
NIS		 3790FILE *
3791PerlIO_findFILE(PerlIO *f)
3792{
14a5cf38 3793 PerlIOl *l = *f;
bbbc33d0 3794 FILE *stdio;
14a5cf38
JH		 3795 while (l) {
3796 if (l->tab == &PerlIO_stdio) {
3797 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3798 return s->stdio;
3799 }
3800 l = *PerlIONext(&l);
f7e7eb72 3801 }
4b069b44 3802 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
bbbc33d0
NC		 3803 /* However, we're not really exporting a FILE * to someone else (who
3804 becomes responsible for closing it, or calling PerlIO_releaseFILE())
486ec47a 3805 So we need to undo its reference count increase on the underlying file
bbbc33d0
NC		 3806 descriptor. We have to do this, because if the loop above returns you
3807 the FILE *, then *it* didn't increase any reference count. So there's
3808 only one way to be consistent. */
3809 stdio = PerlIO_exportFILE(f, NULL);
3810 if (stdio) {
3811 const int fd = fileno(stdio);
3812 if (fd >= 0)
3813 PerlIOUnix_refcnt_dec(fd);
3814 }
3815 return stdio;
9e353e3b
NIS		 3816}
3817
b9d6bf13 3818/* Use this to reverse PerlIO_exportFILE calls. */
9e353e3b
NIS		 3819void
3820PerlIO_releaseFILE(PerlIO *p, FILE *f)
3821{
22569500
NIS		 3822 PerlIOl *l;
3823 while ((l = *p)) {
3824 if (l->tab == &PerlIO_stdio) {
3825 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2bcd6579 3826 if (s->stdio == f) { /* not in a loop */
6b54a403
NC		 3827 const int fd = fileno(f);
3828 if (fd >= 0)
3829 PerlIOUnix_refcnt_dec(fd);
2bcd6579
DD		 3830 {
3831 dTHX;
3832 PerlIO_pop(aTHX_ p);
3833 }
22569500
NIS		 3834 return;
3835 }
3836 }
3837 p = PerlIONext(p);
3838 }
3839 return;
9e353e3b
NIS		 3840}
3841
3842/*--------------------------------------------------------------------------------------*/
14a5cf38 3843/*
71200d45 3844 * perlio buffer layer
14a5cf38 3845 */
9e353e3b 3846
5e2ab84b 3847IV
2dc2558e 3848PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 3849{
14a5cf38 3850 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
de009b76 3851 const int fd = PerlIO_fileno(f);
14a5cf38
JH		 3852 if (fd >= 0 && PerlLIO_isatty(fd)) {
3853 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3854 }
4b069b44 3855 if (*PerlIONext(f)) {
de009b76 3856 const Off_t posn = PerlIO_tell(PerlIONext(f));
4b069b44
NIS		 3857 if (posn != (Off_t) - 1) {
3858 b->posn = posn;
3859 }
14a5cf38 3860 }
2dc2558e 3861 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b
NIS		 3862}
3863
9e353e3b 3864PerlIO *
14a5cf38
JH		 3865PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3866 IV n, const char *mode, int fd, int imode, int perm,
3867 PerlIO *f, int narg, SV **args)
3868{
04892f78 3869 if (PerlIOValid(f)) {
14a5cf38 3870 PerlIO *next = PerlIONext(f);
67363c0d
JH		 3871 PerlIO_funcs *tab =
3872 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3873 if (tab && tab->Open)
3874 next =
3875 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3876 next, narg, args);
2dc2558e 3877 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
14a5cf38
JH		 3878 return NULL;
3879 }
3880 }
3881 else {
04892f78 3882 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38 3883 int init = 0;
3b6c1aba 3884 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 3885 init = 1;
3886 /*
71200d45 3887 * mode++;
14a5cf38
JH		 3888 */
3889 }
67363c0d
JH		 3890 if (tab && tab->Open)
3891 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3892 f, narg, args);
3893 else
3894 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 3895 if (f) {
22569500 3896 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
b26b1ab5
NC		 3897 /*
3898 * if push fails during open, open fails. close will pop us.
3899 */
3900 PerlIO_close (f);
3901 return NULL;
3902 } else {
3903 fd = PerlIO_fileno(f);
b26b1ab5
NC		 3904 if (init && fd == 2) {
3905 /*
3906 * Initial stderr is unbuffered
3907 */
3908 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3909 }
23b84778
IZ		 3910#ifdef PERLIO_USING_CRLF
3911# ifdef PERLIO_IS_BINMODE_FD
3912 if (PERLIO_IS_BINMODE_FD(fd))
bd61b366 3913 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
23b84778
IZ		 3914 else
3915# endif
3916 /*
3917 * do something about failing setmode()? --jhi
3918 */
3919 PerlLIO_setmode(fd, O_BINARY);
3920#endif
8c8488cd 3921#ifdef VMS
8c8488cd
CB		 3922 /* Enable line buffering with record-oriented regular files
3923 * so we don't introduce an extraneous record boundary when
3924 * the buffer fills up.
3925 */
3926 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3927 Stat_t st;
3928 if (PerlLIO_fstat(fd, &st) == 0
3929 && S_ISREG(st.st_mode)
3930 && (st.st_fab_rfm == FAB$C_VAR
3931 || st.st_fab_rfm == FAB$C_VFC)) {
3932 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3933 }
3934 }
3935#endif
14a5cf38
JH		 3936 }
3937 }
ee518936 3938 }
14a5cf38 3939 return f;
9e353e3b
NIS		 3940}
3941
14a5cf38
JH		 3942/*
3943 * This "flush" is akin to sfio's sync in that it handles files in either
93c2c2ec
IZ		 3944 * read or write state. For write state, we put the postponed data through
3945 * the next layers. For read state, we seek() the next layers to the
3946 * offset given by current position in the buffer, and discard the buffer
3947 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3948 * in any case?). Then the pass the stick further in chain.
14a5cf38 3949 */
9e353e3b 3950IV
f62ce20a 3951PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 3952{
dcda55fc 3953 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3954 int code = 0;
04892f78 3955 PerlIO *n = PerlIONext(f);
14a5cf38
JH		 3956 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3957 /*
71200d45 3958 * write() the buffer
14a5cf38 3959 */
de009b76
AL		 3960 const STDCHAR *buf = b->buf;
3961 const STDCHAR *p = buf;
14a5cf38
JH		 3962 while (p < b->ptr) {
3963 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3964 if (count > 0) {
3965 p += count;
3966 }
3967 else if (count < 0 || PerlIO_error(n)) {
3968 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 3969 PerlIO_save_errno(f);
14a5cf38
JH		 3970 code = -1;
3971 break;
3972 }
3973 }
3974 b->posn += (p - buf);
3975 }
3976 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3977 STDCHAR *buf = PerlIO_get_base(f);
3978 /*
71200d45 3979 * Note position change
14a5cf38
JH		 3980 */
3981 b->posn += (b->ptr - buf);
3982 if (b->ptr < b->end) {
4b069b44
NIS		 3983 /* We did not consume all of it - try and seek downstream to
3984 our logical position
14a5cf38 3985 */
4b069b44 3986 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
04892f78
NIS		 3987 /* Reload n as some layers may pop themselves on seek */
3988 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38 3989 }
ba5c3fe9 3990 else {
4b069b44
NIS		 3991 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3992 data is lost for good - so return saying "ok" having undone
3993 the position adjust
3994 */
3995 b->posn -= (b->ptr - buf);
ba5c3fe9
NIS		 3996 return code;
3997 }
14a5cf38
JH		 3998 }
3999 }
4000 b->ptr = b->end = b->buf;
4001 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78 4002 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
04892f78 4003 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH		 4004 code = -1;
4005 return code;
6f9d8c32
NIS		 4006}
4007
93c2c2ec
IZ		 4008/* This discards the content of the buffer after b->ptr, and rereads
4009 * the buffer from the position off in the layer downstream; here off
4010 * is at offset corresponding to b->ptr - b->buf.
4011 */
06da4f11 4012IV
f62ce20a 4013PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 4014{
dcda55fc 4015 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4016 PerlIO *n = PerlIONext(f);
4017 SSize_t avail;
4018 /*
4b069b44
NIS		 4019 * Down-stream flush is defined not to loose read data so is harmless.
4020 * we would not normally be fill'ing if there was data left in anycase.
14a5cf38 4021 */
93c2c2ec 4022 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
14a5cf38
JH		 4023 return -1;
4024 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
f62ce20a 4025 PerlIOBase_flush_linebuf(aTHX);
14a5cf38
JH		 4026
4027 if (!b->buf)
22569500 4028 PerlIO_get_base(f); /* allocate via vtable */
14a5cf38 4029
0f0eef27 4030 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
ec6fa4f0 4031
14a5cf38 4032 b->ptr = b->end = b->buf;
4b069b44
NIS		 4033
4034 if (!PerlIOValid(n)) {
4035 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4036 return -1;
4037 }
4038
14a5cf38
JH		 4039 if (PerlIO_fast_gets(n)) {
4040 /*
04892f78 4041 * Layer below is also buffered. We do _NOT_ want to call its
14a5cf38
JH		 4042 * ->Read() because that will loop till it gets what we asked for
4043 * which may hang on a pipe etc. Instead take anything it has to
71200d45 4044 * hand, or ask it to fill _once_.
14a5cf38
JH		 4045 */
4046 avail = PerlIO_get_cnt(n);
4047 if (avail <= 0) {
4048 avail = PerlIO_fill(n);
4049 if (avail == 0)
4050 avail = PerlIO_get_cnt(n);
4051 else {
4052 if (!PerlIO_error(n) && PerlIO_eof(n))
4053 avail = 0;
4054 }
4055 }
4056 if (avail > 0) {
4057 STDCHAR *ptr = PerlIO_get_ptr(n);
dcda55fc 4058 const SSize_t cnt = avail;
eb160463 4059 if (avail > (SSize_t)b->bufsiz)
14a5cf38
JH		 4060 avail = b->bufsiz;
4061 Copy(ptr, b->buf, avail, STDCHAR);
4062 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4063 }
4064 }
4065 else {
4066 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4067 }
4068 if (avail <= 0) {
4069 if (avail == 0)
4070 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4071 else
0ea86a10 4072 {
14a5cf38 4073 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10
FC		 4074 PerlIO_save_errno(f);
4075 }
14a5cf38
JH		 4076 return -1;
4077 }
4078 b->end = b->buf + avail;
4079 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4080 return 0;
06da4f11
NIS		 4081}
4082
6f9d8c32 4083SSize_t
f62ce20a 4084PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 4085{
04892f78 4086 if (PerlIOValid(f)) {
dcda55fc 4087 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4088 if (!b->ptr)
4089 PerlIO_get_base(f);
f62ce20a 4090 return PerlIOBase_read(aTHX_ f, vbuf, count);
14a5cf38
JH		 4091 }
4092 return 0;
6f9d8c32
NIS		 4093}
4094
9e353e3b 4095SSize_t
f62ce20a 4096PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 4097{
14a5cf38 4098 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
dcda55fc 4099 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4100 SSize_t unread = 0;
4101 SSize_t avail;
4102 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4103 PerlIO_flush(f);
4104 if (!b->buf)
4105 PerlIO_get_base(f);
4106 if (b->buf) {
4107 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4108 /*
4109 * Buffer is already a read buffer, we can overwrite any chars
71200d45 4110 * which have been read back to buffer start
14a5cf38
JH		 4111 */
4112 avail = (b->ptr - b->buf);
4113 }
4114 else {
4115 /*
4116 * Buffer is idle, set it up so whole buffer is available for
71200d45 4117 * unread
14a5cf38
JH		 4118 */
4119 avail = b->bufsiz;
4120 b->end = b->buf + avail;
4121 b->ptr = b->end;
4122 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4123 /*
71200d45 4124 * Buffer extends _back_ from where we are now
14a5cf38
JH		 4125 */
4126 b->posn -= b->bufsiz;
4127 }
94e529cc 4128 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
14a5cf38 4129 /*
71200d45 4130 * If we have space for more than count, just move count
14a5cf38
JH		 4131 */
4132 avail = count;
4133 }
4134 if (avail > 0) {
4135 b->ptr -= avail;
4136 buf -= avail;
4137 /*
4138 * In simple stdio-like ungetc() case chars will be already
71200d45 4139 * there
14a5cf38
JH		 4140 */
4141 if (buf != b->ptr) {
4142 Copy(buf, b->ptr, avail, STDCHAR);
4143 }
4144 count -= avail;
4145 unread += avail;
4146 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4147 }
4148 }
93679785
NIS		 4149 if (count > 0) {
4150 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4151 }
14a5cf38 4152 return unread;
760ac839
LW		 4153}
4154
9e353e3b 4155SSize_t
f62ce20a 4156PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 4157{
de009b76 4158 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4159 const STDCHAR *buf = (const STDCHAR *) vbuf;
ee56a6b9 4160 const STDCHAR *flushptr = buf;
14a5cf38
JH		 4161 Size_t written = 0;
4162 if (!b->buf)
4163 PerlIO_get_base(f);
4164 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4165 return 0;
0678cb22
NIS		 4166 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4167 if (PerlIO_flush(f) != 0) {
4168 return 0;
4169 }
4170 }
ee56a6b9
CS		 4171 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4172 flushptr = buf + count;
4173 while (flushptr > buf && *(flushptr - 1) != '\n')
4174 --flushptr;
4175 }
14a5cf38
JH		 4176 while (count > 0) {
4177 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
94e529cc 4178 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
14a5cf38 4179 avail = count;
ee56a6b9
CS		 4180 if (flushptr > buf && flushptr <= buf + avail)
4181 avail = flushptr - buf;
14a5cf38 4182 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
ee56a6b9
CS		 4183 if (avail) {
4184 Copy(buf, b->ptr, avail, STDCHAR);
4185 count -= avail;
4186 buf += avail;
4187 written += avail;
4188 b->ptr += avail;
4189 if (buf == flushptr)
4190 PerlIO_flush(f);
14a5cf38
JH		 4191 }
4192 if (b->ptr >= (b->buf + b->bufsiz))
abf9167d
DM		 4193 if (PerlIO_flush(f) == -1)
4194 return -1;
14a5cf38
JH		 4195 }
4196 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4197 PerlIO_flush(f);
4198 return written;
9e353e3b
NIS		 4199}
4200
94a175e1 4201IV
f62ce20a 4202PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 4203{
14a5cf38
JH		 4204 IV code;
4205 if ((code = PerlIO_flush(f)) == 0) {
14a5cf38
JH		 4206 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4207 code = PerlIO_seek(PerlIONext(f), offset, whence);
4208 if (code == 0) {
de009b76 4209 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4210 b->posn = PerlIO_tell(PerlIONext(f));
4211 }
9e353e3b 4212 }
14a5cf38 4213 return code;
9e353e3b
NIS		 4214}
4215
4216Off_t
f62ce20a 4217PerlIOBuf_tell(pTHX_ PerlIO *f)
9e353e3b 4218{
dcda55fc 4219 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4220 /*
71200d45 4221 * b->posn is file position where b->buf was read, or will be written
14a5cf38
JH		 4222 */
4223 Off_t posn = b->posn;
37725cdc 4224 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
0678cb22
NIS		 4225 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4226#if 1
4227 /* As O_APPEND files are normally shared in some sense it is better
4228 to flush :
4229 */
4230 PerlIO_flush(f);
4231#else
37725cdc 4232 /* when file is NOT shared then this is sufficient */
0678cb22
NIS		 4233 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4234#endif
4235 posn = b->posn = PerlIO_tell(PerlIONext(f));
4236 }
14a5cf38
JH		 4237 if (b->buf) {
4238 /*
71200d45 4239 * If buffer is valid adjust position by amount in buffer
14a5cf38
JH		 4240 */
4241 posn += (b->ptr - b->buf);
4242 }
4243 return posn;
9e353e3b
NIS		 4244}
4245
4246IV
44798d05
NIS		 4247PerlIOBuf_popped(pTHX_ PerlIO *f)
4248{
de009b76
AL		 4249 const IV code = PerlIOBase_popped(aTHX_ f);
4250 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
44798d05
NIS		 4251 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4252 Safefree(b->buf);
4253 }
dcda55fc 4254 b->ptr = b->end = b->buf = NULL;
44798d05
NIS		 4255 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4256 return code;
4257}
4258
4259IV
f62ce20a 4260PerlIOBuf_close(pTHX_ PerlIO *f)
9e353e3b 4261{
de009b76
AL		 4262 const IV code = PerlIOBase_close(aTHX_ f);
4263 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4264 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4265 Safefree(b->buf);
14a5cf38 4266 }
dcda55fc 4267 b->ptr = b->end = b->buf = NULL;
14a5cf38
JH		 4268 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4269 return code;
760ac839
LW		 4270}
4271
9e353e3b 4272STDCHAR *
f62ce20a 4273PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
9e353e3b 4274{
dcda55fc 4275 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4276 if (!b->buf)
4277 PerlIO_get_base(f);
4278 return b->ptr;
9e353e3b
NIS		 4279}
4280
05d1247b 4281SSize_t
f62ce20a 4282PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
9e353e3b 4283{
dcda55fc 4284 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4285 if (!b->buf)
4286 PerlIO_get_base(f);
4287 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4288 return (b->end - b->ptr);
4289 return 0;
9e353e3b
NIS		 4290}
4291
4292STDCHAR *
f62ce20a 4293PerlIOBuf_get_base(pTHX_ PerlIO *f)
9e353e3b 4294{
dcda55fc 4295 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
96a5add6
AL		 4296 PERL_UNUSED_CONTEXT;
4297
14a5cf38
JH		 4298 if (!b->buf) {
4299 if (!b->bufsiz)
1810cd7c 4300 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
d09f14bf 4301 Newx(b->buf,b->bufsiz, STDCHAR);
14a5cf38
JH		 4302 if (!b->buf) {
4303 b->buf = (STDCHAR *) & b->oneword;
4304 b->bufsiz = sizeof(b->oneword);
4305 }
dcda55fc 4306 b->end = b->ptr = b->buf;
06da4f11 4307 }
14a5cf38 4308 return b->buf;
9e353e3b
NIS		 4309}
4310
4311Size_t
f62ce20a 4312PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
9e353e3b 4313{
dcda55fc 4314 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4315 if (!b->buf)
4316 PerlIO_get_base(f);
4317 return (b->end - b->buf);
9e353e3b
NIS		 4318}
4319
4320void
f62ce20a 4321PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 4322{
dcda55fc 4323 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
babfacb9
JH		 4324#ifndef DEBUGGING
4325 PERL_UNUSED_ARG(cnt);
4326#endif
14a5cf38
JH		 4327 if (!b->buf)
4328 PerlIO_get_base(f);
4329 b->ptr = ptr;
b727803b
RGS		 4330 assert(PerlIO_get_cnt(f) == cnt);
4331 assert(b->ptr >= b->buf);
14a5cf38 4332 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW		 4333}
4334
71200d45 4335PerlIO *
ecdeb87c 4336PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 4337{
ecdeb87c 4338 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 4339}
4340
4341
4342
27da23d5 4343PERLIO_FUNCS_DECL(PerlIO_perlio) = {
2dc2558e 4344 sizeof(PerlIO_funcs),
14a5cf38
JH		 4345 "perlio",
4346 sizeof(PerlIOBuf),
86e05cf2 4347 PERLIO_K_BUFFERED|PERLIO_K_RAW,
14a5cf38 4348 PerlIOBuf_pushed,
44798d05 4349 PerlIOBuf_popped,
14a5cf38 4350 PerlIOBuf_open,
86e05cf2 4351 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4352 NULL,
4353 PerlIOBase_fileno,
71200d45 4354 PerlIOBuf_dup,
14a5cf38
JH		 4355 PerlIOBuf_read,
4356 PerlIOBuf_unread,
4357 PerlIOBuf_write,
4358 PerlIOBuf_seek,
4359 PerlIOBuf_tell,
4360 PerlIOBuf_close,
4361 PerlIOBuf_flush,
4362 PerlIOBuf_fill,
4363 PerlIOBase_eof,
4364 PerlIOBase_error,
4365 PerlIOBase_clearerr,
4366 PerlIOBase_setlinebuf,
4367 PerlIOBuf_get_base,
4368 PerlIOBuf_bufsiz,
4369 PerlIOBuf_get_ptr,
4370 PerlIOBuf_get_cnt,
4371 PerlIOBuf_set_ptrcnt,
9e353e3b
NIS		 4372};
4373
66ecd56b 4374/*--------------------------------------------------------------------------------------*/
14a5cf38 4375/*
71200d45 4376 * Temp layer to hold unread chars when cannot do it any other way
14a5cf38 4377 */
5e2ab84b
NIS		 4378
4379IV
f62ce20a 4380PerlIOPending_fill(pTHX_ PerlIO *f)
5e2ab84b 4381{
14a5cf38 4382 /*
71200d45 4383 * Should never happen
14a5cf38
JH		 4384 */
4385 PerlIO_flush(f);
4386 return 0;
5e2ab84b
NIS		 4387}
4388
4389IV
f62ce20a 4390PerlIOPending_close(pTHX_ PerlIO *f)
5e2ab84b 4391{
14a5cf38 4392 /*
71200d45 4393 * A tad tricky - flush pops us, then we close new top
14a5cf38
JH		 4394 */
4395 PerlIO_flush(f);
4396 return PerlIO_close(f);
5e2ab84b
NIS		 4397}
4398
94a175e1 4399IV
f62ce20a 4400PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
5e2ab84b 4401{
14a5cf38 4402 /*
71200d45 4403 * A tad tricky - flush pops us, then we seek new top
14a5cf38
JH		 4404 */
4405 PerlIO_flush(f);
4406 return PerlIO_seek(f, offset, whence);
5e2ab84b
NIS		 4407}
4408
4409
4410IV
f62ce20a 4411PerlIOPending_flush(pTHX_ PerlIO *f)
5e2ab84b 4412{
dcda55fc 4413 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4414 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4415 Safefree(b->buf);
14a5cf38
JH		 4416 b->buf = NULL;
4417 }
4418 PerlIO_pop(aTHX_ f);
4419 return 0;
5e2ab84b
NIS		 4420}
4421
4422void
f62ce20a 4423PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
5e2ab84b 4424{
14a5cf38
JH		 4425 if (cnt <= 0) {
4426 PerlIO_flush(f);
4427 }
4428 else {
f62ce20a 4429 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
14a5cf38 4430 }
5e2ab84b
NIS		 4431}
4432
4433IV
2dc2558e 4434PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 4435{
de009b76 4436 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
dcda55fc 4437 PerlIOl * const l = PerlIOBase(f);
14a5cf38 4438 /*
71200d45
NIS		 4439 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4440 * etc. get muddled when it changes mid-string when we auto-pop.
14a5cf38
JH		 4441 */
4442 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4443 (PerlIOBase(PerlIONext(f))->
4444 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4445 return code;
5e2ab84b
NIS		 4446}
4447
4448SSize_t
f62ce20a 4449PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
5e2ab84b 4450{
14a5cf38
JH		 4451 SSize_t avail = PerlIO_get_cnt(f);
4452 SSize_t got = 0;
94e529cc 4453 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
14a5cf38
JH		 4454 avail = count;
4455 if (avail > 0)
f62ce20a 4456 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
eb160463 4457 if (got >= 0 && got < (SSize_t)count) {
de009b76 4458 const SSize_t more =
14a5cf38
JH		 4459 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4460 if (more >= 0 || got == 0)
4461 got += more;
4462 }
4463 return got;
5e2ab84b
NIS		 4464}
4465
27da23d5 4466PERLIO_FUNCS_DECL(PerlIO_pending) = {
2dc2558e 4467 sizeof(PerlIO_funcs),
14a5cf38
JH		 4468 "pending",
4469 sizeof(PerlIOBuf),
86e05cf2 4470 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
14a5cf38 4471 PerlIOPending_pushed,
44798d05 4472 PerlIOBuf_popped,
14a5cf38 4473 NULL,
86e05cf2 4474 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4475 NULL,
4476 PerlIOBase_fileno,
71200d45 4477 PerlIOBuf_dup,
14a5cf38
JH		 4478 PerlIOPending_read,
4479 PerlIOBuf_unread,
4480 PerlIOBuf_write,
4481 PerlIOPending_seek,
4482 PerlIOBuf_tell,
4483 PerlIOPending_close,
4484 PerlIOPending_flush,
4485 PerlIOPending_fill,
4486 PerlIOBase_eof,
4487 PerlIOBase_error,
4488 PerlIOBase_clearerr,
4489 PerlIOBase_setlinebuf,
4490 PerlIOBuf_get_base,
4491 PerlIOBuf_bufsiz,
4492 PerlIOBuf_get_ptr,
4493 PerlIOBuf_get_cnt,
4494 PerlIOPending_set_ptrcnt,
5e2ab84b
NIS		 4495};
4496
4497
4498
4499/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4500/*
4501 * crlf - translation On read translate CR,LF to "\n" we do this by
4502 * overriding ptr/cnt entries to hand back a line at a time and keeping a
71200d45 4503 * record of which nl we "lied" about. On write translate "\n" to CR,LF
93c2c2ec
IZ		 4504 *
4505 * c->nl points on the first byte of CR LF pair when it is temporarily
4506 * replaced by LF, or to the last CR of the buffer. In the former case
4507 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4508 * that it ends at c->nl; these two cases can be distinguished by
4509 * *c->nl. c->nl is set during _getcnt() call, and unset during
4510 * _unread() and _flush() calls.
4511 * It only matters for read operations.
66ecd56b
NIS		 4512 */
4513
14a5cf38 4514typedef struct {
22569500
NIS		 4515 PerlIOBuf base; /* PerlIOBuf stuff */
4516 STDCHAR *nl; /* Position of crlf we "lied" about in the
14a5cf38 4517 * buffer */
99efab12
NIS		 4518} PerlIOCrlf;
4519
ff1e3883
JD		 4520/* Inherit the PERLIO_F_UTF8 flag from previous layer.
4521 * Otherwise the :crlf layer would always revert back to
4522 * raw mode.
4523 */
4524static void
4525S_inherit_utf8_flag(PerlIO *f)
4526{
4527 PerlIO *g = PerlIONext(f);
4528 if (PerlIOValid(g)) {
4529 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4530 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4531 }
4532 }
4533}
4534
f5b9d040 4535IV
2dc2558e 4536PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
f5b9d040 4537{
14a5cf38
JH		 4538 IV code;
4539 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2dc2558e 4540 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b 4541#if 0
e17bc05a 4542 DEBUG_i(
14a5cf38 4543 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
6c9570dc 4544 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
14a5cf38 4545 PerlIOBase(f)->flags);
e17bc05a 4546 );
5e2ab84b 4547#endif
8229d19f 4548 {
5da08ab0
LT		 4549 /* If the old top layer is a CRLF layer, reactivate it (if
4550 * necessary) and remove this new layer from the stack */
8229d19f 4551 PerlIO *g = PerlIONext(f);
7826b36f 4552 if (PerlIOValid(g)) {
8229d19f
JH		 4553 PerlIOl *b = PerlIOBase(g);
4554 if (b && b->tab == &PerlIO_crlf) {
4555 if (!(b->flags & PERLIO_F_CRLF))
4556 b->flags |= PERLIO_F_CRLF;
ff1e3883 4557 S_inherit_utf8_flag(g);
8229d19f
JH		 4558 PerlIO_pop(aTHX_ f);
4559 return code;
7826b36f 4560 }
8229d19f
JH		 4561 }
4562 }
ff1e3883 4563 S_inherit_utf8_flag(f);
14a5cf38 4564 return code;
f5b9d040
NIS		 4565}
4566
4567
99efab12 4568SSize_t
f62ce20a 4569PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4570{
dcda55fc 4571 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
93c2c2ec 4572 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
76e6dc3a 4573 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4574 c->nl = NULL;
4575 }
4576 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4577 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 4578 else {
4579 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4580 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4581 SSize_t unread = 0;
4582 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4583 PerlIO_flush(f);
4584 if (!b->buf)
4585 PerlIO_get_base(f);
4586 if (b->buf) {
4587 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4588 b->end = b->ptr = b->buf + b->bufsiz;
4589 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4590 b->posn -= b->bufsiz;
4591 }
4592 while (count > 0 && b->ptr > b->buf) {
dcda55fc 4593 const int ch = *--buf;
14a5cf38
JH		 4594 if (ch == '\n') {
4595 if (b->ptr - 2 >= b->buf) {
76e6dc3a
KW		 4596 *--(b->ptr) = NATIVE_0xa;
4597 *--(b->ptr) = NATIVE_0xd;
14a5cf38
JH		 4598 unread++;
4599 count--;
4600 }
4601 else {
93c2c2ec 4602 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
76e6dc3a
KW		 4603 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4604 '\r' */
93c2c2ec
IZ		 4605 unread++;
4606 count--;
14a5cf38
JH		 4607 }
4608 }
4609 else {
4610 *--(b->ptr) = ch;
4611 unread++;
4612 count--;
4613 }
4614 }
4615 }
ec1da995
LT		 4616 if (count > 0)
4617 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
14a5cf38
JH		 4618 return unread;
4619 }
99efab12
NIS		 4620}
4621
93c2c2ec 4622/* XXXX This code assumes that buffer size >=2, but does not check it... */
99efab12 4623SSize_t
f62ce20a 4624PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
99efab12 4625{
dcda55fc 4626 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4627 if (!b->buf)
4628 PerlIO_get_base(f);
4629 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
dcda55fc 4630 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
76e6dc3a 4631 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
23b3c6af 4632 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
14a5cf38 4633 scan:
76e6dc3a 4634 while (nl < b->end && *nl != NATIVE_0xd)
14a5cf38 4635 nl++;
76e6dc3a 4636 if (nl < b->end && *nl == NATIVE_0xd) {
14a5cf38
JH		 4637 test:
4638 if (nl + 1 < b->end) {
76e6dc3a 4639 if (nl[1] == NATIVE_0xa) {
14a5cf38
JH		 4640 *nl = '\n';
4641 c->nl = nl;
4642 }
4643 else {
4644 /*
71200d45 4645 * Not CR,LF but just CR
14a5cf38
JH		 4646 */
4647 nl++;
4648 goto scan;
4649 }
4650 }
4651 else {
4652 /*
71200d45 4653 * Blast - found CR as last char in buffer
14a5cf38 4654 */
e87a358a 4655
14a5cf38
JH		 4656 if (b->ptr < nl) {
4657 /*
4658 * They may not care, defer work as long as
71200d45 4659 * possible
14a5cf38 4660 */
a0d1d361 4661 c->nl = nl;
14a5cf38
JH		 4662 return (nl - b->ptr);
4663 }
4664 else {
4665 int code;
22569500 4666 b->ptr++; /* say we have read it as far as
14a5cf38 4667 * flush() is concerned */
22569500 4668 b->buf++; /* Leave space in front of buffer */
e949e37c
NIS		 4669 /* Note as we have moved buf up flush's
4670 posn += ptr-buf
4671 will naturally make posn point at CR
4672 */
22569500
NIS		 4673 b->bufsiz--; /* Buffer is thus smaller */
4674 code = PerlIO_fill(f); /* Fetch some more */
4675 b->bufsiz++; /* Restore size for next time */
4676 b->buf--; /* Point at space */
4677 b->ptr = nl = b->buf; /* Which is what we hand
14a5cf38 4678 * off */
76e6dc3a 4679 *nl = NATIVE_0xd; /* Fill in the CR */
14a5cf38 4680 if (code == 0)
22569500 4681 goto test; /* fill() call worked */
14a5cf38 4682 /*
71200d45 4683 * CR at EOF - just fall through
14a5cf38 4684 */
a0d1d361 4685 /* Should we clear EOF though ??? */
14a5cf38
JH		 4686 }
4687 }
4688 }
4689 }
4690 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4691 }
4692 return 0;
99efab12
NIS		 4693}
4694
4695void
f62ce20a 4696PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
14a5cf38 4697{
dcda55fc
AL		 4698 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4699 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38
JH		 4700 if (!b->buf)
4701 PerlIO_get_base(f);
4702 if (!ptr) {
a0d1d361 4703 if (c->nl) {
14a5cf38 4704 ptr = c->nl + 1;
76e6dc3a 4705 if (ptr == b->end && *c->nl == NATIVE_0xd) {
486ec47a 4706 /* Deferred CR at end of buffer case - we lied about count */
22569500
NIS		 4707 ptr--;
4708 }
4709 }
14a5cf38
JH		 4710 else {
4711 ptr = b->end;
14a5cf38
JH		 4712 }
4713 ptr -= cnt;
4714 }
4715 else {
6f207bd3 4716 NOOP;
3b4bd3fd 4717#if 0
14a5cf38 4718 /*
71200d45 4719 * Test code - delete when it works ...
14a5cf38 4720 */
3b4bd3fd 4721 IV flags = PerlIOBase(f)->flags;
ba7abf9d 4722 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
76e6dc3a 4723 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
486ec47a 4724 /* Deferred CR at end of buffer case - we lied about count */
a0d1d361 4725 chk--;
22569500 4726 }
14a5cf38
JH		 4727 chk -= cnt;
4728
a0d1d361 4729 if (ptr != chk ) {
99ef548b 4730 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
6c9570dc
MHM		 4731 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4732 flags, c->nl, b->end, cnt);
14a5cf38 4733 }
99ef548b 4734#endif
14a5cf38
JH		 4735 }
4736 if (c->nl) {
4737 if (ptr > c->nl) {
4738 /*
71200d45 4739 * They have taken what we lied about
14a5cf38 4740 */
76e6dc3a 4741 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4742 c->nl = NULL;
4743 ptr++;
4744 }
4745 }
4746 b->ptr = ptr;
4747 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
99efab12
NIS		 4748}
4749
4750SSize_t
f62ce20a 4751PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4752{
14a5cf38 4753 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4754 return PerlIOBuf_write(aTHX_ f, vbuf, count);
14a5cf38 4755 else {
dcda55fc 4756 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4757 const STDCHAR *buf = (const STDCHAR *) vbuf;
dcda55fc 4758 const STDCHAR * const ebuf = buf + count;
14a5cf38
JH		 4759 if (!b->buf)
4760 PerlIO_get_base(f);
4761 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4762 return 0;
4763 while (buf < ebuf) {
dcda55fc 4764 const STDCHAR * const eptr = b->buf + b->bufsiz;
14a5cf38
JH		 4765 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4766 while (buf < ebuf && b->ptr < eptr) {
4767 if (*buf == '\n') {
4768 if ((b->ptr + 2) > eptr) {
4769 /*
71200d45 4770 * Not room for both
14a5cf38
JH		 4771 */
4772 PerlIO_flush(f);
4773 break;
4774 }
4775 else {
76e6dc3a
KW		 4776 *(b->ptr)++ = NATIVE_0xd; /* CR */
4777 *(b->ptr)++ = NATIVE_0xa; /* LF */
14a5cf38
JH		 4778 buf++;
4779 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4780 PerlIO_flush(f);
4781 break;
4782 }
4783 }
4784 }
4785 else {
dcda55fc 4786 *(b->ptr)++ = *buf++;
14a5cf38
JH		 4787 }
4788 if (b->ptr >= eptr) {
4789 PerlIO_flush(f);
4790 break;
4791 }
4792 }
4793 }
4794 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4795 PerlIO_flush(f);
4796 return (buf - (STDCHAR *) vbuf);
4797 }
99efab12
NIS		 4798}
4799
4800IV
f62ce20a 4801PerlIOCrlf_flush(pTHX_ PerlIO *f)
99efab12 4802{
dcda55fc 4803 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38 4804 if (c->nl) {
76e6dc3a 4805 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4806 c->nl = NULL;
4807 }
f62ce20a 4808 return PerlIOBuf_flush(aTHX_ f);
99efab12
NIS		 4809}
4810
86e05cf2
NIS		 4811IV
4812PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4813{
4814 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4815 /* In text mode - flush any pending stuff and flip it */
4816 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4817#ifndef PERLIO_USING_CRLF
4818 /* CRLF is unusual case - if this is just the :crlf layer pop it */
5fae6dc1 4819 PerlIO_pop(aTHX_ f);
86e05cf2
NIS		 4820#endif
4821 }
dda4a477 4822 return PerlIOBase_binmode(aTHX_ f);
86e05cf2
NIS		 4823}
4824
27da23d5 4825PERLIO_FUNCS_DECL(PerlIO_crlf) = {
2dc2558e 4826 sizeof(PerlIO_funcs),
14a5cf38
JH		 4827 "crlf",
4828 sizeof(PerlIOCrlf),
86e05cf2 4829 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
14a5cf38 4830 PerlIOCrlf_pushed,
44798d05 4831 PerlIOBuf_popped, /* popped */
14a5cf38 4832 PerlIOBuf_open,
86e05cf2 4833 PerlIOCrlf_binmode, /* binmode */
14a5cf38
JH		 4834 NULL,
4835 PerlIOBase_fileno,
71200d45 4836 PerlIOBuf_dup,
de009b76 4837 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
22569500
NIS		 4838 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4839 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
14a5cf38
JH		 4840 PerlIOBuf_seek,
4841 PerlIOBuf_tell,
4842 PerlIOBuf_close,
4843 PerlIOCrlf_flush,
4844 PerlIOBuf_fill,
4845 PerlIOBase_eof,
4846 PerlIOBase_error,
4847 PerlIOBase_clearerr,
4848 PerlIOBase_setlinebuf,
4849 PerlIOBuf_get_base,
4850 PerlIOBuf_bufsiz,
4851 PerlIOBuf_get_ptr,
4852 PerlIOCrlf_get_cnt,
4853 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS		 4854};
4855
9e353e3b 4856PerlIO *
e87a358a 4857Perl_PerlIO_stdin(pTHX)
9e353e3b 4858{
a1ea730d 4859 if (!PL_perlio) {
14a5cf38
JH		 4860 PerlIO_stdstreams(aTHX);
4861 }
303f2dc3 4862 return (PerlIO*)&PL_perlio[1];
9e353e3b
NIS		 4863}
4864
9e353e3b 4865PerlIO *
e87a358a 4866Perl_PerlIO_stdout(pTHX)
9e353e3b 4867{
a1ea730d 4868 if (!PL_perlio) {
14a5cf38
JH		 4869 PerlIO_stdstreams(aTHX);
4870 }
303f2dc3 4871 return (PerlIO*)&PL_perlio[2];
9e353e3b
NIS		 4872}
4873
9e353e3b 4874PerlIO *
e87a358a 4875Perl_PerlIO_stderr(pTHX)
9e353e3b 4876{
a1ea730d 4877 if (!PL_perlio) {
14a5cf38
JH		 4878 PerlIO_stdstreams(aTHX);
4879 }
303f2dc3 4880 return (PerlIO*)&PL_perlio[3];
9e353e3b
NIS		 4881}
4882
4883/*--------------------------------------------------------------------------------------*/
4884
9e353e3b
NIS		 4885char *
4886PerlIO_getname(PerlIO *f, char *buf)
4887{
a15cef0c 4888#ifdef VMS
dbf7dff6 4889 dTHX;
73d840c0 4890 char *name = NULL;
7659f319 4891 bool exported = FALSE;
14a5cf38 4892 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
7659f319
CB		 4893 if (!stdio) {
4894 stdio = PerlIO_exportFILE(f,0);
4895 exported = TRUE;
4896 }
4897 if (stdio) {
14a5cf38 4898 name = fgetname(stdio, buf);
7659f319
CB		 4899 if (exported) PerlIO_releaseFILE(f,stdio);
4900 }
73d840c0 4901 return name;
a15cef0c 4902#else
8772537c
AL		 4903 PERL_UNUSED_ARG(f);
4904 PERL_UNUSED_ARG(buf);
dbf7dff6 4905 Perl_croak_nocontext("Don't know how to get file name");
bd61b366 4906 return NULL;
a15cef0c 4907#endif
9e353e3b
NIS		 4908}
4909
4910
4911/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4912/*
4913 * Functions which can be called on any kind of PerlIO implemented in
71200d45 4914 * terms of above
14a5cf38 4915 */
9e353e3b 4916
e87a358a
NIS		 4917#undef PerlIO_fdopen
4918PerlIO *
4919PerlIO_fdopen(int fd, const char *mode)
4920{
4921 dTHX;
bd61b366 4922 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
e87a358a
NIS		 4923}
4924
4925#undef PerlIO_open
4926PerlIO *
4927PerlIO_open(const char *path, const char *mode)
4928{
4929 dTHX;
42d9b98d 4930 SV *name = sv_2mortal(newSVpv(path, 0));
bd61b366 4931 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
e87a358a
NIS		 4932}
4933
4934#undef Perlio_reopen
4935PerlIO *
4936PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4937{
4938 dTHX;
42d9b98d 4939 SV *name = sv_2mortal(newSVpv(path,0));
bd61b366 4940 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
e87a358a
NIS		 4941}
4942
9e353e3b 4943#undef PerlIO_getc
6f9d8c32 4944int
9e353e3b 4945PerlIO_getc(PerlIO *f)
760ac839 4946{
e87a358a 4947 dTHX;
14a5cf38 4948 STDCHAR buf[1];
de009b76 4949 if ( 1 == PerlIO_read(f, buf, 1) ) {
14a5cf38
JH		 4950 return (unsigned char) buf[0];
4951 }
4952 return EOF;
313ca112
NIS		 4953}
4954
4955#undef PerlIO_ungetc
4956int
4957PerlIO_ungetc(PerlIO *f, int ch)
4958{
e87a358a 4959 dTHX;
14a5cf38
JH		 4960 if (ch != EOF) {
4961 STDCHAR buf = ch;
4962 if (PerlIO_unread(f, &buf, 1) == 1)
4963 return ch;
4964 }
4965 return EOF;
760ac839
LW		 4966}
4967
9e353e3b
NIS		 4968#undef PerlIO_putc
4969int
4970PerlIO_putc(PerlIO *f, int ch)
760ac839 4971{
e87a358a 4972 dTHX;
14a5cf38
JH		 4973 STDCHAR buf = ch;
4974 return PerlIO_write(f, &buf, 1);
760ac839
LW		 4975}
4976
9e353e3b 4977#undef PerlIO_puts
760ac839 4978int
9e353e3b 4979PerlIO_puts(PerlIO *f, const char *s)
760ac839 4980{
e87a358a 4981 dTHX;
dcda55fc 4982 return PerlIO_write(f, s, strlen(s));
760ac839
LW		 4983}
4984
4985#undef PerlIO_rewind
4986void
c78749f2 4987PerlIO_rewind(PerlIO *f)
760ac839 4988{
e87a358a 4989 dTHX;
14a5cf38
JH		 4990 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4991 PerlIO_clearerr(f);
6f9d8c32
NIS		 4992}
4993
4994#undef PerlIO_vprintf
4995int
4996PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4997{
14a5cf38 4998 dTHX;
53ce71d3 4999 SV * sv;
b83604b4 5000 const char *s;
14a5cf38
JH		 5001 STRLEN len;
5002 SSize_t wrote;
2cc61e15 5003#ifdef NEED_VA_COPY
14a5cf38
JH		 5004 va_list apc;
5005 Perl_va_copy(ap, apc);
53ce71d3 5006 sv = vnewSVpvf(fmt, &apc);
d4825b27 5007 va_end(apc);
2cc61e15 5008#else
53ce71d3 5009 sv = vnewSVpvf(fmt, &ap);
2cc61e15 5010#endif
b83604b4 5011 s = SvPV_const(sv, len);
14a5cf38
JH		 5012 wrote = PerlIO_write(f, s, len);
5013 SvREFCNT_dec(sv);
5014 return wrote;
760ac839
LW		 5015}
5016
5017#undef PerlIO_printf
6f9d8c32 5018int
14a5cf38 5019PerlIO_printf(PerlIO *f, const char *fmt, ...)
760ac839 5020{
14a5cf38
JH		 5021 va_list ap;
5022 int result;
5023 va_start(ap, fmt);
5024 result = PerlIO_vprintf(f, fmt, ap);
5025 va_end(ap);
5026 return result;
760ac839
LW		 5027}
5028
5029#undef PerlIO_stdoutf
6f9d8c32 5030int
14a5cf38 5031PerlIO_stdoutf(const char *fmt, ...)
760ac839 5032{
e87a358a 5033 dTHX;
14a5cf38
JH		 5034 va_list ap;
5035 int result;
5036 va_start(ap, fmt);
5037 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5038 va_end(ap);
5039 return result;
760ac839
LW		 5040}
5041
5042#undef PerlIO_tmpfile
5043PerlIO *
c78749f2 5044PerlIO_tmpfile(void)
760ac839 5045{
dbf7dff6 5046#ifndef WIN32
2941a2e1 5047 dTHX;
dbf7dff6 5048#endif
2941a2e1 5049 PerlIO *f = NULL;
2941a2e1 5050#ifdef WIN32
de009b76 5051 const int fd = win32_tmpfd();
2941a2e1
JH		 5052 if (fd >= 0)
5053 f = PerlIO_fdopen(fd, "w+b");
d333cbeb 5054#elif ! defined(VMS) && ! defined(OS2)
0b99e986
RGS		 5055 int fd = -1;
5056 char tempname[] = "/tmp/PerlIO_XXXXXX";
284167a5 5057 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
525f6fe9 5058 SV * sv = NULL;
e57270be 5059 int old_umask = umask(0177);
7299ca58 5060 if (tmpdir && *tmpdir) {
0b99e986 5061 /* if TMPDIR is set and not empty, we try that first */
7299ca58 5062 sv = newSVpv(tmpdir, 0);
0b99e986 5063 sv_catpv(sv, tempname + 4);
884fc2d3 5064 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
0b99e986
RGS		 5065 }
5066 if (fd < 0) {
e40f8e80 5067 SvREFCNT_dec(sv);
7299ca58 5068 sv = NULL;
0b99e986 5069 /* else we try /tmp */
884fc2d3 5070 fd = Perl_my_mkstemp_cloexec(tempname);
0b99e986 5071 }
b7561fc9
BF		 5072 if (fd < 0) {
5073 /* Try cwd */
5074 sv = newSVpvs(".");
5075 sv_catpv(sv, tempname + 4);
884fc2d3 5076 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
b7561fc9 5077 }
60f7fc1e 5078 umask(old_umask);
2941a2e1
JH		 5079 if (fd >= 0) {
5080 f = PerlIO_fdopen(fd, "w+");
5081 if (f)
5082 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
0b99e986 5083 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
2941a2e1 5084 }
ef8d46e8 5085 SvREFCNT_dec(sv);
faf55891 5086#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
c4420975 5087 FILE * const stdio = PerlSIO_tmpfile();
2941a2e1 5088
085e731f
CB		 5089 if (stdio)
5090 f = PerlIO_fdopen(fileno(stdio), "w+");
5091
2941a2e1
JH		 5092#endif /* else WIN32 */
5093 return f;
760ac839
LW		 5094}
5095
0ea86a10
FC		 5096void
5097Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5098{
e9b8343f 5099 PERL_UNUSED_CONTEXT;
0ea86a10
FC		 5100 if (!PerlIOValid(f))
5101 return;
5102 PerlIOBase(f)->err = errno;
5103#ifdef VMS
5104 PerlIOBase(f)->os_err = vaxc$errno;
5105#elif defined(OS2)
5106 PerlIOBase(f)->os_err = Perl_rc;
5107#elif defined(WIN32)
5108 PerlIOBase(f)->os_err = GetLastError();
5109#endif
5110}
5111
5112void
5113Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5114{
e9b8343f 5115 PERL_UNUSED_CONTEXT;
0ea86a10
FC		 5116 if (!PerlIOValid(f))
5117 return;
5118 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5119#ifdef OS2
5120 Perl_rc = PerlIOBase(f)->os_err);
5121#elif defined(WIN32)
5122 SetLastError(PerlIOBase(f)->os_err);
5123#endif
5124}
5125
6f9d8c32
NIS		 5126#undef HAS_FSETPOS
5127#undef HAS_FGETPOS
5128
760ac839 5129
9e353e3b 5130/*======================================================================================*/
14a5cf38 5131/*
71200d45
NIS		 5132 * Now some functions in terms of above which may be needed even if we are
5133 * not in true PerlIO mode
9e353e3b 5134 */
188f0c84
YO		 5135const char *
5136Perl_PerlIO_context_layers(pTHX_ const char *mode)
5137{
8b850bd5
NC		 5138 const char *direction = NULL;
5139 SV *layers;
188f0c84
YO		 5140 /*
5141 * Need to supply default layer info from open.pm
5142 */
8b850bd5
NC		 5143
5144 if (!PL_curcop)
5145 return NULL;
5146
5147 if (mode && mode[0] != 'r') {
5148 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5149 direction = "open>";
5150 } else {
5151 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5152 direction = "open<";
188f0c84 5153 }
8b850bd5
NC		 5154 if (!direction)
5155 return NULL;
5156
20439bc7 5157 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
8b850bd5
NC		 5158
5159 assert(layers);
5160 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
188f0c84
YO		 5161}
5162
9e353e3b 5163
760ac839
LW		 5164#ifndef HAS_FSETPOS
5165#undef PerlIO_setpos
5166int
766a733e 5167PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 5168{
14a5cf38 5169 if (SvOK(pos)) {
e1a83e70
DD		 5170 if (f) {
5171 dTHX;
5172 STRLEN len;
5173 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5174 if(len == sizeof(Off_t))
5175 return PerlIO_seek(f, *posn, SEEK_SET);
5176 }
14a5cf38 5177 }
93189314 5178 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5179 return -1;
760ac839 5180}
c411622e 5181#else
c411622e 5182#undef PerlIO_setpos
5183int
766a733e 5184PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 5185{
14a5cf38 5186 if (SvOK(pos)) {
e1a83e70
DD		 5187 if (f) {
5188 dTHX;
5189 STRLEN len;
5190 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5191 if(len == sizeof(Fpos_t))
2d4389e4 5192#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
e1a83e70 5193 return fsetpos64(f, fpos);
d9b3e12d 5194#else
e1a83e70 5195 return fsetpos(f, fpos);
d9b3e12d 5196#endif
14a5cf38 5197 }
766a733e 5198 }
93189314 5199 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5200 return -1;
c411622e 5201}
5202#endif
760ac839
LW		 5203
5204#ifndef HAS_FGETPOS
5205#undef PerlIO_getpos
5206int
766a733e 5207PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 5208{
14a5cf38
JH		 5209 dTHX;
5210 Off_t posn = PerlIO_tell(f);
5211 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5212 return (posn == (Off_t) - 1) ? -1 : 0;
760ac839 5213}
c411622e 5214#else
c411622e 5215#undef PerlIO_getpos
5216int
766a733e 5217PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 5218{
14a5cf38
JH		 5219 dTHX;
5220 Fpos_t fpos;
5221 int code;
2d4389e4 5222#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 5223 code = fgetpos64(f, &fpos);
d9b3e12d 5224#else
14a5cf38 5225 code = fgetpos(f, &fpos);
d9b3e12d 5226#endif
14a5cf38
JH		 5227 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5228 return code;
c411622e 5229}
5230#endif
760ac839 5231
db6e00bd
DD		 5232/* print a failure format string message to stderr and fail exit the process
5233 using only libc without depending on any perl data structures being
5234 initialized.
5235*/
5236
5237void
5238Perl_noperl_die(const char* pat, ...)
5239{
fc917fff 5240 va_list arglist;
db6e00bd
DD		 5241 PERL_ARGS_ASSERT_NOPERL_DIE;
5242 va_start(arglist, pat);
5243 vfprintf(stderr, pat, arglist);
5244 va_end(arglist);
5245 exit(1);
5246}
5247
9cfa90c0 5248/*
14d04a33 5249 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5250 */
Unnamed repository; edit this file 'description' to name the repository.