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