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
re/re_tests: Rmv comment
[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 }
14a5cf38 3335 return got;
9e353e3b
NIS		 3336}
3337
3338SSize_t
f62ce20a 3339PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3340{
14a5cf38 3341 SSize_t unread = 0;
c4420975 3342 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3343
313e59c8 3344#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3345 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3346 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3347 STDCHAR *base = PerlIO_get_base(f);
3348 SSize_t cnt = PerlIO_get_cnt(f);
3349 STDCHAR *ptr = PerlIO_get_ptr(f);
3350 SSize_t avail = ptr - base;
3351 if (avail > 0) {
3352 if (avail > count) {
3353 avail = count;
3354 }
3355 ptr -= avail;
3356 Move(buf-avail,ptr,avail,STDCHAR);
3357 count -= avail;
3358 unread += avail;
3359 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS		 3360 if (PerlSIO_feof(s) && unread >= 0)
3361 PerlSIO_clearerr(s);
3362 }
3363 }
313e59c8
NIS		 3364 else
3365#endif
3366 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3367 /* We can get pointer to buffer but not its base
3368 Do ungetc() but check chars are ending up in the
3369 buffer
3370 */
3371 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3372 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3373 while (count > 0) {
de009b76 3374 const int ch = *--buf & 0xFF;
9f7cd136
NIS		 3375 if (ungetc(ch,s) != ch) {
3376 /* ungetc did not work */
3377 break;
3378 }
3379 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3380 /* Did not change pointer as expected */
375ed12a
JH		 3381 if (fgetc(s) != EOF) /* get char back again */
3382 break;
9f7cd136
NIS		 3383 }
3384 /* It worked ! */
3385 count--;
3386 unread++;
93679785
NIS		 3387 }
3388 }
3389
3390 if (count > 0) {
3391 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 3392 }
3393 return unread;
9e353e3b
NIS		 3394}
3395
3396SSize_t
f62ce20a 3397PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3398{
4d948241 3399 SSize_t got;
abf9167d
DM		 3400 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3401 return -1;
4d948241
NIS		 3402 for (;;) {
3403 got = PerlSIO_fwrite(vbuf, 1, count,
3404 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3405 if (got >= 0 || errno != EINTR)
4d948241 3406 break;
abf9167d
DM		 3407 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3408 return -1;
42a7a32f 3409 SETERRNO(0,0); /* just in case */
4d948241
NIS		 3410 }
3411 return got;
9e353e3b
NIS		 3412}
3413
94a175e1 3414IV
f62ce20a 3415PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3416{
c4420975 3417 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3418 PERL_UNUSED_CONTEXT;
3419
94a175e1 3420 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS		 3421}
3422
3423Off_t
f62ce20a 3424PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3425{
c4420975 3426 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3427 PERL_UNUSED_CONTEXT;
3428
94a175e1 3429 return PerlSIO_ftell(stdio);
9e353e3b
NIS		 3430}
3431
3432IV
f62ce20a 3433PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3434{
c4420975 3435 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL		 3436 PERL_UNUSED_CONTEXT;
3437
14a5cf38
JH		 3438 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3439 return PerlSIO_fflush(stdio);
3440 }
3441 else {
6f207bd3 3442 NOOP;
88b61e10 3443#if 0
14a5cf38
JH		 3444 /*
3445 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3446 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3447 * design is to do _this_ but not have layer above flush this
71200d45 3448 * layer read-to-read
14a5cf38
JH		 3449 */
3450 /*
71200d45 3451 * Not writeable - sync by attempting a seek
14a5cf38 3452 */
4ee39169 3453 dSAVE_ERRNO;
14a5cf38 3454 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3455 RESTORE_ERRNO;
88b61e10 3456#endif
14a5cf38
JH		 3457 }
3458 return 0;
9e353e3b
NIS		 3459}
3460
3461IV
f62ce20a 3462PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3463{
96a5add6
AL		 3464 PERL_UNUSED_CONTEXT;
3465
14a5cf38 3466 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3467}
3468
3469IV
f62ce20a 3470PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3471{
96a5add6
AL		 3472 PERL_UNUSED_CONTEXT;
3473
263df5f1 3474 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3475}
3476
3477void
f62ce20a 3478PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3479{
96a5add6
AL		 3480 PERL_UNUSED_CONTEXT;
3481
14a5cf38 3482 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3483}
3484
3485void
f62ce20a 3486PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3487{
96a5add6
AL		 3488 PERL_UNUSED_CONTEXT;
3489
9e353e3b 3490#ifdef HAS_SETLINEBUF
14a5cf38 3491 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3492#else
bd61b366 3493 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS		 3494#endif
3495}
3496
3497#ifdef FILE_base
3498STDCHAR *
f62ce20a 3499PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3500{
c4420975 3501 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3502 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS		 3503}
3504
3505Size_t
f62ce20a 3506PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3507{
c4420975 3508 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3509 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS		 3510}
3511#endif
3512
3513#ifdef USE_STDIO_PTR
3514STDCHAR *
f62ce20a 3515PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3516{
c4420975 3517 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3518 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS		 3519}
3520
3521SSize_t
f62ce20a 3522PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3523{
c4420975 3524 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3525 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS		 3526}
3527
3528void
f62ce20a 3529PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3530{
c4420975 3531 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3532 if (ptr != NULL) {
9e353e3b 3533#ifdef STDIO_PTR_LVALUE
46f05249
JH		 3534 /* This is a long-standing infamous mess. The root of the
3535 * problem is that one cannot know the signedness of char, and
3536 * more precisely the signedness of FILE._ptr. The following
3537 * things have been tried, and they have all failed (across
3538 * different compilers (remember that core needs to to build
3539 * also with c++) and compiler options:
3540 *
3541 * - casting the RHS to (void*) -- works in *some* places
3542 * - casting the LHS to (void*) -- totally unportable
3543 *
3544 * So let's try silencing the warning at least for gcc. */
3545 GCC_DIAG_IGNORE(-Wpointer-sign);
d06fc7d4 3546 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
46f05249 3547 GCC_DIAG_RESTORE;
9e353e3b 3548#ifdef STDIO_PTR_LVAL_SETS_CNT
f8a4dbc5 3549 assert(PerlSIO_get_cnt(stdio) == (cnt));
9e353e3b
NIS		 3550#endif
3551#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3552 /*
71200d45 3553 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH		 3554 */
3555 return;
9e353e3b 3556#endif
22569500 3557#else /* STDIO_PTR_LVALUE */
14a5cf38 3558 PerlProc_abort();
22569500 3559#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH		 3560 }
3561 /*
71200d45 3562 * Now (or only) set cnt
14a5cf38 3563 */
9e353e3b 3564#ifdef STDIO_CNT_LVALUE
14a5cf38 3565 PerlSIO_set_cnt(stdio, cnt);
22569500 3566#else /* STDIO_CNT_LVALUE */
9e353e3b 3567#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH		 3568 PerlSIO_set_ptr(stdio,
3569 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3570 cnt));
22569500 3571#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3572 PerlProc_abort();
22569500
NIS		 3573#endif /* STDIO_PTR_LVAL_SETS_CNT */
3574#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS		 3575}
3576
93679785 3577
9e353e3b
NIS		 3578#endif
3579
93679785
NIS		 3580IV
3581PerlIOStdio_fill(pTHX_ PerlIO *f)
3582{
abf9167d 3583 FILE * stdio;
93679785 3584 int c;
96a5add6 3585 PERL_UNUSED_CONTEXT;
abf9167d
DM		 3586 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3587 return -1;
3588 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6 3589
93679785
NIS		 3590 /*
3591 * fflush()ing read-only streams can cause trouble on some stdio-s
3592 */
3593 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3594 if (PerlSIO_fflush(stdio) != 0)
3595 return EOF;
3596 }
f3be3723
BL		 3597 for (;;) {
3598 c = PerlSIO_fgetc(stdio);
3599 if (c != EOF)
3600 break;
3601 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3602 return EOF;
abf9167d
DM		 3603 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3604 return -1;
f3be3723
BL		 3605 SETERRNO(0,0);
3606 }
93679785
NIS		 3607
3608#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS		 3609
3610#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3611 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3612 /* Fake ungetc() to the real buffer in case system's ungetc
3613 goes elsewhere
3614 */
3615 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3616 SSize_t cnt = PerlSIO_get_cnt(stdio);
3617 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3618 if (ptr == base+1) {
3619 *--ptr = (STDCHAR) c;
3620 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3621 if (PerlSIO_feof(stdio))
3622 PerlSIO_clearerr(stdio);
3623 return 0;
3624 }
3625 }
313e59c8
NIS		 3626 else
3627#endif
3628 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3629 STDCHAR ch = c;
3630 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3631 return 0;
3632 }
3633 }
93679785
NIS		 3634#endif
3635
93679785 3636 /* If buffer snoop scheme above fails fall back to
9f7cd136 3637 using ungetc().
93679785
NIS		 3638 */
3639 if (PerlSIO_ungetc(c, stdio) != c)
3640 return EOF;
5876737a 3641
93679785
NIS		 3642 return 0;
3643}
3644
3645
3646
27da23d5 3647PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3648 sizeof(PerlIO_funcs),
14a5cf38
JH		 3649 "stdio",
3650 sizeof(PerlIOStdio),
86e05cf2 3651 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3652 PerlIOStdio_pushed,
2376d97d 3653 PerlIOBase_popped,
14a5cf38 3654 PerlIOStdio_open,
86e05cf2 3655 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 3656 NULL,
3657 PerlIOStdio_fileno,
71200d45 3658 PerlIOStdio_dup,
14a5cf38
JH		 3659 PerlIOStdio_read,
3660 PerlIOStdio_unread,
3661 PerlIOStdio_write,
3662 PerlIOStdio_seek,
3663 PerlIOStdio_tell,
3664 PerlIOStdio_close,
3665 PerlIOStdio_flush,
3666 PerlIOStdio_fill,
3667 PerlIOStdio_eof,
3668 PerlIOStdio_error,
3669 PerlIOStdio_clearerr,
3670 PerlIOStdio_setlinebuf,
9e353e3b 3671#ifdef FILE_base
14a5cf38
JH		 3672 PerlIOStdio_get_base,
3673 PerlIOStdio_get_bufsiz,
9e353e3b 3674#else
14a5cf38
JH		 3675 NULL,
3676 NULL,
9e353e3b
NIS		 3677#endif
3678#ifdef USE_STDIO_PTR
14a5cf38
JH		 3679 PerlIOStdio_get_ptr,
3680 PerlIOStdio_get_cnt,
15b61c98 3681# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
79ed0f43 3682 PerlIOStdio_set_ptrcnt,
15b61c98
JH		 3683# else
3684 NULL,
3685# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3686#else
3687 NULL,
14a5cf38
JH		 3688 NULL,
3689 NULL,
15b61c98 3690#endif /* USE_STDIO_PTR */
9e353e3b
NIS		 3691};
3692
b9d6bf13
JH		 3693/* Note that calls to PerlIO_exportFILE() are reversed using
3694 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3695FILE *
81428673 3696PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3697{
e87a358a 3698 dTHX;
81428673
NIS		 3699 FILE *stdio = NULL;
3700 if (PerlIOValid(f)) {
3701 char buf[8];
375ed12a
JH		 3702 int fd = PerlIO_fileno(f);
3703 if (fd < 0) {
3704 return NULL;
3705 }
81428673
NIS		 3706 PerlIO_flush(f);
3707 if (!mode || !*mode) {
3708 mode = PerlIO_modestr(f, buf);
3709 }
3710 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3711 if (stdio) {
3712 PerlIOl *l = *f;
9f75cc58 3713 PerlIO *f2;
81428673
NIS		 3714 /* De-link any lower layers so new :stdio sticks */
3715 *f = NULL;
a0714e2c 3716 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
9f75cc58 3717 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673 3718 s->stdio = stdio;
6b54a403 3719 PerlIOUnix_refcnt_inc(fileno(stdio));
81428673
NIS		 3720 /* Link previous lower layers under new one */
3721 *PerlIONext(f) = l;
3722 }
3723 else {
3724 /* restore layers list */
3725 *f = l;
3726 }
a33cf58c 3727 }
14a5cf38
JH		 3728 }
3729 return stdio;
9e353e3b
NIS		 3730}
3731
81428673 3732
9e353e3b
NIS		 3733FILE *
3734PerlIO_findFILE(PerlIO *f)
3735{
14a5cf38 3736 PerlIOl *l = *f;
bbbc33d0 3737 FILE *stdio;
14a5cf38
JH		 3738 while (l) {
3739 if (l->tab == &PerlIO_stdio) {
3740 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3741 return s->stdio;
3742 }
3743 l = *PerlIONext(&l);
f7e7eb72 3744 }
4b069b44 3745 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
bbbc33d0
NC		 3746 /* However, we're not really exporting a FILE * to someone else (who
3747 becomes responsible for closing it, or calling PerlIO_releaseFILE())
486ec47a 3748 So we need to undo its reference count increase on the underlying file
bbbc33d0
NC		 3749 descriptor. We have to do this, because if the loop above returns you
3750 the FILE *, then *it* didn't increase any reference count. So there's
3751 only one way to be consistent. */
3752 stdio = PerlIO_exportFILE(f, NULL);
3753 if (stdio) {
3754 const int fd = fileno(stdio);
3755 if (fd >= 0)
3756 PerlIOUnix_refcnt_dec(fd);
3757 }
3758 return stdio;
9e353e3b
NIS		 3759}
3760
b9d6bf13 3761/* Use this to reverse PerlIO_exportFILE calls. */
9e353e3b
NIS		 3762void
3763PerlIO_releaseFILE(PerlIO *p, FILE *f)
3764{
22569500
NIS		 3765 PerlIOl *l;
3766 while ((l = *p)) {
3767 if (l->tab == &PerlIO_stdio) {
3768 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2bcd6579 3769 if (s->stdio == f) { /* not in a loop */
6b54a403
NC		 3770 const int fd = fileno(f);
3771 if (fd >= 0)
3772 PerlIOUnix_refcnt_dec(fd);
2bcd6579
DD		 3773 {
3774 dTHX;
3775 PerlIO_pop(aTHX_ p);
3776 }
22569500
NIS		 3777 return;
3778 }
3779 }
3780 p = PerlIONext(p);
3781 }
3782 return;
9e353e3b
NIS		 3783}
3784
3785/*--------------------------------------------------------------------------------------*/
14a5cf38 3786/*
71200d45 3787 * perlio buffer layer
14a5cf38 3788 */
9e353e3b 3789
5e2ab84b 3790IV
2dc2558e 3791PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 3792{
14a5cf38 3793 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
de009b76 3794 const int fd = PerlIO_fileno(f);
14a5cf38
JH		 3795 if (fd >= 0 && PerlLIO_isatty(fd)) {
3796 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3797 }
4b069b44 3798 if (*PerlIONext(f)) {
de009b76 3799 const Off_t posn = PerlIO_tell(PerlIONext(f));
4b069b44
NIS		 3800 if (posn != (Off_t) - 1) {
3801 b->posn = posn;
3802 }
14a5cf38 3803 }
2dc2558e 3804 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b
NIS		 3805}
3806
9e353e3b 3807PerlIO *
14a5cf38
JH		 3808PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3809 IV n, const char *mode, int fd, int imode, int perm,
3810 PerlIO *f, int narg, SV **args)
3811{
04892f78 3812 if (PerlIOValid(f)) {
14a5cf38 3813 PerlIO *next = PerlIONext(f);
67363c0d
JH		 3814 PerlIO_funcs *tab =
3815 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3816 if (tab && tab->Open)
3817 next =
3818 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3819 next, narg, args);
2dc2558e 3820 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
14a5cf38
JH		 3821 return NULL;
3822 }
3823 }
3824 else {
04892f78 3825 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38 3826 int init = 0;
3b6c1aba 3827 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 3828 init = 1;
3829 /*
71200d45 3830 * mode++;
14a5cf38
JH		 3831 */
3832 }
67363c0d
JH		 3833 if (tab && tab->Open)
3834 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3835 f, narg, args);
3836 else
3837 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 3838 if (f) {
22569500 3839 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
b26b1ab5
NC		 3840 /*
3841 * if push fails during open, open fails. close will pop us.
3842 */
3843 PerlIO_close (f);
3844 return NULL;
3845 } else {
3846 fd = PerlIO_fileno(f);
b26b1ab5
NC		 3847 if (init && fd == 2) {
3848 /*
3849 * Initial stderr is unbuffered
3850 */
3851 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3852 }
23b84778
IZ		 3853#ifdef PERLIO_USING_CRLF
3854# ifdef PERLIO_IS_BINMODE_FD
3855 if (PERLIO_IS_BINMODE_FD(fd))
bd61b366 3856 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
23b84778
IZ		 3857 else
3858# endif
3859 /*
3860 * do something about failing setmode()? --jhi
3861 */
3862 PerlLIO_setmode(fd, O_BINARY);
3863#endif
8c8488cd 3864#ifdef VMS
8c8488cd
CB		 3865 /* Enable line buffering with record-oriented regular files
3866 * so we don't introduce an extraneous record boundary when
3867 * the buffer fills up.
3868 */
3869 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3870 Stat_t st;
3871 if (PerlLIO_fstat(fd, &st) == 0
3872 && S_ISREG(st.st_mode)
3873 && (st.st_fab_rfm == FAB$C_VAR
3874 || st.st_fab_rfm == FAB$C_VFC)) {
3875 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3876 }
3877 }
3878#endif
14a5cf38
JH		 3879 }
3880 }
ee518936 3881 }
14a5cf38 3882 return f;
9e353e3b
NIS		 3883}
3884
14a5cf38
JH		 3885/*
3886 * This "flush" is akin to sfio's sync in that it handles files in either
93c2c2ec
IZ		 3887 * read or write state. For write state, we put the postponed data through
3888 * the next layers. For read state, we seek() the next layers to the
3889 * offset given by current position in the buffer, and discard the buffer
3890 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3891 * in any case?). Then the pass the stick further in chain.
14a5cf38 3892 */
9e353e3b 3893IV
f62ce20a 3894PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 3895{
dcda55fc 3896 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3897 int code = 0;
04892f78 3898 PerlIO *n = PerlIONext(f);
14a5cf38
JH		 3899 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3900 /*
71200d45 3901 * write() the buffer
14a5cf38 3902 */
de009b76
AL		 3903 const STDCHAR *buf = b->buf;
3904 const STDCHAR *p = buf;
14a5cf38
JH		 3905 while (p < b->ptr) {
3906 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3907 if (count > 0) {
3908 p += count;
3909 }
3910 else if (count < 0 || PerlIO_error(n)) {
3911 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10 3912 PerlIO_save_errno(f);
14a5cf38
JH		 3913 code = -1;
3914 break;
3915 }
3916 }
3917 b->posn += (p - buf);
3918 }
3919 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3920 STDCHAR *buf = PerlIO_get_base(f);
3921 /*
71200d45 3922 * Note position change
14a5cf38
JH		 3923 */
3924 b->posn += (b->ptr - buf);
3925 if (b->ptr < b->end) {
4b069b44
NIS		 3926 /* We did not consume all of it - try and seek downstream to
3927 our logical position
14a5cf38 3928 */
4b069b44 3929 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
04892f78
NIS		 3930 /* Reload n as some layers may pop themselves on seek */
3931 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38 3932 }
ba5c3fe9 3933 else {
4b069b44
NIS		 3934 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3935 data is lost for good - so return saying "ok" having undone
3936 the position adjust
3937 */
3938 b->posn -= (b->ptr - buf);
ba5c3fe9
NIS		 3939 return code;
3940 }
14a5cf38
JH		 3941 }
3942 }
3943 b->ptr = b->end = b->buf;
3944 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78 3945 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
04892f78 3946 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH		 3947 code = -1;
3948 return code;
6f9d8c32
NIS		 3949}
3950
93c2c2ec
IZ		 3951/* This discards the content of the buffer after b->ptr, and rereads
3952 * the buffer from the position off in the layer downstream; here off
3953 * is at offset corresponding to b->ptr - b->buf.
3954 */
06da4f11 3955IV
f62ce20a 3956PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 3957{
dcda55fc 3958 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3959 PerlIO *n = PerlIONext(f);
3960 SSize_t avail;
3961 /*
4b069b44
NIS		 3962 * Down-stream flush is defined not to loose read data so is harmless.
3963 * we would not normally be fill'ing if there was data left in anycase.
14a5cf38 3964 */
93c2c2ec 3965 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
14a5cf38
JH		 3966 return -1;
3967 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
f62ce20a 3968 PerlIOBase_flush_linebuf(aTHX);
14a5cf38
JH		 3969
3970 if (!b->buf)
22569500 3971 PerlIO_get_base(f); /* allocate via vtable */
14a5cf38 3972
0f0eef27 3973 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
ec6fa4f0 3974
14a5cf38 3975 b->ptr = b->end = b->buf;
4b069b44
NIS		 3976
3977 if (!PerlIOValid(n)) {
3978 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3979 return -1;
3980 }
3981
14a5cf38
JH		 3982 if (PerlIO_fast_gets(n)) {
3983 /*
04892f78 3984 * Layer below is also buffered. We do _NOT_ want to call its
14a5cf38
JH		 3985 * ->Read() because that will loop till it gets what we asked for
3986 * which may hang on a pipe etc. Instead take anything it has to
71200d45 3987 * hand, or ask it to fill _once_.
14a5cf38
JH		 3988 */
3989 avail = PerlIO_get_cnt(n);
3990 if (avail <= 0) {
3991 avail = PerlIO_fill(n);
3992 if (avail == 0)
3993 avail = PerlIO_get_cnt(n);
3994 else {
3995 if (!PerlIO_error(n) && PerlIO_eof(n))
3996 avail = 0;
3997 }
3998 }
3999 if (avail > 0) {
4000 STDCHAR *ptr = PerlIO_get_ptr(n);
dcda55fc 4001 const SSize_t cnt = avail;
eb160463 4002 if (avail > (SSize_t)b->bufsiz)
14a5cf38
JH		 4003 avail = b->bufsiz;
4004 Copy(ptr, b->buf, avail, STDCHAR);
4005 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4006 }
4007 }
4008 else {
4009 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4010 }
4011 if (avail <= 0) {
4012 if (avail == 0)
4013 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4014 else
0ea86a10 4015 {
14a5cf38 4016 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
0ea86a10
FC		 4017 PerlIO_save_errno(f);
4018 }
14a5cf38
JH		 4019 return -1;
4020 }
4021 b->end = b->buf + avail;
4022 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4023 return 0;
06da4f11
NIS		 4024}
4025
6f9d8c32 4026SSize_t
f62ce20a 4027PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 4028{
04892f78 4029 if (PerlIOValid(f)) {
dcda55fc 4030 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4031 if (!b->ptr)
4032 PerlIO_get_base(f);
f62ce20a 4033 return PerlIOBase_read(aTHX_ f, vbuf, count);
14a5cf38
JH		 4034 }
4035 return 0;
6f9d8c32
NIS		 4036}
4037
9e353e3b 4038SSize_t
f62ce20a 4039PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 4040{
14a5cf38 4041 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
dcda55fc 4042 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4043 SSize_t unread = 0;
4044 SSize_t avail;
4045 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4046 PerlIO_flush(f);
4047 if (!b->buf)
4048 PerlIO_get_base(f);
4049 if (b->buf) {
4050 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4051 /*
4052 * Buffer is already a read buffer, we can overwrite any chars
71200d45 4053 * which have been read back to buffer start
14a5cf38
JH		 4054 */
4055 avail = (b->ptr - b->buf);
4056 }
4057 else {
4058 /*
4059 * Buffer is idle, set it up so whole buffer is available for
71200d45 4060 * unread
14a5cf38
JH		 4061 */
4062 avail = b->bufsiz;
4063 b->end = b->buf + avail;
4064 b->ptr = b->end;
4065 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4066 /*
71200d45 4067 * Buffer extends _back_ from where we are now
14a5cf38
JH		 4068 */
4069 b->posn -= b->bufsiz;
4070 }
94e529cc 4071 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
14a5cf38 4072 /*
71200d45 4073 * If we have space for more than count, just move count
14a5cf38
JH		 4074 */
4075 avail = count;
4076 }
4077 if (avail > 0) {
4078 b->ptr -= avail;
4079 buf -= avail;
4080 /*
4081 * In simple stdio-like ungetc() case chars will be already
71200d45 4082 * there
14a5cf38
JH		 4083 */
4084 if (buf != b->ptr) {
4085 Copy(buf, b->ptr, avail, STDCHAR);
4086 }
4087 count -= avail;
4088 unread += avail;
4089 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4090 }
4091 }
93679785
NIS		 4092 if (count > 0) {
4093 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4094 }
14a5cf38 4095 return unread;
760ac839
LW		 4096}
4097
9e353e3b 4098SSize_t
f62ce20a 4099PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 4100{
de009b76 4101 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4102 const STDCHAR *buf = (const STDCHAR *) vbuf;
ee56a6b9 4103 const STDCHAR *flushptr = buf;
14a5cf38
JH		 4104 Size_t written = 0;
4105 if (!b->buf)
4106 PerlIO_get_base(f);
4107 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4108 return 0;
0678cb22
NIS		 4109 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4110 if (PerlIO_flush(f) != 0) {
4111 return 0;
4112 }
4113 }
ee56a6b9
CS		 4114 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4115 flushptr = buf + count;
4116 while (flushptr > buf && *(flushptr - 1) != '\n')
4117 --flushptr;
4118 }
14a5cf38
JH		 4119 while (count > 0) {
4120 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
94e529cc 4121 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
14a5cf38 4122 avail = count;
ee56a6b9
CS		 4123 if (flushptr > buf && flushptr <= buf + avail)
4124 avail = flushptr - buf;
14a5cf38 4125 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
ee56a6b9
CS		 4126 if (avail) {
4127 Copy(buf, b->ptr, avail, STDCHAR);
4128 count -= avail;
4129 buf += avail;
4130 written += avail;
4131 b->ptr += avail;
4132 if (buf == flushptr)
4133 PerlIO_flush(f);
14a5cf38
JH		 4134 }
4135 if (b->ptr >= (b->buf + b->bufsiz))
abf9167d
DM		 4136 if (PerlIO_flush(f) == -1)
4137 return -1;
14a5cf38
JH		 4138 }
4139 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4140 PerlIO_flush(f);
4141 return written;
9e353e3b
NIS		 4142}
4143
94a175e1 4144IV
f62ce20a 4145PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 4146{
14a5cf38
JH		 4147 IV code;
4148 if ((code = PerlIO_flush(f)) == 0) {
14a5cf38
JH		 4149 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4150 code = PerlIO_seek(PerlIONext(f), offset, whence);
4151 if (code == 0) {
de009b76 4152 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4153 b->posn = PerlIO_tell(PerlIONext(f));
4154 }
9e353e3b 4155 }
14a5cf38 4156 return code;
9e353e3b
NIS		 4157}
4158
4159Off_t
f62ce20a 4160PerlIOBuf_tell(pTHX_ PerlIO *f)
9e353e3b 4161{
dcda55fc 4162 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4163 /*
71200d45 4164 * b->posn is file position where b->buf was read, or will be written
14a5cf38
JH		 4165 */
4166 Off_t posn = b->posn;
37725cdc 4167 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
0678cb22
NIS		 4168 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4169#if 1
4170 /* As O_APPEND files are normally shared in some sense it is better
4171 to flush :
4172 */
4173 PerlIO_flush(f);
4174#else
37725cdc 4175 /* when file is NOT shared then this is sufficient */
0678cb22
NIS		 4176 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4177#endif
4178 posn = b->posn = PerlIO_tell(PerlIONext(f));
4179 }
14a5cf38
JH		 4180 if (b->buf) {
4181 /*
71200d45 4182 * If buffer is valid adjust position by amount in buffer
14a5cf38
JH		 4183 */
4184 posn += (b->ptr - b->buf);
4185 }
4186 return posn;
9e353e3b
NIS		 4187}
4188
4189IV
44798d05
NIS		 4190PerlIOBuf_popped(pTHX_ PerlIO *f)
4191{
de009b76
AL		 4192 const IV code = PerlIOBase_popped(aTHX_ f);
4193 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
44798d05
NIS		 4194 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4195 Safefree(b->buf);
4196 }
dcda55fc 4197 b->ptr = b->end = b->buf = NULL;
44798d05
NIS		 4198 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4199 return code;
4200}
4201
4202IV
f62ce20a 4203PerlIOBuf_close(pTHX_ PerlIO *f)
9e353e3b 4204{
de009b76
AL		 4205 const IV code = PerlIOBase_close(aTHX_ f);
4206 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4207 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4208 Safefree(b->buf);
14a5cf38 4209 }
dcda55fc 4210 b->ptr = b->end = b->buf = NULL;
14a5cf38
JH		 4211 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4212 return code;
760ac839
LW		 4213}
4214
9e353e3b 4215STDCHAR *
f62ce20a 4216PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
9e353e3b 4217{
dcda55fc 4218 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4219 if (!b->buf)
4220 PerlIO_get_base(f);
4221 return b->ptr;
9e353e3b
NIS		 4222}
4223
05d1247b 4224SSize_t
f62ce20a 4225PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
9e353e3b 4226{
dcda55fc 4227 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4228 if (!b->buf)
4229 PerlIO_get_base(f);
4230 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4231 return (b->end - b->ptr);
4232 return 0;
9e353e3b
NIS		 4233}
4234
4235STDCHAR *
f62ce20a 4236PerlIOBuf_get_base(pTHX_ PerlIO *f)
9e353e3b 4237{
dcda55fc 4238 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
96a5add6
AL		 4239 PERL_UNUSED_CONTEXT;
4240
14a5cf38
JH		 4241 if (!b->buf) {
4242 if (!b->bufsiz)
1810cd7c 4243 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
e05a0d74 4244 Newxz(b->buf,b->bufsiz, STDCHAR);
14a5cf38
JH		 4245 if (!b->buf) {
4246 b->buf = (STDCHAR *) & b->oneword;
4247 b->bufsiz = sizeof(b->oneword);
4248 }
dcda55fc 4249 b->end = b->ptr = b->buf;
06da4f11 4250 }
14a5cf38 4251 return b->buf;
9e353e3b
NIS		 4252}
4253
4254Size_t
f62ce20a 4255PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
9e353e3b 4256{
dcda55fc 4257 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4258 if (!b->buf)
4259 PerlIO_get_base(f);
4260 return (b->end - b->buf);
9e353e3b
NIS		 4261}
4262
4263void
f62ce20a 4264PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 4265{
dcda55fc 4266 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
babfacb9
JH		 4267#ifndef DEBUGGING
4268 PERL_UNUSED_ARG(cnt);
4269#endif
14a5cf38
JH		 4270 if (!b->buf)
4271 PerlIO_get_base(f);
4272 b->ptr = ptr;
b727803b
RGS		 4273 assert(PerlIO_get_cnt(f) == cnt);
4274 assert(b->ptr >= b->buf);
14a5cf38 4275 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW		 4276}
4277
71200d45 4278PerlIO *
ecdeb87c 4279PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 4280{
ecdeb87c 4281 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 4282}
4283
4284
4285
27da23d5 4286PERLIO_FUNCS_DECL(PerlIO_perlio) = {
2dc2558e 4287 sizeof(PerlIO_funcs),
14a5cf38
JH		 4288 "perlio",
4289 sizeof(PerlIOBuf),
86e05cf2 4290 PERLIO_K_BUFFERED|PERLIO_K_RAW,
14a5cf38 4291 PerlIOBuf_pushed,
44798d05 4292 PerlIOBuf_popped,
14a5cf38 4293 PerlIOBuf_open,
86e05cf2 4294 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4295 NULL,
4296 PerlIOBase_fileno,
71200d45 4297 PerlIOBuf_dup,
14a5cf38
JH		 4298 PerlIOBuf_read,
4299 PerlIOBuf_unread,
4300 PerlIOBuf_write,
4301 PerlIOBuf_seek,
4302 PerlIOBuf_tell,
4303 PerlIOBuf_close,
4304 PerlIOBuf_flush,
4305 PerlIOBuf_fill,
4306 PerlIOBase_eof,
4307 PerlIOBase_error,
4308 PerlIOBase_clearerr,
4309 PerlIOBase_setlinebuf,
4310 PerlIOBuf_get_base,
4311 PerlIOBuf_bufsiz,
4312 PerlIOBuf_get_ptr,
4313 PerlIOBuf_get_cnt,
4314 PerlIOBuf_set_ptrcnt,
9e353e3b
NIS		 4315};
4316
66ecd56b 4317/*--------------------------------------------------------------------------------------*/
14a5cf38 4318/*
71200d45 4319 * Temp layer to hold unread chars when cannot do it any other way
14a5cf38 4320 */
5e2ab84b
NIS		 4321
4322IV
f62ce20a 4323PerlIOPending_fill(pTHX_ PerlIO *f)
5e2ab84b 4324{
14a5cf38 4325 /*
71200d45 4326 * Should never happen
14a5cf38
JH		 4327 */
4328 PerlIO_flush(f);
4329 return 0;
5e2ab84b
NIS		 4330}
4331
4332IV
f62ce20a 4333PerlIOPending_close(pTHX_ PerlIO *f)
5e2ab84b 4334{
14a5cf38 4335 /*
71200d45 4336 * A tad tricky - flush pops us, then we close new top
14a5cf38
JH		 4337 */
4338 PerlIO_flush(f);
4339 return PerlIO_close(f);
5e2ab84b
NIS		 4340}
4341
94a175e1 4342IV
f62ce20a 4343PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
5e2ab84b 4344{
14a5cf38 4345 /*
71200d45 4346 * A tad tricky - flush pops us, then we seek new top
14a5cf38
JH		 4347 */
4348 PerlIO_flush(f);
4349 return PerlIO_seek(f, offset, whence);
5e2ab84b
NIS		 4350}
4351
4352
4353IV
f62ce20a 4354PerlIOPending_flush(pTHX_ PerlIO *f)
5e2ab84b 4355{
dcda55fc 4356 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4357 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4358 Safefree(b->buf);
14a5cf38
JH		 4359 b->buf = NULL;
4360 }
4361 PerlIO_pop(aTHX_ f);
4362 return 0;
5e2ab84b
NIS		 4363}
4364
4365void
f62ce20a 4366PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
5e2ab84b 4367{
14a5cf38
JH		 4368 if (cnt <= 0) {
4369 PerlIO_flush(f);
4370 }
4371 else {
f62ce20a 4372 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
14a5cf38 4373 }
5e2ab84b
NIS		 4374}
4375
4376IV
2dc2558e 4377PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 4378{
de009b76 4379 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
dcda55fc 4380 PerlIOl * const l = PerlIOBase(f);
14a5cf38 4381 /*
71200d45
NIS		 4382 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4383 * etc. get muddled when it changes mid-string when we auto-pop.
14a5cf38
JH		 4384 */
4385 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4386 (PerlIOBase(PerlIONext(f))->
4387 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4388 return code;
5e2ab84b
NIS		 4389}
4390
4391SSize_t
f62ce20a 4392PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
5e2ab84b 4393{
14a5cf38
JH		 4394 SSize_t avail = PerlIO_get_cnt(f);
4395 SSize_t got = 0;
94e529cc 4396 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
14a5cf38
JH		 4397 avail = count;
4398 if (avail > 0)
f62ce20a 4399 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
eb160463 4400 if (got >= 0 && got < (SSize_t)count) {
de009b76 4401 const SSize_t more =
14a5cf38
JH		 4402 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4403 if (more >= 0 || got == 0)
4404 got += more;
4405 }
4406 return got;
5e2ab84b
NIS		 4407}
4408
27da23d5 4409PERLIO_FUNCS_DECL(PerlIO_pending) = {
2dc2558e 4410 sizeof(PerlIO_funcs),
14a5cf38
JH		 4411 "pending",
4412 sizeof(PerlIOBuf),
86e05cf2 4413 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
14a5cf38 4414 PerlIOPending_pushed,
44798d05 4415 PerlIOBuf_popped,
14a5cf38 4416 NULL,
86e05cf2 4417 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4418 NULL,
4419 PerlIOBase_fileno,
71200d45 4420 PerlIOBuf_dup,
14a5cf38
JH		 4421 PerlIOPending_read,
4422 PerlIOBuf_unread,
4423 PerlIOBuf_write,
4424 PerlIOPending_seek,
4425 PerlIOBuf_tell,
4426 PerlIOPending_close,
4427 PerlIOPending_flush,
4428 PerlIOPending_fill,
4429 PerlIOBase_eof,
4430 PerlIOBase_error,
4431 PerlIOBase_clearerr,
4432 PerlIOBase_setlinebuf,
4433 PerlIOBuf_get_base,
4434 PerlIOBuf_bufsiz,
4435 PerlIOBuf_get_ptr,
4436 PerlIOBuf_get_cnt,
4437 PerlIOPending_set_ptrcnt,
5e2ab84b
NIS		 4438};
4439
4440
4441
4442/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4443/*
4444 * crlf - translation On read translate CR,LF to "\n" we do this by
4445 * overriding ptr/cnt entries to hand back a line at a time and keeping a
71200d45 4446 * record of which nl we "lied" about. On write translate "\n" to CR,LF
93c2c2ec
IZ		 4447 *
4448 * c->nl points on the first byte of CR LF pair when it is temporarily
4449 * replaced by LF, or to the last CR of the buffer. In the former case
4450 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4451 * that it ends at c->nl; these two cases can be distinguished by
4452 * *c->nl. c->nl is set during _getcnt() call, and unset during
4453 * _unread() and _flush() calls.
4454 * It only matters for read operations.
66ecd56b
NIS		 4455 */
4456
14a5cf38 4457typedef struct {
22569500
NIS		 4458 PerlIOBuf base; /* PerlIOBuf stuff */
4459 STDCHAR *nl; /* Position of crlf we "lied" about in the
14a5cf38 4460 * buffer */
99efab12
NIS		 4461} PerlIOCrlf;
4462
ff1e3883
JD		 4463/* Inherit the PERLIO_F_UTF8 flag from previous layer.
4464 * Otherwise the :crlf layer would always revert back to
4465 * raw mode.
4466 */
4467static void
4468S_inherit_utf8_flag(PerlIO *f)
4469{
4470 PerlIO *g = PerlIONext(f);
4471 if (PerlIOValid(g)) {
4472 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4473 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4474 }
4475 }
4476}
4477
f5b9d040 4478IV
2dc2558e 4479PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
f5b9d040 4480{
14a5cf38
JH		 4481 IV code;
4482 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2dc2558e 4483 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b 4484#if 0
14a5cf38 4485 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
6c9570dc 4486 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
14a5cf38 4487 PerlIOBase(f)->flags);
5e2ab84b 4488#endif
8229d19f 4489 {
5da08ab0
LT		 4490 /* If the old top layer is a CRLF layer, reactivate it (if
4491 * necessary) and remove this new layer from the stack */
8229d19f 4492 PerlIO *g = PerlIONext(f);
7826b36f 4493 if (PerlIOValid(g)) {
8229d19f
JH		 4494 PerlIOl *b = PerlIOBase(g);
4495 if (b && b->tab == &PerlIO_crlf) {
4496 if (!(b->flags & PERLIO_F_CRLF))
4497 b->flags |= PERLIO_F_CRLF;
ff1e3883 4498 S_inherit_utf8_flag(g);
8229d19f
JH		 4499 PerlIO_pop(aTHX_ f);
4500 return code;
7826b36f 4501 }
8229d19f
JH		 4502 }
4503 }
ff1e3883 4504 S_inherit_utf8_flag(f);
14a5cf38 4505 return code;
f5b9d040
NIS		 4506}
4507
4508
99efab12 4509SSize_t
f62ce20a 4510PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4511{
dcda55fc 4512 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
93c2c2ec 4513 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
76e6dc3a 4514 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4515 c->nl = NULL;
4516 }
4517 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4518 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 4519 else {
4520 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4521 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4522 SSize_t unread = 0;
4523 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4524 PerlIO_flush(f);
4525 if (!b->buf)
4526 PerlIO_get_base(f);
4527 if (b->buf) {
4528 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4529 b->end = b->ptr = b->buf + b->bufsiz;
4530 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4531 b->posn -= b->bufsiz;
4532 }
4533 while (count > 0 && b->ptr > b->buf) {
dcda55fc 4534 const int ch = *--buf;
14a5cf38
JH		 4535 if (ch == '\n') {
4536 if (b->ptr - 2 >= b->buf) {
76e6dc3a
KW		 4537 *--(b->ptr) = NATIVE_0xa;
4538 *--(b->ptr) = NATIVE_0xd;
14a5cf38
JH		 4539 unread++;
4540 count--;
4541 }
4542 else {
93c2c2ec 4543 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
76e6dc3a
KW		 4544 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4545 '\r' */
93c2c2ec
IZ		 4546 unread++;
4547 count--;
14a5cf38
JH		 4548 }
4549 }
4550 else {
4551 *--(b->ptr) = ch;
4552 unread++;
4553 count--;
4554 }
4555 }
4556 }
ec1da995
LT		 4557 if (count > 0)
4558 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
14a5cf38
JH		 4559 return unread;
4560 }
99efab12
NIS		 4561}
4562
93c2c2ec 4563/* XXXX This code assumes that buffer size >=2, but does not check it... */
99efab12 4564SSize_t
f62ce20a 4565PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
99efab12 4566{
dcda55fc 4567 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4568 if (!b->buf)
4569 PerlIO_get_base(f);
4570 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
dcda55fc 4571 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
76e6dc3a 4572 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
23b3c6af 4573 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
14a5cf38 4574 scan:
76e6dc3a 4575 while (nl < b->end && *nl != NATIVE_0xd)
14a5cf38 4576 nl++;
76e6dc3a 4577 if (nl < b->end && *nl == NATIVE_0xd) {
14a5cf38
JH		 4578 test:
4579 if (nl + 1 < b->end) {
76e6dc3a 4580 if (nl[1] == NATIVE_0xa) {
14a5cf38
JH		 4581 *nl = '\n';
4582 c->nl = nl;
4583 }
4584 else {
4585 /*
71200d45 4586 * Not CR,LF but just CR
14a5cf38
JH		 4587 */
4588 nl++;
4589 goto scan;
4590 }
4591 }
4592 else {
4593 /*
71200d45 4594 * Blast - found CR as last char in buffer
14a5cf38 4595 */
e87a358a 4596
14a5cf38
JH		 4597 if (b->ptr < nl) {
4598 /*
4599 * They may not care, defer work as long as
71200d45 4600 * possible
14a5cf38 4601 */
a0d1d361 4602 c->nl = nl;
14a5cf38
JH		 4603 return (nl - b->ptr);
4604 }
4605 else {
4606 int code;
22569500 4607 b->ptr++; /* say we have read it as far as
14a5cf38 4608 * flush() is concerned */
22569500 4609 b->buf++; /* Leave space in front of buffer */
e949e37c
NIS		 4610 /* Note as we have moved buf up flush's
4611 posn += ptr-buf
4612 will naturally make posn point at CR
4613 */
22569500
NIS		 4614 b->bufsiz--; /* Buffer is thus smaller */
4615 code = PerlIO_fill(f); /* Fetch some more */
4616 b->bufsiz++; /* Restore size for next time */
4617 b->buf--; /* Point at space */
4618 b->ptr = nl = b->buf; /* Which is what we hand
14a5cf38 4619 * off */
76e6dc3a 4620 *nl = NATIVE_0xd; /* Fill in the CR */
14a5cf38 4621 if (code == 0)
22569500 4622 goto test; /* fill() call worked */
14a5cf38 4623 /*
71200d45 4624 * CR at EOF - just fall through
14a5cf38 4625 */
a0d1d361 4626 /* Should we clear EOF though ??? */
14a5cf38
JH		 4627 }
4628 }
4629 }
4630 }
4631 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4632 }
4633 return 0;
99efab12
NIS		 4634}
4635
4636void
f62ce20a 4637PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
14a5cf38 4638{
dcda55fc
AL		 4639 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4640 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38
JH		 4641 if (!b->buf)
4642 PerlIO_get_base(f);
4643 if (!ptr) {
a0d1d361 4644 if (c->nl) {
14a5cf38 4645 ptr = c->nl + 1;
76e6dc3a 4646 if (ptr == b->end && *c->nl == NATIVE_0xd) {
486ec47a 4647 /* Deferred CR at end of buffer case - we lied about count */
22569500
NIS		 4648 ptr--;
4649 }
4650 }
14a5cf38
JH		 4651 else {
4652 ptr = b->end;
14a5cf38
JH		 4653 }
4654 ptr -= cnt;
4655 }
4656 else {
6f207bd3 4657 NOOP;
3b4bd3fd 4658#if 0
14a5cf38 4659 /*
71200d45 4660 * Test code - delete when it works ...
14a5cf38 4661 */
3b4bd3fd 4662 IV flags = PerlIOBase(f)->flags;
ba7abf9d 4663 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
76e6dc3a 4664 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
486ec47a 4665 /* Deferred CR at end of buffer case - we lied about count */
a0d1d361 4666 chk--;
22569500 4667 }
14a5cf38
JH		 4668 chk -= cnt;
4669
a0d1d361 4670 if (ptr != chk ) {
99ef548b 4671 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
6c9570dc
MHM		 4672 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4673 flags, c->nl, b->end, cnt);
14a5cf38 4674 }
99ef548b 4675#endif
14a5cf38
JH		 4676 }
4677 if (c->nl) {
4678 if (ptr > c->nl) {
4679 /*
71200d45 4680 * They have taken what we lied about
14a5cf38 4681 */
76e6dc3a 4682 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4683 c->nl = NULL;
4684 ptr++;
4685 }
4686 }
4687 b->ptr = ptr;
4688 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
99efab12
NIS		 4689}
4690
4691SSize_t
f62ce20a 4692PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4693{
14a5cf38 4694 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4695 return PerlIOBuf_write(aTHX_ f, vbuf, count);
14a5cf38 4696 else {
dcda55fc 4697 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4698 const STDCHAR *buf = (const STDCHAR *) vbuf;
dcda55fc 4699 const STDCHAR * const ebuf = buf + count;
14a5cf38
JH		 4700 if (!b->buf)
4701 PerlIO_get_base(f);
4702 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4703 return 0;
4704 while (buf < ebuf) {
dcda55fc 4705 const STDCHAR * const eptr = b->buf + b->bufsiz;
14a5cf38
JH		 4706 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4707 while (buf < ebuf && b->ptr < eptr) {
4708 if (*buf == '\n') {
4709 if ((b->ptr + 2) > eptr) {
4710 /*
71200d45 4711 * Not room for both
14a5cf38
JH		 4712 */
4713 PerlIO_flush(f);
4714 break;
4715 }
4716 else {
76e6dc3a
KW		 4717 *(b->ptr)++ = NATIVE_0xd; /* CR */
4718 *(b->ptr)++ = NATIVE_0xa; /* LF */
14a5cf38
JH		 4719 buf++;
4720 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4721 PerlIO_flush(f);
4722 break;
4723 }
4724 }
4725 }
4726 else {
dcda55fc 4727 *(b->ptr)++ = *buf++;
14a5cf38
JH		 4728 }
4729 if (b->ptr >= eptr) {
4730 PerlIO_flush(f);
4731 break;
4732 }
4733 }
4734 }
4735 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4736 PerlIO_flush(f);
4737 return (buf - (STDCHAR *) vbuf);
4738 }
99efab12
NIS		 4739}
4740
4741IV
f62ce20a 4742PerlIOCrlf_flush(pTHX_ PerlIO *f)
99efab12 4743{
dcda55fc 4744 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38 4745 if (c->nl) {
76e6dc3a 4746 *(c->nl) = NATIVE_0xd;
14a5cf38
JH		 4747 c->nl = NULL;
4748 }
f62ce20a 4749 return PerlIOBuf_flush(aTHX_ f);
99efab12
NIS		 4750}
4751
86e05cf2
NIS		 4752IV
4753PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4754{
4755 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4756 /* In text mode - flush any pending stuff and flip it */
4757 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4758#ifndef PERLIO_USING_CRLF
4759 /* CRLF is unusual case - if this is just the :crlf layer pop it */
5fae6dc1 4760 PerlIO_pop(aTHX_ f);
86e05cf2
NIS		 4761#endif
4762 }
4763 return 0;
4764}
4765
27da23d5 4766PERLIO_FUNCS_DECL(PerlIO_crlf) = {
2dc2558e 4767 sizeof(PerlIO_funcs),
14a5cf38
JH		 4768 "crlf",
4769 sizeof(PerlIOCrlf),
86e05cf2 4770 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
14a5cf38 4771 PerlIOCrlf_pushed,
44798d05 4772 PerlIOBuf_popped, /* popped */
14a5cf38 4773 PerlIOBuf_open,
86e05cf2 4774 PerlIOCrlf_binmode, /* binmode */
14a5cf38
JH		 4775 NULL,
4776 PerlIOBase_fileno,
71200d45 4777 PerlIOBuf_dup,
de009b76 4778 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
22569500
NIS		 4779 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4780 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
14a5cf38
JH		 4781 PerlIOBuf_seek,
4782 PerlIOBuf_tell,
4783 PerlIOBuf_close,
4784 PerlIOCrlf_flush,
4785 PerlIOBuf_fill,
4786 PerlIOBase_eof,
4787 PerlIOBase_error,
4788 PerlIOBase_clearerr,
4789 PerlIOBase_setlinebuf,
4790 PerlIOBuf_get_base,
4791 PerlIOBuf_bufsiz,
4792 PerlIOBuf_get_ptr,
4793 PerlIOCrlf_get_cnt,
4794 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS		 4795};
4796
9e353e3b 4797PerlIO *
e87a358a 4798Perl_PerlIO_stdin(pTHX)
9e353e3b 4799{
a1ea730d 4800 if (!PL_perlio) {
14a5cf38
JH		 4801 PerlIO_stdstreams(aTHX);
4802 }
303f2dc3 4803 return (PerlIO*)&PL_perlio[1];
9e353e3b
NIS		 4804}
4805
9e353e3b 4806PerlIO *
e87a358a 4807Perl_PerlIO_stdout(pTHX)
9e353e3b 4808{
a1ea730d 4809 if (!PL_perlio) {
14a5cf38
JH		 4810 PerlIO_stdstreams(aTHX);
4811 }
303f2dc3 4812 return (PerlIO*)&PL_perlio[2];
9e353e3b
NIS		 4813}
4814
9e353e3b 4815PerlIO *
e87a358a 4816Perl_PerlIO_stderr(pTHX)
9e353e3b 4817{
a1ea730d 4818 if (!PL_perlio) {
14a5cf38
JH		 4819 PerlIO_stdstreams(aTHX);
4820 }
303f2dc3 4821 return (PerlIO*)&PL_perlio[3];
9e353e3b
NIS		 4822}
4823
4824/*--------------------------------------------------------------------------------------*/
4825
9e353e3b
NIS		 4826char *
4827PerlIO_getname(PerlIO *f, char *buf)
4828{
a15cef0c 4829#ifdef VMS
dbf7dff6 4830 dTHX;
73d840c0 4831 char *name = NULL;
7659f319 4832 bool exported = FALSE;
14a5cf38 4833 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
7659f319
CB		 4834 if (!stdio) {
4835 stdio = PerlIO_exportFILE(f,0);
4836 exported = TRUE;
4837 }
4838 if (stdio) {
14a5cf38 4839 name = fgetname(stdio, buf);
7659f319
CB		 4840 if (exported) PerlIO_releaseFILE(f,stdio);
4841 }
73d840c0 4842 return name;
a15cef0c 4843#else
8772537c
AL		 4844 PERL_UNUSED_ARG(f);
4845 PERL_UNUSED_ARG(buf);
dbf7dff6 4846 Perl_croak_nocontext("Don't know how to get file name");
bd61b366 4847 return NULL;
a15cef0c 4848#endif
9e353e3b
NIS		 4849}
4850
4851
4852/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4853/*
4854 * Functions which can be called on any kind of PerlIO implemented in
71200d45 4855 * terms of above
14a5cf38 4856 */
9e353e3b 4857
e87a358a
NIS		 4858#undef PerlIO_fdopen
4859PerlIO *
4860PerlIO_fdopen(int fd, const char *mode)
4861{
4862 dTHX;
bd61b366 4863 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
e87a358a
NIS		 4864}
4865
4866#undef PerlIO_open
4867PerlIO *
4868PerlIO_open(const char *path, const char *mode)
4869{
4870 dTHX;
42d9b98d 4871 SV *name = sv_2mortal(newSVpv(path, 0));
bd61b366 4872 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
e87a358a
NIS		 4873}
4874
4875#undef Perlio_reopen
4876PerlIO *
4877PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4878{
4879 dTHX;
42d9b98d 4880 SV *name = sv_2mortal(newSVpv(path,0));
bd61b366 4881 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
e87a358a
NIS		 4882}
4883
9e353e3b 4884#undef PerlIO_getc
6f9d8c32 4885int
9e353e3b 4886PerlIO_getc(PerlIO *f)
760ac839 4887{
e87a358a 4888 dTHX;
14a5cf38 4889 STDCHAR buf[1];
de009b76 4890 if ( 1 == PerlIO_read(f, buf, 1) ) {
14a5cf38
JH		 4891 return (unsigned char) buf[0];
4892 }
4893 return EOF;
313ca112
NIS		 4894}
4895
4896#undef PerlIO_ungetc
4897int
4898PerlIO_ungetc(PerlIO *f, int ch)
4899{
e87a358a 4900 dTHX;
14a5cf38
JH		 4901 if (ch != EOF) {
4902 STDCHAR buf = ch;
4903 if (PerlIO_unread(f, &buf, 1) == 1)
4904 return ch;
4905 }
4906 return EOF;
760ac839
LW		 4907}
4908
9e353e3b
NIS		 4909#undef PerlIO_putc
4910int
4911PerlIO_putc(PerlIO *f, int ch)
760ac839 4912{
e87a358a 4913 dTHX;
14a5cf38
JH		 4914 STDCHAR buf = ch;
4915 return PerlIO_write(f, &buf, 1);
760ac839
LW		 4916}
4917
9e353e3b 4918#undef PerlIO_puts
760ac839 4919int
9e353e3b 4920PerlIO_puts(PerlIO *f, const char *s)
760ac839 4921{
e87a358a 4922 dTHX;
dcda55fc 4923 return PerlIO_write(f, s, strlen(s));
760ac839
LW		 4924}
4925
4926#undef PerlIO_rewind
4927void
c78749f2 4928PerlIO_rewind(PerlIO *f)
760ac839 4929{
e87a358a 4930 dTHX;
14a5cf38
JH		 4931 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4932 PerlIO_clearerr(f);
6f9d8c32
NIS		 4933}
4934
4935#undef PerlIO_vprintf
4936int
4937PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4938{
14a5cf38 4939 dTHX;
53ce71d3 4940 SV * sv;
b83604b4 4941 const char *s;
14a5cf38
JH		 4942 STRLEN len;
4943 SSize_t wrote;
2cc61e15 4944#ifdef NEED_VA_COPY
14a5cf38
JH		 4945 va_list apc;
4946 Perl_va_copy(ap, apc);
53ce71d3 4947 sv = vnewSVpvf(fmt, &apc);
d4825b27 4948 va_end(apc);
2cc61e15 4949#else
53ce71d3 4950 sv = vnewSVpvf(fmt, &ap);
2cc61e15 4951#endif
b83604b4 4952 s = SvPV_const(sv, len);
14a5cf38
JH		 4953 wrote = PerlIO_write(f, s, len);
4954 SvREFCNT_dec(sv);
4955 return wrote;
760ac839
LW		 4956}
4957
4958#undef PerlIO_printf
6f9d8c32 4959int
14a5cf38 4960PerlIO_printf(PerlIO *f, const char *fmt, ...)
760ac839 4961{
14a5cf38
JH		 4962 va_list ap;
4963 int result;
4964 va_start(ap, fmt);
4965 result = PerlIO_vprintf(f, fmt, ap);
4966 va_end(ap);
4967 return result;
760ac839
LW		 4968}
4969
4970#undef PerlIO_stdoutf
6f9d8c32 4971int
14a5cf38 4972PerlIO_stdoutf(const char *fmt, ...)
760ac839 4973{
e87a358a 4974 dTHX;
14a5cf38
JH		 4975 va_list ap;
4976 int result;
4977 va_start(ap, fmt);
4978 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4979 va_end(ap);
4980 return result;
760ac839
LW		 4981}
4982
4983#undef PerlIO_tmpfile
4984PerlIO *
c78749f2 4985PerlIO_tmpfile(void)
760ac839 4986{
dbf7dff6 4987#ifndef WIN32
2941a2e1 4988 dTHX;
dbf7dff6 4989#endif
2941a2e1 4990 PerlIO *f = NULL;
2941a2e1 4991#ifdef WIN32
de009b76 4992 const int fd = win32_tmpfd();
2941a2e1
JH		 4993 if (fd >= 0)
4994 f = PerlIO_fdopen(fd, "w+b");
4995#else /* WIN32 */
460c8493 4996# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
0b99e986
RGS		 4997 int fd = -1;
4998 char tempname[] = "/tmp/PerlIO_XXXXXX";
284167a5 4999 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
525f6fe9 5000 SV * sv = NULL;
60f7fc1e 5001 int old_umask = umask(0600);
2941a2e1
JH		 5002 /*
5003 * I have no idea how portable mkstemp() is ... NI-S
5004 */
7299ca58 5005 if (tmpdir && *tmpdir) {
0b99e986 5006 /* if TMPDIR is set and not empty, we try that first */
7299ca58 5007 sv = newSVpv(tmpdir, 0);
0b99e986
RGS		 5008 sv_catpv(sv, tempname + 4);
5009 fd = mkstemp(SvPVX(sv));
5010 }
5011 if (fd < 0) {
e40f8e80 5012 SvREFCNT_dec(sv);
7299ca58 5013 sv = NULL;
0b99e986
RGS		 5014 /* else we try /tmp */
5015 fd = mkstemp(tempname);
5016 }
b7561fc9
BF		 5017 if (fd < 0) {
5018 /* Try cwd */
5019 sv = newSVpvs(".");
5020 sv_catpv(sv, tempname + 4);
5021 fd = mkstemp(SvPVX(sv));
5022 }
60f7fc1e 5023 umask(old_umask);
2941a2e1
JH		 5024 if (fd >= 0) {
5025 f = PerlIO_fdopen(fd, "w+");
5026 if (f)
5027 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
0b99e986 5028 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
2941a2e1 5029 }
ef8d46e8 5030 SvREFCNT_dec(sv);
2941a2e1 5031# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
c4420975 5032 FILE * const stdio = PerlSIO_tmpfile();
2941a2e1 5033
085e731f
CB		 5034 if (stdio)
5035 f = PerlIO_fdopen(fileno(stdio), "w+");
5036
2941a2e1
JH		 5037# endif /* else HAS_MKSTEMP */
5038#endif /* else WIN32 */
5039 return f;
760ac839
LW		 5040}
5041
0ea86a10
FC		 5042void
5043Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5044{
5045 if (!PerlIOValid(f))
5046 return;
5047 PerlIOBase(f)->err = errno;
5048#ifdef VMS
5049 PerlIOBase(f)->os_err = vaxc$errno;
5050#elif defined(OS2)
5051 PerlIOBase(f)->os_err = Perl_rc;
5052#elif defined(WIN32)
5053 PerlIOBase(f)->os_err = GetLastError();
5054#endif
5055}
5056
5057void
5058Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5059{
5060 if (!PerlIOValid(f))
5061 return;
5062 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5063#ifdef OS2
5064 Perl_rc = PerlIOBase(f)->os_err);
5065#elif defined(WIN32)
5066 SetLastError(PerlIOBase(f)->os_err);
5067#endif
5068}
5069
6f9d8c32
NIS		 5070#undef HAS_FSETPOS
5071#undef HAS_FGETPOS
5072
760ac839 5073
9e353e3b 5074/*======================================================================================*/
14a5cf38 5075/*
71200d45
NIS		 5076 * Now some functions in terms of above which may be needed even if we are
5077 * not in true PerlIO mode
9e353e3b 5078 */
188f0c84
YO		 5079const char *
5080Perl_PerlIO_context_layers(pTHX_ const char *mode)
5081{
8b850bd5
NC		 5082 const char *direction = NULL;
5083 SV *layers;
188f0c84
YO		 5084 /*
5085 * Need to supply default layer info from open.pm
5086 */
8b850bd5
NC		 5087
5088 if (!PL_curcop)
5089 return NULL;
5090
5091 if (mode && mode[0] != 'r') {
5092 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5093 direction = "open>";
5094 } else {
5095 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5096 direction = "open<";
188f0c84 5097 }
8b850bd5
NC		 5098 if (!direction)
5099 return NULL;
5100
20439bc7 5101 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
8b850bd5
NC		 5102
5103 assert(layers);
5104 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
188f0c84
YO		 5105}
5106
9e353e3b 5107
760ac839
LW		 5108#ifndef HAS_FSETPOS
5109#undef PerlIO_setpos
5110int
766a733e 5111PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 5112{
14a5cf38 5113 if (SvOK(pos)) {
e1a83e70
DD		 5114 if (f) {
5115 dTHX;
5116 STRLEN len;
5117 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5118 if(len == sizeof(Off_t))
5119 return PerlIO_seek(f, *posn, SEEK_SET);
5120 }
14a5cf38 5121 }
93189314 5122 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5123 return -1;
760ac839 5124}
c411622e 5125#else
c411622e 5126#undef PerlIO_setpos
5127int
766a733e 5128PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 5129{
14a5cf38 5130 if (SvOK(pos)) {
e1a83e70
DD		 5131 if (f) {
5132 dTHX;
5133 STRLEN len;
5134 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5135 if(len == sizeof(Fpos_t))
2d4389e4 5136#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
e1a83e70 5137 return fsetpos64(f, fpos);
d9b3e12d 5138#else
e1a83e70 5139 return fsetpos(f, fpos);
d9b3e12d 5140#endif
14a5cf38 5141 }
766a733e 5142 }
93189314 5143 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5144 return -1;
c411622e 5145}
5146#endif
760ac839
LW		 5147
5148#ifndef HAS_FGETPOS
5149#undef PerlIO_getpos
5150int
766a733e 5151PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 5152{
14a5cf38
JH		 5153 dTHX;
5154 Off_t posn = PerlIO_tell(f);
5155 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5156 return (posn == (Off_t) - 1) ? -1 : 0;
760ac839 5157}
c411622e 5158#else
c411622e 5159#undef PerlIO_getpos
5160int
766a733e 5161PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 5162{
14a5cf38
JH		 5163 dTHX;
5164 Fpos_t fpos;
5165 int code;
2d4389e4 5166#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 5167 code = fgetpos64(f, &fpos);
d9b3e12d 5168#else
14a5cf38 5169 code = fgetpos(f, &fpos);
d9b3e12d 5170#endif
14a5cf38
JH		 5171 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5172 return code;
c411622e 5173}
5174#endif
760ac839 5175
97cb92d6 5176#if !defined(HAS_VPRINTF)
760ac839
LW		 5177
5178int
c78749f2 5179vprintf(char *pat, char *args)
662a7e3f
CS		 5180{
5181 _doprnt(pat, args, stdout);
22569500 5182 return 0; /* wrong, but perl doesn't use the return
14a5cf38 5183 * value */
662a7e3f
CS		 5184}
5185
5186int
c78749f2 5187vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW		 5188{
5189 _doprnt(pat, args, fd);
22569500 5190 return 0; /* wrong, but perl doesn't use the return
14a5cf38 5191 * value */
760ac839
LW		 5192}
5193
5194#endif
5195
db6e00bd
DD		 5196/* print a failure format string message to stderr and fail exit the process
5197 using only libc without depending on any perl data structures being
5198 initialized.
5199*/
5200
5201void
5202Perl_noperl_die(const char* pat, ...)
5203{
5204 va_list(arglist);
5205 PERL_ARGS_ASSERT_NOPERL_DIE;
5206 va_start(arglist, pat);
5207 vfprintf(stderr, pat, arglist);
5208 va_end(arglist);
5209 exit(1);
5210}
5211
9cfa90c0 5212/*
14d04a33 5213 * ex: set ts=8 sts=4 sw=4 et:
37442d52 5214 */
Unnamed repository; edit this file 'description' to name the repository.