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