This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid blank lines in backslash warnings test.
[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#ifdef PERLIO_IS_STDIO
760ac839
LW
342
343void
e8632036 344PerlIO_init(pTHX)
760ac839 345{
96a5add6 346 PERL_UNUSED_CONTEXT;
14a5cf38
JH
347 /*
348 * Does nothing (yet) except force this file to be included in perl
71200d45 349 * binary. That allows this file to force inclusion of other functions
14a5cf38 350 * that may be required by loadable extensions e.g. for
71200d45 351 * FileHandle::tmpfile
14a5cf38 352 */
760ac839
LW
353}
354
33dcbb9a
PP
355#undef PerlIO_tmpfile
356PerlIO *
8ac85365 357PerlIO_tmpfile(void)
33dcbb9a 358{
14a5cf38 359 return tmpfile();
33dcbb9a
PP
360}
361
22569500 362#else /* PERLIO_IS_STDIO */
760ac839 363
6f9d8c32 364/*======================================================================================*/
14a5cf38 365/*
71200d45 366 * Implement all the PerlIO interface ourselves.
9e353e3b 367 */
760ac839 368
76ced9ad
NIS
369#include "perliol.h"
370
6f9d8c32 371void
14a5cf38
JH
372PerlIO_debug(const char *fmt, ...)
373{
14a5cf38
JH
374 va_list ap;
375 dSYS;
376 va_start(ap, fmt);
582588d2 377 if (!PL_perlio_debug_fd) {
284167a5 378 if (!TAINTING_get &&
985213f2
AB
379 PerlProc_getuid() == PerlProc_geteuid() &&
380 PerlProc_getgid() == PerlProc_getegid()) {
582588d2
NC
381 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
382 if (s && *s)
383 PL_perlio_debug_fd
384 = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
385 else
386 PL_perlio_debug_fd = -1;
387 } else {
388 /* tainting or set*id, so ignore the environment, and ensure we
389 skip these tests next time through. */
27da23d5 390 PL_perlio_debug_fd = -1;
582588d2 391 }
14a5cf38 392 }
27da23d5 393 if (PL_perlio_debug_fd > 0) {
70ace5da 394#ifdef USE_ITHREADS
dcda55fc 395 const char * const s = CopFILE(PL_curcop);
70ace5da
NIS
396 /* Use fixed buffer as sv_catpvf etc. needs SVs */
397 char buffer[1024];
1208b3dd
JH
398 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
399 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
b469f1e0 400 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
70ace5da 401#else
dcda55fc
AL
402 const char *s = CopFILE(PL_curcop);
403 STRLEN len;
550e2ce0
NC
404 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
405 (IV) CopLINE(PL_curcop));
14a5cf38
JH
406 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
407
b83604b4 408 s = SvPV_const(sv, len);
b469f1e0 409 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
14a5cf38 410 SvREFCNT_dec(sv);
70ace5da 411#endif
14a5cf38
JH
412 }
413 va_end(ap);
6f9d8c32
NIS
414}
415
9e353e3b
NIS
416/*--------------------------------------------------------------------------------------*/
417
14a5cf38 418/*
71200d45 419 * Inner level routines
14a5cf38 420 */
9e353e3b 421
16865ff7
DM
422/* check that the head field of each layer points back to the head */
423
424#ifdef DEBUGGING
425# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
426static void
427PerlIO_verify_head(pTHX_ PerlIO *f)
428{
429 PerlIOl *head, *p;
430 int seen = 0;
431 if (!PerlIOValid(f))
432 return;
433 p = head = PerlIOBase(f)->head;
434 assert(p);
435 do {
436 assert(p->head == head);
437 if (p == (PerlIOl*)f)
438 seen = 1;
439 p = p->next;
440 } while (p);
441 assert(seen);
442}
443#else
444# define VERIFY_HEAD(f)
445#endif
446
447
14a5cf38 448/*
71200d45 449 * Table of pointers to the PerlIO structs (malloc'ed)
14a5cf38 450 */
05d1247b 451#define PERLIO_TABLE_SIZE 64
6f9d8c32 452
8995e67d
DM
453static void
454PerlIO_init_table(pTHX)
455{
456 if (PL_perlio)
457 return;
458 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
459}
460
461
462
760ac839 463PerlIO *
5f1a76d0 464PerlIO_allocate(pTHX)
6f9d8c32 465{
97aff369 466 dVAR;
14a5cf38 467 /*
71200d45 468 * Find a free slot in the table, allocating new table as necessary
14a5cf38 469 */
303f2dc3
DM
470 PerlIOl **last;
471 PerlIOl *f;
a1ea730d 472 last = &PL_perlio;
14a5cf38
JH
473 while ((f = *last)) {
474 int i;
303f2dc3 475 last = (PerlIOl **) (f);
14a5cf38 476 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 477 if (!((++f)->next)) {
abf9167d 478 f->flags = 0; /* lockcnt */
303f2dc3 479 f->tab = NULL;
16865ff7 480 f->head = f;
303f2dc3 481 return (PerlIO *)f;
14a5cf38
JH
482 }
483 }
484 }
303f2dc3 485 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
14a5cf38
JH
486 if (!f) {
487 return NULL;
488 }
303f2dc3 489 *last = (PerlIOl*) f++;
abf9167d 490 f->flags = 0; /* lockcnt */
303f2dc3 491 f->tab = NULL;
16865ff7 492 f->head = f;
303f2dc3 493 return (PerlIO*) f;
05d1247b
NIS
494}
495
a1ea730d
NIS
496#undef PerlIO_fdupopen
497PerlIO *
ecdeb87c 498PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
a1ea730d 499{
04892f78 500 if (PerlIOValid(f)) {
de009b76 501 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
fe5a182c 502 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
210e727c
JH
503 if (tab && tab->Dup)
504 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
37725cdc
NIS
505 else {
506 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
507 }
a1ea730d 508 }
210e727c
JH
509 else
510 SETERRNO(EBADF, SS_IVCHAN);
511
512 return NULL;
a1ea730d
NIS
513}
514
515void
303f2dc3 516PerlIO_cleantable(pTHX_ PerlIOl **tablep)
05d1247b 517{
303f2dc3 518 PerlIOl * const table = *tablep;
14a5cf38
JH
519 if (table) {
520 int i;
303f2dc3 521 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
14a5cf38 522 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
303f2dc3
DM
523 PerlIOl * const f = table + i;
524 if (f->next) {
525 PerlIO_close(&(f->next));
14a5cf38
JH
526 }
527 }
3a1ee7e8 528 Safefree(table);
14a5cf38 529 *tablep = NULL;
05d1247b 530 }
05d1247b
NIS
531}
532
fcf2db38
NIS
533
534PerlIO_list_t *
3a1ee7e8 535PerlIO_list_alloc(pTHX)
fcf2db38 536{
14a5cf38 537 PerlIO_list_t *list;
96a5add6 538 PERL_UNUSED_CONTEXT;
a02a5408 539 Newxz(list, 1, PerlIO_list_t);
14a5cf38
JH
540 list->refcnt = 1;
541 return list;
fcf2db38
NIS
542}
543
544void
3a1ee7e8 545PerlIO_list_free(pTHX_ PerlIO_list_t *list)
fcf2db38 546{
14a5cf38
JH
547 if (list) {
548 if (--list->refcnt == 0) {
549 if (list->array) {
14a5cf38 550 IV i;
ef8d46e8
VP
551 for (i = 0; i < list->cur; i++)
552 SvREFCNT_dec(list->array[i].arg);
14a5cf38
JH
553 Safefree(list->array);
554 }
555 Safefree(list);
556 }
557 }
fcf2db38
NIS
558}
559
560void
3a1ee7e8 561PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
14a5cf38 562{
97aff369 563 dVAR;
334e202e 564 PerlIO_pair_t *p;
b37c2d43
AL
565 PERL_UNUSED_CONTEXT;
566
14a5cf38
JH
567 if (list->cur >= list->len) {
568 list->len += 8;
569 if (list->array)
570 Renew(list->array, list->len, PerlIO_pair_t);
571 else
a02a5408 572 Newx(list->array, list->len, PerlIO_pair_t);
14a5cf38
JH
573 }
574 p = &(list->array[list->cur++]);
575 p->funcs = funcs;
576 if ((p->arg = arg)) {
f84c484e 577 SvREFCNT_inc_simple_void_NN(arg);
14a5cf38 578 }
fcf2db38
NIS
579}
580
3a1ee7e8
NIS
581PerlIO_list_t *
582PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
583{
b37c2d43 584 PerlIO_list_t *list = NULL;
694c95cf
JH
585 if (proto) {
586 int i;
587 list = PerlIO_list_alloc(aTHX);
588 for (i=0; i < proto->cur; i++) {
a951d81d 589 SV *arg = proto->array[i].arg;
24d147a6 590#ifdef USE_ITHREADS
a951d81d
BL
591 if (arg && param)
592 arg = sv_dup(arg, param);
593#else
594 PERL_UNUSED_ARG(param);
595#endif
694c95cf
JH
596 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
597 }
3a1ee7e8
NIS
598 }
599 return list;
600}
4a4a6116 601
05d1247b 602void
3a1ee7e8 603PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
9a6404c5 604{
3aaf42a7 605#ifdef USE_ITHREADS
303f2dc3
DM
606 PerlIOl **table = &proto->Iperlio;
607 PerlIOl *f;
3a1ee7e8
NIS
608 PL_perlio = NULL;
609 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
610 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
8995e67d 611 PerlIO_init_table(aTHX);
a25429c6 612 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
3a1ee7e8
NIS
613 while ((f = *table)) {
614 int i;
303f2dc3 615 table = (PerlIOl **) (f++);
3a1ee7e8 616 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM
617 if (f->next) {
618 (void) fp_dup(&(f->next), 0, param);
3a1ee7e8
NIS
619 }
620 f++;
621 }
622 }
1b6737cc 623#else
a25429c6 624 PERL_UNUSED_CONTEXT;
1b6737cc
AL
625 PERL_UNUSED_ARG(proto);
626 PERL_UNUSED_ARG(param);
3aaf42a7 627#endif
9a6404c5
DM
628}
629
630void
13621cfb
NIS
631PerlIO_destruct(pTHX)
632{
97aff369 633 dVAR;
303f2dc3
DM
634 PerlIOl **table = &PL_perlio;
635 PerlIOl *f;
694c95cf 636#ifdef USE_ITHREADS
a25429c6 637 PerlIO_debug("Destruct %p\n",(void*)aTHX);
694c95cf 638#endif
14a5cf38
JH
639 while ((f = *table)) {
640 int i;
303f2dc3 641 table = (PerlIOl **) (f++);
14a5cf38 642 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 643 PerlIO *x = &(f->next);
dcda55fc 644 const PerlIOl *l;
14a5cf38 645 while ((l = *x)) {
cc6623a8 646 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
14a5cf38
JH
647 PerlIO_debug("Destruct popping %s\n", l->tab->name);
648 PerlIO_flush(x);
649 PerlIO_pop(aTHX_ x);
650 }
651 else {
652 x = PerlIONext(x);
653 }
654 }
655 f++;
656 }
657 }
13621cfb
NIS
658}
659
660void
a999f61b 661PerlIO_pop(pTHX_ PerlIO *f)
760ac839 662{
dcda55fc 663 const PerlIOl *l = *f;
16865ff7 664 VERIFY_HEAD(f);
14a5cf38 665 if (l) {
cc6623a8
DM
666 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
667 l->tab ? l->tab->name : "(Null)");
668 if (l->tab && l->tab->Popped) {
14a5cf38
JH
669 /*
670 * If popped returns non-zero do not free its layer structure
671 * it has either done so itself, or it is shared and still in
71200d45 672 * use
14a5cf38 673 */
f62ce20a 674 if ((*l->tab->Popped) (aTHX_ f) != 0)
14a5cf38
JH
675 return;
676 }
abf9167d
DM
677 if (PerlIO_lockcnt(f)) {
678 /* we're in use; defer freeing the structure */
679 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
680 PerlIOBase(f)->tab = NULL;
681 }
682 else {
683 *f = l->next;
684 Safefree(l);
685 }
686
a8c08ecd 687 }
6f9d8c32
NIS
688}
689
39f7a870
JH
690/* Return as an array the stack of layers on a filehandle. Note that
691 * the stack is returned top-first in the array, and there are three
692 * times as many array elements as there are layers in the stack: the
693 * first element of a layer triplet is the name, the second one is the
694 * arguments, and the third one is the flags. */
695
696AV *
697PerlIO_get_layers(pTHX_ PerlIO *f)
698{
97aff369 699 dVAR;
dcda55fc 700 AV * const av = newAV();
39f7a870 701
dcda55fc
AL
702 if (PerlIOValid(f)) {
703 PerlIOl *l = PerlIOBase(f);
704
705 while (l) {
92e45a3e
NC
706 /* There is some collusion in the implementation of
707 XS_PerlIO_get_layers - it knows that name and flags are
708 generated as fresh SVs here, and takes advantage of that to
709 "copy" them by taking a reference. If it changes here, it needs
710 to change there too. */
dcda55fc
AL
711 SV * const name = l->tab && l->tab->name ?
712 newSVpv(l->tab->name, 0) : &PL_sv_undef;
713 SV * const arg = l->tab && l->tab->Getarg ?
714 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
715 av_push(av, name);
716 av_push(av, arg);
717 av_push(av, newSViv((IV)l->flags));
718 l = l->next;
719 }
720 }
39f7a870 721
dcda55fc 722 return av;
39f7a870
JH
723}
724
9e353e3b 725/*--------------------------------------------------------------------------------------*/
14a5cf38 726/*
71200d45 727 * XS Interface for perl code
14a5cf38 728 */
9e353e3b 729
fcf2db38 730PerlIO_funcs *
2edd7e44 731PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
f3862f8b 732{
27da23d5 733 dVAR;
14a5cf38
JH
734 IV i;
735 if ((SSize_t) len <= 0)
736 len = strlen(name);
3a1ee7e8 737 for (i = 0; i < PL_known_layers->cur; i++) {
46c461b5 738 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
ba90859e
NC
739 const STRLEN this_len = strlen(f->name);
740 if (this_len == len && memEQ(f->name, name, len)) {
fe5a182c 741 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
14a5cf38
JH
742 return f;
743 }
744 }
3a1ee7e8
NIS
745 if (load && PL_subname && PL_def_layerlist
746 && PL_def_layerlist->cur >= 2) {
d7a09b41
SR
747 if (PL_in_load_module) {
748 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
749 return NULL;
750 } else {
396482e1 751 SV * const pkgsv = newSVpvs("PerlIO");
46c461b5 752 SV * const layer = newSVpvn(name, len);
b96d8cd9 753 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
46c461b5 754 ENTER;
4fa7c2bf 755 SAVEBOOL(PL_in_load_module);
c9bca74a 756 if (cv) {
9cfa90c0 757 SAVEGENERICSV(PL_warnhook);
ad64d0ec 758 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
c9bca74a 759 }
4fa7c2bf 760 PL_in_load_module = TRUE;
d7a09b41
SR
761 /*
762 * The two SVs are magically freed by load_module
763 */
a0714e2c 764 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
d7a09b41
SR
765 LEAVE;
766 return PerlIO_find_layer(aTHX_ name, len, 0);
767 }
14a5cf38
JH
768 }
769 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
770 return NULL;
f3862f8b
NIS
771}
772
2a1bc955 773#ifdef USE_ATTRIBUTES_FOR_PERLIO
b13b2135
NIS
774
775static int
776perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
777{
14a5cf38 778 if (SvROK(sv)) {
159b6efe 779 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
dcda55fc
AL
780 PerlIO * const ifp = IoIFP(io);
781 PerlIO * const ofp = IoOFP(io);
be2597df
MHM
782 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
783 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
14a5cf38
JH
784 }
785 return 0;
b13b2135
NIS
786}
787
788static int
789perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
790{
14a5cf38 791 if (SvROK(sv)) {
159b6efe 792 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
dcda55fc
AL
793 PerlIO * const ifp = IoIFP(io);
794 PerlIO * const ofp = IoOFP(io);
be2597df
MHM
795 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
796 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
14a5cf38
JH
797 }
798 return 0;
b13b2135
NIS
799}
800
801static int
802perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
803{
be2597df 804 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
14a5cf38 805 return 0;
b13b2135
NIS
806}
807
808static int
809perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
810{
be2597df 811 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
14a5cf38 812 return 0;
b13b2135
NIS
813}
814
815MGVTBL perlio_vtab = {
14a5cf38
JH
816 perlio_mg_get,
817 perlio_mg_set,
22569500 818 NULL, /* len */
14a5cf38
JH
819 perlio_mg_clear,
820 perlio_mg_free
b13b2135
NIS
821};
822
15eb3045 823XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
b13b2135
NIS
824XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
825{
14a5cf38 826 dXSARGS;
dcda55fc
AL
827 SV * const sv = SvRV(ST(1));
828 AV * const av = newAV();
14a5cf38
JH
829 MAGIC *mg;
830 int count = 0;
831 int i;
ad64d0ec 832 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
14a5cf38
JH
833 SvRMAGICAL_off(sv);
834 mg = mg_find(sv, PERL_MAGIC_ext);
835 mg->mg_virtual = &perlio_vtab;
836 mg_magical(sv);
be2597df 837 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
14a5cf38
JH
838 for (i = 2; i < items; i++) {
839 STRLEN len;
dcda55fc
AL
840 const char * const name = SvPV_const(ST(i), len);
841 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
14a5cf38 842 if (layer) {
b37c2d43 843 av_push(av, SvREFCNT_inc_simple_NN(layer));
14a5cf38
JH
844 }
845 else {
846 ST(count) = ST(i);
847 count++;
848 }
849 }
850 SvREFCNT_dec(av);
851 XSRETURN(count);
852}
853
22569500 854#endif /* USE_ATTIBUTES_FOR_PERLIO */
2a1bc955 855
e3f3bf95
NIS
856SV *
857PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
f3862f8b 858{
da51bb9b 859 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
46c461b5 860 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
14a5cf38 861 return sv;
e3f3bf95
NIS
862}
863
15eb3045 864XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
5ca1d77f 865XS(XS_PerlIO__Layer__NoWarnings)
c9bca74a 866{
486ec47a 867 /* This is used as a %SIG{__WARN__} handler to suppress warnings
c9bca74a
NIS
868 during loading of layers.
869 */
97aff369 870 dVAR;
c9bca74a 871 dXSARGS;
58c0efa5 872 PERL_UNUSED_ARG(cv);
c9bca74a 873 if (items)
e62f0680 874 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
c9bca74a
NIS
875 XSRETURN(0);
876}
877
15eb3045 878XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
5ca1d77f 879XS(XS_PerlIO__Layer__find)
0c4f7ff0 880{
97aff369 881 dVAR;
14a5cf38 882 dXSARGS;
58c0efa5 883 PERL_UNUSED_ARG(cv);
14a5cf38
JH
884 if (items < 2)
885 Perl_croak(aTHX_ "Usage class->find(name[,load])");
886 else {
de009b76 887 STRLEN len;
46c461b5 888 const char * const name = SvPV_const(ST(1), len);
de009b76 889 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
46c461b5 890 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
14a5cf38
JH
891 ST(0) =
892 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
893 &PL_sv_undef;
894 XSRETURN(1);
895 }
0c4f7ff0
NIS
896}
897
e3f3bf95
NIS
898void
899PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
900{
97aff369 901 dVAR;
3a1ee7e8
NIS
902 if (!PL_known_layers)
903 PL_known_layers = PerlIO_list_alloc(aTHX);
a0714e2c 904 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
fe5a182c 905 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
f3862f8b
NIS
906}
907
1141d9f8 908int
fcf2db38 909PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1141d9f8 910{
97aff369 911 dVAR;
14a5cf38
JH
912 if (names) {
913 const char *s = names;
914 while (*s) {
915 while (isSPACE(*s) || *s == ':')
916 s++;
917 if (*s) {
918 STRLEN llen = 0;
919 const char *e = s;
bd61b366 920 const char *as = NULL;
14a5cf38
JH
921 STRLEN alen = 0;
922 if (!isIDFIRST(*s)) {
923 /*
924 * Message is consistent with how attribute lists are
925 * passed. Even though this means "foo : : bar" is
71200d45 926 * seen as an invalid separator character.
14a5cf38 927 */
de009b76 928 const char q = ((*s == '\'') ? '"' : '\'');
a2a5de95
NC
929 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
930 "Invalid separator character %c%c%c in PerlIO layer specification %s",
931 q, *s, q, s);
93189314 932 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
933 return -1;
934 }
935 do {
936 e++;
0eb30aeb 937 } while (isWORDCHAR(*e));
14a5cf38
JH
938 llen = e - s;
939 if (*e == '(') {
940 int nesting = 1;
941 as = ++e;
942 while (nesting) {
943 switch (*e++) {
944 case ')':
945 if (--nesting == 0)
946 alen = (e - 1) - as;
947 break;
948 case '(':
949 ++nesting;
950 break;
951 case '\\':
952 /*
953 * It's a nul terminated string, not allowed
954 * to \ the terminating null. Anything other
71200d45 955 * character is passed over.
14a5cf38
JH
956 */
957 if (*e++) {
958 break;
959 }
960 /*
71200d45 961 * Drop through
14a5cf38
JH
962 */
963 case '\0':
964 e--;
a2a5de95
NC
965 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
966 "Argument list not closed for PerlIO layer \"%.*s\"",
967 (int) (e - s), s);
14a5cf38
JH
968 return -1;
969 default:
970 /*
71200d45 971 * boring.
14a5cf38
JH
972 */
973 break;
974 }
975 }
976 }
977 if (e > s) {
46c461b5 978 PerlIO_funcs * const layer =
14a5cf38
JH
979 PerlIO_find_layer(aTHX_ s, llen, 1);
980 if (layer) {
a951d81d
BL
981 SV *arg = NULL;
982 if (as)
983 arg = newSVpvn(as, alen);
3a1ee7e8 984 PerlIO_list_push(aTHX_ av, layer,
a951d81d 985 (arg) ? arg : &PL_sv_undef);
ef8d46e8 986 SvREFCNT_dec(arg);
14a5cf38
JH
987 }
988 else {
a2a5de95
NC
989 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
990 (int) llen, s);
14a5cf38
JH
991 return -1;
992 }
993 }
994 s = e;
995 }
996 }
997 }
998 return 0;
1141d9f8
NIS
999}
1000
dfebf958 1001void
fcf2db38 1002PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
dfebf958 1003{
97aff369 1004 dVAR;
27da23d5 1005 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
35990314 1006#ifdef PERLIO_USING_CRLF
6ce75a77 1007 tab = &PerlIO_crlf;
846be114 1008#else
6ce75a77 1009 if (PerlIO_stdio.Set_ptrcnt)
22569500 1010 tab = &PerlIO_stdio;
846be114 1011#endif
14a5cf38 1012 PerlIO_debug("Pushing %s\n", tab->name);
3a1ee7e8 1013 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
14a5cf38 1014 &PL_sv_undef);
dfebf958
NIS
1015}
1016
e3f3bf95 1017SV *
14a5cf38 1018PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
e3f3bf95 1019{
14a5cf38 1020 return av->array[n].arg;
e3f3bf95
NIS
1021}
1022
f3862f8b 1023PerlIO_funcs *
14a5cf38 1024PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
f3862f8b 1025{
14a5cf38
JH
1026 if (n >= 0 && n < av->cur) {
1027 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1028 av->array[n].funcs->name);
1029 return av->array[n].funcs;
1030 }
1031 if (!def)
1032 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1033 return def;
e3f3bf95
NIS
1034}
1035
4ec2216f
NIS
1036IV
1037PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1038{
8772537c
AL
1039 PERL_UNUSED_ARG(mode);
1040 PERL_UNUSED_ARG(arg);
1041 PERL_UNUSED_ARG(tab);
4ec2216f
NIS
1042 if (PerlIOValid(f)) {
1043 PerlIO_flush(f);
1044 PerlIO_pop(aTHX_ f);
1045 return 0;
1046 }
1047 return -1;
1048}
1049
27da23d5 1050PERLIO_FUNCS_DECL(PerlIO_remove) = {
4ec2216f
NIS
1051 sizeof(PerlIO_funcs),
1052 "pop",
1053 0,
1054 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1055 PerlIOPop_pushed,
1056 NULL,
c0888ace 1057 PerlIOBase_open,
4ec2216f
NIS
1058 NULL,
1059 NULL,
1060 NULL,
1061 NULL,
1062 NULL,
1063 NULL,
1064 NULL,
1065 NULL,
de009b76
AL
1066 NULL,
1067 NULL,
4ec2216f
NIS
1068 NULL, /* flush */
1069 NULL, /* fill */
1070 NULL,
1071 NULL,
1072 NULL,
1073 NULL,
1074 NULL, /* get_base */
1075 NULL, /* get_bufsiz */
1076 NULL, /* get_ptr */
1077 NULL, /* get_cnt */
1078 NULL, /* set_ptrcnt */
1079};
1080
fcf2db38 1081PerlIO_list_t *
e3f3bf95
NIS
1082PerlIO_default_layers(pTHX)
1083{
97aff369 1084 dVAR;
3a1ee7e8 1085 if (!PL_def_layerlist) {
284167a5 1086 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
27da23d5 1087 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
3a1ee7e8 1088 PL_def_layerlist = PerlIO_list_alloc(aTHX);
27da23d5 1089 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
979e2c82 1090#if defined(WIN32)
27da23d5 1091 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
2f8118af 1092#if 0
14a5cf38 1093 osLayer = &PerlIO_win32;
0c4128ad 1094#endif
2f8118af 1095#endif
27da23d5
JH
1096 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1097 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1098 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1099 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
27da23d5
JH
1100 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1101 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1102 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
3a1ee7e8 1103 PerlIO_list_push(aTHX_ PL_def_layerlist,
14a5cf38
JH
1104 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1105 &PL_sv_undef);
1106 if (s) {
3a1ee7e8 1107 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
14a5cf38
JH
1108 }
1109 else {
3a1ee7e8 1110 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
14a5cf38 1111 }
1141d9f8 1112 }
3a1ee7e8
NIS
1113 if (PL_def_layerlist->cur < 2) {
1114 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
f3862f8b 1115 }
3a1ee7e8 1116 return PL_def_layerlist;
e3f3bf95
NIS
1117}
1118
0c4f7ff0
NIS
1119void
1120Perl_boot_core_PerlIO(pTHX)
1121{
1122#ifdef USE_ATTRIBUTES_FOR_PERLIO
14a5cf38
JH
1123 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1124 __FILE__);
0c4f7ff0 1125#endif
14a5cf38 1126 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
c9bca74a 1127 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
0c4f7ff0 1128}
e3f3bf95
NIS
1129
1130PerlIO_funcs *
1131PerlIO_default_layer(pTHX_ I32 n)
1132{
97aff369 1133 dVAR;
46c461b5 1134 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
14a5cf38
JH
1135 if (n < 0)
1136 n += av->cur;
27da23d5 1137 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
f3862f8b
NIS
1138}
1139
a999f61b
NIS
1140#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1141#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
60382766
NIS
1142
1143void
1141d9f8 1144PerlIO_stdstreams(pTHX)
60382766 1145{
97aff369 1146 dVAR;
a1ea730d 1147 if (!PL_perlio) {
8995e67d 1148 PerlIO_init_table(aTHX);
14a5cf38
JH
1149 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1150 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1151 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1152 }
60382766
NIS
1153}
1154
1155PerlIO *
27da23d5 1156PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
14a5cf38 1157{
16865ff7 1158 VERIFY_HEAD(f);
2dc2558e 1159 if (tab->fsize != sizeof(PerlIO_funcs)) {
0dc17498 1160 Perl_croak( aTHX_
5cf96513
RB
1161 "%s (%"UVuf") does not match %s (%"UVuf")",
1162 "PerlIO layer function table size", (UV)tab->fsize,
1163 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
2dc2558e
NIS
1164 }
1165 if (tab->size) {
b464bac0 1166 PerlIOl *l;
2dc2558e 1167 if (tab->size < sizeof(PerlIOl)) {
0dc17498 1168 Perl_croak( aTHX_
5cf96513
RB
1169 "%s (%"UVuf") smaller than %s (%"UVuf")",
1170 "PerlIO layer instance size", (UV)tab->size,
1171 "size expected by this perl", (UV)sizeof(PerlIOl) );
2dc2558e
NIS
1172 }
1173 /* Real layer with a data area */
002e75cf
JH
1174 if (f) {
1175 char *temp;
1176 Newxz(temp, tab->size, char);
1177 l = (PerlIOl*)temp;
1178 if (l) {
1179 l->next = *f;
1180 l->tab = (PerlIO_funcs*) tab;
16865ff7 1181 l->head = ((PerlIOl*)f)->head;
002e75cf
JH
1182 *f = l;
1183 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1184 (void*)f, tab->name,
1185 (mode) ? mode : "(Null)", (void*)arg);
1186 if (*l->tab->Pushed &&
1187 (*l->tab->Pushed)
1188 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1189 PerlIO_pop(aTHX_ f);
1190 return NULL;
1191 }
2dc2558e 1192 }
002e75cf
JH
1193 else
1194 return NULL;
2dc2558e
NIS
1195 }
1196 }
1197 else if (f) {
1198 /* Pseudo-layer where push does its own stack adjust */
00f51856
NIS
1199 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1200 (mode) ? mode : "(Null)", (void*)arg);
210e727c 1201 if (tab->Pushed &&
27da23d5 1202 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
210e727c 1203 return NULL;
14a5cf38
JH
1204 }
1205 }
1206 return f;
60382766
NIS
1207}
1208
81fe74fb
LT
1209PerlIO *
1210PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1211 IV n, const char *mode, int fd, int imode, int perm,
1212 PerlIO *old, int narg, SV **args)
1213{
1214 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1215 if (tab && tab->Open) {
1216 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
6d5bdea2 1217 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
81fe74fb
LT
1218 PerlIO_close(ret);
1219 return NULL;
1220 }
1221 return ret;
1222 }
1223 SETERRNO(EINVAL, LIB_INVARG);
1224 return NULL;
1225}
1226
dfebf958 1227IV
86e05cf2
NIS
1228PerlIOBase_binmode(pTHX_ PerlIO *f)
1229{
1230 if (PerlIOValid(f)) {
1231 /* Is layer suitable for raw stream ? */
cc6623a8 1232 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
86e05cf2
NIS
1233 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1234 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1235 }
1236 else {
1237 /* Not suitable - pop it */
1238 PerlIO_pop(aTHX_ f);
1239 }
1240 return 0;
1241 }
1242 return -1;
1243}
1244
1245IV
2dc2558e 1246PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
dfebf958 1247{
8772537c
AL
1248 PERL_UNUSED_ARG(mode);
1249 PERL_UNUSED_ARG(arg);
1250 PERL_UNUSED_ARG(tab);
86e05cf2 1251
04892f78 1252 if (PerlIOValid(f)) {
86e05cf2 1253 PerlIO *t;
de009b76 1254 const PerlIOl *l;
14a5cf38 1255 PerlIO_flush(f);
86e05cf2
NIS
1256 /*
1257 * Strip all layers that are not suitable for a raw stream
1258 */
1259 t = f;
1260 while (t && (l = *t)) {
cc6623a8 1261 if (l->tab && l->tab->Binmode) {
86e05cf2 1262 /* Has a handler - normal case */
9d97e8b8 1263 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
86e05cf2
NIS
1264 if (*t == l) {
1265 /* Layer still there - move down a layer */
1266 t = PerlIONext(t);
1267 }
1268 }
1269 else {
1270 return -1;
1271 }
14a5cf38
JH
1272 }
1273 else {
86e05cf2
NIS
1274 /* No handler - pop it */
1275 PerlIO_pop(aTHX_ t);
14a5cf38
JH
1276 }
1277 }
86e05cf2 1278 if (PerlIOValid(f)) {
cc6623a8
DM
1279 PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1280 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
86e05cf2
NIS
1281 return 0;
1282 }
14a5cf38
JH
1283 }
1284 return -1;
dfebf958
NIS
1285}
1286
ac27b0f5 1287int
14a5cf38 1288PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
d9dac8cd 1289 PerlIO_list_t *layers, IV n, IV max)
14a5cf38 1290{
14a5cf38
JH
1291 int code = 0;
1292 while (n < max) {
8772537c 1293 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
14a5cf38
JH
1294 if (tab) {
1295 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1296 code = -1;
1297 break;
1298 }
1299 }
1300 n++;
1301 }
1302 return code;
e3f3bf95
NIS
1303}
1304
1305int
ac27b0f5
NIS
1306PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1307{
14a5cf38 1308 int code = 0;
da0fccaa
DG
1309 ENTER;
1310 save_scalar(PL_errgv);
53f1b6d2 1311 if (f && names) {
8772537c 1312 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
14a5cf38
JH
1313 code = PerlIO_parse_layers(aTHX_ layers, names);
1314 if (code == 0) {
d9dac8cd 1315 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
14a5cf38 1316 }
3a1ee7e8 1317 PerlIO_list_free(aTHX_ layers);
ac27b0f5 1318 }
da0fccaa 1319 LEAVE;
14a5cf38 1320 return code;
ac27b0f5
NIS
1321}
1322
f3862f8b 1323
60382766 1324/*--------------------------------------------------------------------------------------*/
14a5cf38 1325/*
71200d45 1326 * Given the abstraction above the public API functions
14a5cf38 1327 */
60382766
NIS
1328
1329int
f5b9d040 1330PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 1331{
68b5363f 1332 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
cc6623a8
DM
1333 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1334 PerlIOBase(f)->tab->name : "(Null)",
68b5363f
PD
1335 iotype, mode, (names) ? names : "(Null)");
1336
03c0554d
NIS
1337 if (names) {
1338 /* Do not flush etc. if (e.g.) switching encodings.
1339 if a pushed layer knows it needs to flush lower layers
1340 (for example :unix which is never going to call them)
1341 it can do the flush when it is pushed.
1342 */
1343 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1344 }
1345 else {
86e05cf2 1346 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
35990314 1347#ifdef PERLIO_USING_CRLF
03c0554d
NIS
1348 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1349 O_BINARY so we can look for it in mode.
1350 */
1351 if (!(mode & O_BINARY)) {
1352 /* Text mode */
86e05cf2
NIS
1353 /* FIXME?: Looking down the layer stack seems wrong,
1354 but is a way of reaching past (say) an encoding layer
1355 to flip CRLF-ness of the layer(s) below
1356 */
03c0554d
NIS
1357 while (*f) {
1358 /* Perhaps we should turn on bottom-most aware layer
1359 e.g. Ilya's idea that UNIX TTY could serve
1360 */
cc6623a8
DM
1361 if (PerlIOBase(f)->tab &&
1362 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1363 {
03c0554d
NIS
1364 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1365 /* Not in text mode - flush any pending stuff and flip it */
1366 PerlIO_flush(f);
1367 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1368 }
1369 /* Only need to turn it on in one layer so we are done */
1370 return TRUE;
ed53a2bb 1371 }
03c0554d 1372 f = PerlIONext(f);
14a5cf38 1373 }
03c0554d
NIS
1374 /* Not finding a CRLF aware layer presumably means we are binary
1375 which is not what was requested - so we failed
1376 We _could_ push :crlf layer but so could caller
1377 */
1378 return FALSE;
14a5cf38 1379 }
6ce75a77 1380#endif
86e05cf2
NIS
1381 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1382 So code that used to be here is now in PerlIORaw_pushed().
03c0554d 1383 */
a0714e2c 1384 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
14a5cf38 1385 }
f5b9d040
NIS
1386}
1387
f5b9d040 1388int
e87a358a 1389PerlIO__close(pTHX_ PerlIO *f)
f5b9d040 1390{
37725cdc 1391 if (PerlIOValid(f)) {
46c461b5 1392 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
37725cdc
NIS
1393 if (tab && tab->Close)
1394 return (*tab->Close)(aTHX_ f);
1395 else
1396 return PerlIOBase_close(aTHX_ f);
1397 }
14a5cf38 1398 else {
93189314 1399 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1400 return -1;
1401 }
76ced9ad
NIS
1402}
1403
b931b1d9 1404int
e87a358a 1405Perl_PerlIO_close(pTHX_ PerlIO *f)
b931b1d9 1406{
de009b76 1407 const int code = PerlIO__close(aTHX_ f);
37725cdc
NIS
1408 while (PerlIOValid(f)) {
1409 PerlIO_pop(aTHX_ f);
abf9167d
DM
1410 if (PerlIO_lockcnt(f))
1411 /* we're in use; the 'pop' deferred freeing the structure */
1412 f = PerlIONext(f);
f6c77cf1 1413 }
14a5cf38 1414 return code;
b931b1d9
NIS
1415}
1416
b931b1d9 1417int
e87a358a 1418Perl_PerlIO_fileno(pTHX_ PerlIO *f)
b931b1d9 1419{
97aff369 1420 dVAR;
b32dd47e 1421 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
b931b1d9
NIS
1422}
1423
1141d9f8 1424
fcf2db38 1425static PerlIO_funcs *
2edd7e44
NIS
1426PerlIO_layer_from_ref(pTHX_ SV *sv)
1427{
97aff369 1428 dVAR;
14a5cf38 1429 /*
71200d45 1430 * For any scalar type load the handler which is bundled with perl
14a5cf38 1431 */
526fd1b4 1432 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
75208dda
RGS
1433 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1434 /* This isn't supposed to happen, since PerlIO::scalar is core,
1435 * but could happen anyway in smaller installs or with PAR */
a2a5de95 1436 if (!f)
dcbac5bb 1437 /* diag_listed_as: Unknown PerlIO layer "%s" */
a2a5de95 1438 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
75208dda
RGS
1439 return f;
1440 }
14a5cf38
JH
1441
1442 /*
71200d45 1443 * For other types allow if layer is known but don't try and load it
14a5cf38
JH
1444 */
1445 switch (SvTYPE(sv)) {
1446 case SVt_PVAV:
6a245ed1 1447 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
14a5cf38 1448 case SVt_PVHV:
6a245ed1 1449 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
14a5cf38 1450 case SVt_PVCV:
6a245ed1 1451 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
14a5cf38 1452 case SVt_PVGV:
6a245ed1 1453 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
42d0e0b7
AL
1454 default:
1455 return NULL;
14a5cf38 1456 }
2edd7e44
NIS
1457}
1458
fcf2db38 1459PerlIO_list_t *
14a5cf38
JH
1460PerlIO_resolve_layers(pTHX_ const char *layers,
1461 const char *mode, int narg, SV **args)
1462{
97aff369 1463 dVAR;
14a5cf38
JH
1464 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1465 int incdef = 1;
a1ea730d 1466 if (!PL_perlio)
14a5cf38
JH
1467 PerlIO_stdstreams(aTHX);
1468 if (narg) {
dcda55fc 1469 SV * const arg = *args;
14a5cf38 1470 /*
71200d45
NIS
1471 * If it is a reference but not an object see if we have a handler
1472 * for it
14a5cf38
JH
1473 */
1474 if (SvROK(arg) && !sv_isobject(arg)) {
46c461b5 1475 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1476 if (handler) {
3a1ee7e8
NIS
1477 def = PerlIO_list_alloc(aTHX);
1478 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH
1479 incdef = 0;
1480 }
1481 /*
e934609f 1482 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1483 * something sensible else we will just stringfy and open
71200d45 1484 * resulting string.
14a5cf38
JH
1485 */
1486 }
1487 }
9fe371da 1488 if (!layers || !*layers)
11bcd5da 1489 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1490 if (layers && *layers) {
1491 PerlIO_list_t *av;
1492 if (incdef) {
a951d81d 1493 av = PerlIO_clone_list(aTHX_ def, NULL);
14a5cf38
JH
1494 }
1495 else {
1496 av = def;
1497 }
0cff2cf3
NIS
1498 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1499 return av;
1500 }
1501 else {
1502 PerlIO_list_free(aTHX_ av);
b37c2d43 1503 return NULL;
0cff2cf3 1504 }
14a5cf38
JH
1505 }
1506 else {
1507 if (incdef)
1508 def->refcnt++;
1509 return def;
1510 }
ee518936
NIS
1511}
1512
1513PerlIO *
14a5cf38
JH
1514PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1515 int imode, int perm, PerlIO *f, int narg, SV **args)
1516{
97aff369 1517 dVAR;
14a5cf38
JH
1518 if (!f && narg == 1 && *args == &PL_sv_undef) {
1519 if ((f = PerlIO_tmpfile())) {
9fe371da 1520 if (!layers || !*layers)
11bcd5da 1521 layers = Perl_PerlIO_context_layers(aTHX_ mode);
14a5cf38
JH
1522 if (layers && *layers)
1523 PerlIO_apply_layers(aTHX_ f, mode, layers);
1524 }
1525 }
1526 else {
de009b76 1527 PerlIO_list_t *layera;
14a5cf38
JH
1528 IV n;
1529 PerlIO_funcs *tab = NULL;
04892f78 1530 if (PerlIOValid(f)) {
14a5cf38 1531 /*
71200d45
NIS
1532 * This is "reopen" - it is not tested as perl does not use it
1533 * yet
14a5cf38
JH
1534 */
1535 PerlIOl *l = *f;
3a1ee7e8 1536 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1537 while (l) {
a951d81d 1538 SV *arg = NULL;
cc6623a8 1539 if (l->tab && l->tab->Getarg)
a951d81d
BL
1540 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1541 PerlIO_list_push(aTHX_ layera, l->tab,
1542 (arg) ? arg : &PL_sv_undef);
ef8d46e8 1543 SvREFCNT_dec(arg);
14a5cf38
JH
1544 l = *PerlIONext(&l);
1545 }
1546 }
1547 else {
1548 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS
1549 if (!layera) {
1550 return NULL;
1551 }
14a5cf38
JH
1552 }
1553 /*
71200d45 1554 * Start at "top" of layer stack
14a5cf38
JH
1555 */
1556 n = layera->cur - 1;
1557 while (n >= 0) {
46c461b5 1558 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH
1559 if (t && t->Open) {
1560 tab = t;
1561 break;
1562 }
1563 n--;
1564 }
1565 if (tab) {
1566 /*
71200d45 1567 * Found that layer 'n' can do opens - call it
14a5cf38 1568 */
7cf31beb 1569 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1570 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1571 }
14a5cf38 1572 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
355d3743
PD
1573 tab->name, layers ? layers : "(Null)", mode, fd,
1574 imode, perm, (void*)f, narg, (void*)args);
210e727c
JH
1575 if (tab->Open)
1576 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1577 f, narg, args);
1578 else {
1579 SETERRNO(EINVAL, LIB_INVARG);
1580 f = NULL;
1581 }
14a5cf38
JH
1582 if (f) {
1583 if (n + 1 < layera->cur) {
1584 /*
1585 * More layers above the one that we used to open -
71200d45 1586 * apply them now
14a5cf38 1587 */
d9dac8cd
NIS
1588 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1589 /* If pushing layers fails close the file */
1590 PerlIO_close(f);
14a5cf38
JH
1591 f = NULL;
1592 }
1593 }
1594 }
1595 }
3a1ee7e8 1596 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH
1597 }
1598 return f;
ee518936 1599}
b931b1d9
NIS
1600
1601
9e353e3b 1602SSize_t
e87a358a 1603Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1604{
7918f24d
NC
1605 PERL_ARGS_ASSERT_PERLIO_READ;
1606
b32dd47e 1607 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1608}
1609
313ca112 1610SSize_t
e87a358a 1611Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1612{
7918f24d
NC
1613 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1614
b32dd47e 1615 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1616}
1617
9e353e3b 1618SSize_t
e87a358a 1619Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1620{
7918f24d
NC
1621 PERL_ARGS_ASSERT_PERLIO_WRITE;
1622
b32dd47e 1623 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW
1624}
1625
6f9d8c32 1626int
e87a358a 1627Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1628{
b32dd47e 1629 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW
1630}
1631
9e353e3b 1632Off_t
e87a358a 1633Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1634{
b32dd47e 1635 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW
1636}
1637
6f9d8c32 1638int
e87a358a 1639Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1640{
97aff369 1641 dVAR;
14a5cf38
JH
1642 if (f) {
1643 if (*f) {
de009b76 1644 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1b7a0411
JH
1645
1646 if (tab && tab->Flush)
f62ce20a 1647 return (*tab->Flush) (aTHX_ f);
1b7a0411
JH
1648 else
1649 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH
1650 }
1651 else {
fe5a182c 1652 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
93189314 1653 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH
1654 return -1;
1655 }
1656 }
1657 else {
1658 /*
1659 * Is it good API design to do flush-all on NULL, a potentially
486ec47a 1660 * erroneous input? Maybe some magical value (PerlIO*
14a5cf38
JH
1661 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1662 * things on fflush(NULL), but should we be bound by their design
71200d45 1663 * decisions? --jhi
14a5cf38 1664 */
303f2dc3
DM
1665 PerlIOl **table = &PL_perlio;
1666 PerlIOl *ff;
14a5cf38 1667 int code = 0;
303f2dc3 1668 while ((ff = *table)) {
14a5cf38 1669 int i;
303f2dc3 1670 table = (PerlIOl **) (ff++);
14a5cf38 1671 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3 1672 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
14a5cf38 1673 code = -1;
303f2dc3 1674 ff++;
14a5cf38
JH
1675 }
1676 }
1677 return code;
1678 }
760ac839
LW
1679}
1680
a9c883f6 1681void
f62ce20a 1682PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1683{
97aff369 1684 dVAR;
303f2dc3
DM
1685 PerlIOl **table = &PL_perlio;
1686 PerlIOl *f;
14a5cf38
JH
1687 while ((f = *table)) {
1688 int i;
303f2dc3 1689 table = (PerlIOl **) (f++);
14a5cf38 1690 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
303f2dc3
DM
1691 if (f->next
1692 && (PerlIOBase(&(f->next))->
14a5cf38
JH
1693 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1694 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
303f2dc3 1695 PerlIO_flush(&(f->next));
14a5cf38
JH
1696 f++;
1697 }
a9c883f6 1698 }
a9c883f6
NIS
1699}
1700
06da4f11 1701int
e87a358a 1702Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1703{
b32dd47e 1704 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS
1705}
1706
f3862f8b
NIS
1707int
1708PerlIO_isutf8(PerlIO *f)
1709{
1b7a0411
JH
1710 if (PerlIOValid(f))
1711 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1712 else
1713 SETERRNO(EBADF, SS_IVCHAN);
37725cdc 1714
1b7a0411 1715 return -1;
f3862f8b
NIS
1716}
1717
6f9d8c32 1718int
e87a358a 1719Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1720{
b32dd47e 1721 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS
1722}
1723
9e353e3b 1724int
e87a358a 1725Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1726{
b32dd47e 1727 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS
1728}
1729
9e353e3b 1730void
e87a358a 1731Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1732{
b32dd47e 1733 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS
1734}
1735
9e353e3b 1736void
e87a358a 1737Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1738{
b32dd47e 1739 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS
1740}
1741
9e353e3b
NIS
1742int
1743PerlIO_has_base(PerlIO *f)
1744{
1b7a0411 1745 if (PerlIOValid(f)) {
46c461b5 1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1747
1748 if (tab)
1749 return (tab->Get_base != NULL);
1b7a0411 1750 }
1b7a0411
JH
1751
1752 return 0;
760ac839
LW
1753}
1754
9e353e3b
NIS
1755int
1756PerlIO_fast_gets(PerlIO *f)
760ac839 1757{
d7dfc388
SK
1758 if (PerlIOValid(f)) {
1759 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1760 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411 1761
d7dfc388
SK
1762 if (tab)
1763 return (tab->Set_ptrcnt != NULL);
d7dfc388 1764 }
14a5cf38 1765 }
1b7a0411 1766
14a5cf38 1767 return 0;
9e353e3b
NIS
1768}
1769
9e353e3b
NIS
1770int
1771PerlIO_has_cntptr(PerlIO *f)
1772{
04892f78 1773 if (PerlIOValid(f)) {
46c461b5 1774 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1775
1776 if (tab)
1777 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
14a5cf38 1778 }
1b7a0411 1779
14a5cf38 1780 return 0;
9e353e3b
NIS
1781}
1782
9e353e3b
NIS
1783int
1784PerlIO_canset_cnt(PerlIO *f)
1785{
04892f78 1786 if (PerlIOValid(f)) {
46c461b5 1787 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1b7a0411
JH
1788
1789 if (tab)
1790 return (tab->Set_ptrcnt != NULL);
14a5cf38 1791 }
1b7a0411 1792
14a5cf38 1793 return 0;
760ac839
LW
1794}
1795
888911fc 1796STDCHAR *
e87a358a 1797Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1798{
b32dd47e 1799 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS
1800}
1801
b66f3475 1802SSize_t
e87a358a 1803Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1804{
b66f3475 1805 /* Note that Get_bufsiz returns a Size_t */
b32dd47e 1806 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS
1807}
1808
9e353e3b 1809STDCHAR *
e87a358a 1810Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1811{
b32dd47e 1812 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS
1813}
1814
b66f3475 1815SSize_t
e87a358a 1816Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1817{
b32dd47e 1818 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS
1819}
1820
9e353e3b 1821void
b66f3475 1822Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
9e353e3b 1823{
b32dd47e 1824 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS
1825}
1826
9e353e3b 1827void
b66f3475 1828Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 1829{
b32dd47e 1830 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS
1831}
1832
4ec2216f 1833
9e353e3b 1834/*--------------------------------------------------------------------------------------*/
14a5cf38 1835/*
71200d45 1836 * utf8 and raw dummy layers
14a5cf38 1837 */
dfebf958 1838
26fb694e 1839IV
2dc2558e 1840PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1841{
96a5add6 1842 PERL_UNUSED_CONTEXT;
8772537c
AL
1843 PERL_UNUSED_ARG(mode);
1844 PERL_UNUSED_ARG(arg);
00f51856 1845 if (PerlIOValid(f)) {
cc6623a8 1846 if (tab && tab->kind & PERLIO_K_UTF8)
14a5cf38
JH
1847 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1848 else
1849 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1850 return 0;
1851 }
1852 return -1;
26fb694e
NIS
1853}
1854
27da23d5 1855PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1856 sizeof(PerlIO_funcs),
14a5cf38 1857 "utf8",
2dc2558e 1858 0,
a778d1f5 1859 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
14a5cf38
JH
1860 PerlIOUtf8_pushed,
1861 NULL,
c0888ace 1862 PerlIOBase_open,
14a5cf38
JH
1863 NULL,
1864 NULL,
1865 NULL,
1866 NULL,
1867 NULL,
1868 NULL,
1869 NULL,
1870 NULL,
de009b76
AL
1871 NULL,
1872 NULL,
22569500
NIS
1873 NULL, /* flush */
1874 NULL, /* fill */
14a5cf38
JH
1875 NULL,
1876 NULL,
1877 NULL,
1878 NULL,
22569500
NIS
1879 NULL, /* get_base */
1880 NULL, /* get_bufsiz */
1881 NULL, /* get_ptr */
1882 NULL, /* get_cnt */
1883 NULL, /* set_ptrcnt */
26fb694e
NIS
1884};
1885
27da23d5 1886PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1887 sizeof(PerlIO_funcs),
14a5cf38 1888 "bytes",
2dc2558e 1889 0,
a778d1f5 1890 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
14a5cf38
JH
1891 PerlIOUtf8_pushed,
1892 NULL,
c0888ace 1893 PerlIOBase_open,
14a5cf38
JH
1894 NULL,
1895 NULL,
1896 NULL,
1897 NULL,
1898 NULL,
1899 NULL,
1900 NULL,
1901 NULL,
de009b76
AL
1902 NULL,
1903 NULL,
22569500
NIS
1904 NULL, /* flush */
1905 NULL, /* fill */
14a5cf38
JH
1906 NULL,
1907 NULL,
1908 NULL,
1909 NULL,
22569500
NIS
1910 NULL, /* get_base */
1911 NULL, /* get_bufsiz */
1912 NULL, /* get_ptr */
1913 NULL, /* get_cnt */
1914 NULL, /* set_ptrcnt */
dfebf958
NIS
1915};
1916
27da23d5 1917PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 1918 sizeof(PerlIO_funcs),
14a5cf38 1919 "raw",
2dc2558e 1920 0,
14a5cf38
JH
1921 PERLIO_K_DUMMY,
1922 PerlIORaw_pushed,
1923 PerlIOBase_popped,
ecfd0649 1924 PerlIOBase_open,
14a5cf38
JH
1925 NULL,
1926 NULL,
1927 NULL,
1928 NULL,
1929 NULL,
1930 NULL,
1931 NULL,
1932 NULL,
de009b76
AL
1933 NULL,
1934 NULL,
22569500
NIS
1935 NULL, /* flush */
1936 NULL, /* fill */
14a5cf38
JH
1937 NULL,
1938 NULL,
1939 NULL,
1940 NULL,
22569500
NIS
1941 NULL, /* get_base */
1942 NULL, /* get_bufsiz */
1943 NULL, /* get_ptr */
1944 NULL, /* get_cnt */
1945 NULL, /* set_ptrcnt */
dfebf958
NIS
1946};
1947/*--------------------------------------------------------------------------------------*/
1948/*--------------------------------------------------------------------------------------*/
14a5cf38 1949/*
71200d45 1950 * "Methods" of the "base class"
14a5cf38 1951 */
9e353e3b
NIS
1952
1953IV
f62ce20a 1954PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 1955{
04892f78 1956 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS
1957}
1958
f5b9d040 1959char *
81428673 1960PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH
1961{
1962 char *s = buf;
81428673 1963 if (PerlIOValid(f)) {
de009b76 1964 const IV flags = PerlIOBase(f)->flags;
81428673
NIS
1965 if (flags & PERLIO_F_APPEND) {
1966 *s++ = 'a';
1967 if (flags & PERLIO_F_CANREAD) {
1968 *s++ = '+';
1969 }
14a5cf38 1970 }
81428673
NIS
1971 else if (flags & PERLIO_F_CANREAD) {
1972 *s++ = 'r';
1973 if (flags & PERLIO_F_CANWRITE)
1974 *s++ = '+';
1975 }
1976 else if (flags & PERLIO_F_CANWRITE) {
1977 *s++ = 'w';
1978 if (flags & PERLIO_F_CANREAD) {
1979 *s++ = '+';
1980 }
14a5cf38 1981 }
35990314 1982#ifdef PERLIO_USING_CRLF
81428673
NIS
1983 if (!(flags & PERLIO_F_CRLF))
1984 *s++ = 'b';
5f1a76d0 1985#endif
81428673 1986 }
14a5cf38
JH
1987 *s = '\0';
1988 return buf;
f5b9d040
NIS
1989}
1990
81428673 1991
76ced9ad 1992IV
2dc2558e 1993PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 1994{
de009b76 1995 PerlIOl * const l = PerlIOBase(f);
96a5add6 1996 PERL_UNUSED_CONTEXT;
8772537c 1997 PERL_UNUSED_ARG(arg);
de009b76 1998
14a5cf38
JH
1999 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2000 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
cc6623a8 2001 if (tab && tab->Set_ptrcnt != NULL)
14a5cf38
JH
2002 l->flags |= PERLIO_F_FASTGETS;
2003 if (mode) {
3b6c1aba 2004 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2005 mode++;
2006 switch (*mode++) {
2007 case 'r':
2008 l->flags |= PERLIO_F_CANREAD;
2009 break;
2010 case 'a':
2011 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2012 break;
2013 case 'w':
2014 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2015 break;
2016 default:
93189314 2017 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2018 return -1;
2019 }
2020 while (*mode) {
2021 switch (*mode++) {
2022 case '+':
2023 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2024 break;
2025 case 'b':
2026 l->flags &= ~PERLIO_F_CRLF;
2027 break;
2028 case 't':
2029 l->flags |= PERLIO_F_CRLF;
2030 break;
2031 default:
93189314 2032 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2033 return -1;
2034 }
2035 }
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
14a5cf38 2045 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
6c9570dc 2046 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
14a5cf38 2047 l->flags, PerlIO_modestr(f, temp));
5e2ab84b 2048#endif
14a5cf38 2049 return 0;
76ced9ad
NIS
2050}
2051
2052IV
f62ce20a 2053PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2054{
96a5add6 2055 PERL_UNUSED_CONTEXT;
8772537c 2056 PERL_UNUSED_ARG(f);
14a5cf38 2057 return 0;
760ac839
LW
2058}
2059
9e353e3b 2060SSize_t
f62ce20a 2061PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2062{
14a5cf38 2063 /*
71200d45 2064 * Save the position as current head considers it
14a5cf38 2065 */
de009b76 2066 const Off_t old = PerlIO_tell(f);
a0714e2c 2067 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2068 PerlIOSelf(f, PerlIOBuf)->posn = old;
de009b76 2069 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS
2070}
2071
f6c77cf1 2072SSize_t
f62ce20a 2073PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2074{
14a5cf38
JH
2075 STDCHAR *buf = (STDCHAR *) vbuf;
2076 if (f) {
263df5f1
JH
2077 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2078 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2079 SETERRNO(EBADF, SS_IVCHAN);
2080 return 0;
2081 }
14a5cf38 2082 while (count > 0) {
93c2c2ec
IZ
2083 get_cnt:
2084 {
14a5cf38
JH
2085 SSize_t avail = PerlIO_get_cnt(f);
2086 SSize_t take = 0;
2087 if (avail > 0)
94e529cc 2088 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
14a5cf38
JH
2089 if (take > 0) {
2090 STDCHAR *ptr = PerlIO_get_ptr(f);
2091 Copy(ptr, buf, take, STDCHAR);
2092 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2093 count -= take;
2094 buf += take;
93c2c2ec
IZ
2095 if (avail == 0) /* set_ptrcnt could have reset avail */
2096 goto get_cnt;
14a5cf38
JH
2097 }
2098 if (count > 0 && avail <= 0) {
2099 if (PerlIO_fill(f) != 0)
2100 break;
2101 }
93c2c2ec 2102 }
14a5cf38
JH
2103 }
2104 return (buf - (STDCHAR *) vbuf);
2105 }
f6c77cf1 2106 return 0;
f6c77cf1
NIS
2107}
2108
9e353e3b 2109IV
f62ce20a 2110PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2111{
96a5add6 2112 PERL_UNUSED_CONTEXT;
8772537c 2113 PERL_UNUSED_ARG(f);
14a5cf38 2114 return 0;
9e353e3b
NIS
2115}
2116
2117IV
f62ce20a 2118PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2119{
96a5add6 2120 PERL_UNUSED_CONTEXT;
8772537c 2121 PERL_UNUSED_ARG(f);
14a5cf38 2122 return -1;
06da4f11
NIS
2123}
2124
2125IV
f62ce20a 2126PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2127{
37725cdc
NIS
2128 IV code = -1;
2129 if (PerlIOValid(f)) {
2130 PerlIO *n = PerlIONext(f);
2131 code = PerlIO_flush(f);
2132 PerlIOBase(f)->flags &=
2133 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2134 while (PerlIOValid(n)) {
de009b76 2135 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
37725cdc
NIS
2136 if (tab && tab->Close) {
2137 if ((*tab->Close)(aTHX_ n) != 0)
2138 code = -1;
2139 break;
2140 }
2141 else {
2142 PerlIOBase(n)->flags &=
2143 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2144 }
2145 n = PerlIONext(n);
2146 }
2147 }
2148 else {
2149 SETERRNO(EBADF, SS_IVCHAN);
2150 }
14a5cf38 2151 return code;
9e353e3b
NIS
2152}
2153
2154IV
f62ce20a 2155PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2156{
96a5add6 2157 PERL_UNUSED_CONTEXT;
04892f78 2158 if (PerlIOValid(f)) {
14a5cf38
JH
2159 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2160 }
2161 return 1;
9e353e3b
NIS
2162}
2163
2164IV
f62ce20a 2165PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2166{
96a5add6 2167 PERL_UNUSED_CONTEXT;
04892f78 2168 if (PerlIOValid(f)) {
14a5cf38
JH
2169 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2170 }
2171 return 1;
9e353e3b
NIS
2172}
2173
2174void
f62ce20a 2175PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2176{
04892f78 2177 if (PerlIOValid(f)) {
dcda55fc 2178 PerlIO * const n = PerlIONext(f);
14a5cf38 2179 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2180 if (PerlIOValid(n))
14a5cf38
JH
2181 PerlIO_clearerr(n);
2182 }
9e353e3b
NIS
2183}
2184
2185void
f62ce20a 2186PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2187{
96a5add6 2188 PERL_UNUSED_CONTEXT;
04892f78 2189 if (PerlIOValid(f)) {
14a5cf38
JH
2190 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2191 }
9e353e3b
NIS
2192}
2193
93a8090d
NIS
2194SV *
2195PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2196{
2197 if (!arg)
a0714e2c 2198 return NULL;
24d147a6 2199#ifdef USE_ITHREADS
93a8090d 2200 if (param) {
a951d81d
BL
2201 arg = sv_dup(arg, param);
2202 SvREFCNT_inc_simple_void_NN(arg);
2203 return arg;
93a8090d
NIS
2204 }
2205 else {
2206 return newSVsv(arg);
2207 }
2208#else
1b6737cc 2209 PERL_UNUSED_ARG(param);
93a8090d
NIS
2210 return newSVsv(arg);
2211#endif
2212}
2213
2214PerlIO *
ecdeb87c 2215PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2216{
1b6737cc 2217 PerlIO * const nexto = PerlIONext(o);
04892f78 2218 if (PerlIOValid(nexto)) {
de009b76 2219 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
37725cdc
NIS
2220 if (tab && tab->Dup)
2221 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2222 else
2223 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS
2224 }
2225 if (f) {
dcda55fc 2226 PerlIO_funcs * const self = PerlIOBase(o)->tab;
a951d81d 2227 SV *arg = NULL;
93a8090d 2228 char buf[8];
316ebaf2 2229 assert(self);
fe5a182c 2230 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
cc6623a8
DM
2231 self ? self->name : "(Null)",
2232 (void*)f, (void*)o, (void*)param);
2233 if (self && self->Getarg)
210e727c 2234 arg = (*self->Getarg)(aTHX_ o, param, flags);
93a8090d 2235 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
df8c7dee 2236 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
f0720f70 2237 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
ef8d46e8 2238 SvREFCNT_dec(arg);
93a8090d
NIS
2239 }
2240 return f;
2241}
2242
27da23d5 2243/* PL_perlio_fd_refcnt[] is in intrpvar.h */
93a8090d 2244
8b84d7dd 2245/* Must be called with PL_perlio_mutex locked. */
22c96fc1
NC
2246static void
2247S_more_refcounted_fds(pTHX_ const int new_fd) {
7a89be66 2248 dVAR;
22c96fc1 2249 const int old_max = PL_perlio_fd_refcnt_size;
f4ae5be6 2250 const int new_max = 16 + (new_fd & ~15);
22c96fc1
NC
2251 int *new_array;
2252
2253 PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2254 old_max, new_fd, new_max);
2255
2256 if (new_fd < old_max) {
2257 return;
2258 }
2259
f4ae5be6
NC
2260 assert (new_max > new_fd);
2261
eae082a0
JH
2262 /* Use plain realloc() since we need this memory to be really
2263 * global and visible to all the interpreters and/or threads. */
2264 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
22c96fc1
NC
2265
2266 if (!new_array) {
8b84d7dd 2267#ifdef USE_ITHREADS
6cb8cb21 2268 MUTEX_UNLOCK(&PL_perlio_mutex);
22c96fc1 2269#endif
4cbe3a7d 2270 croak_no_mem();
22c96fc1
NC
2271 }
2272
2273 PL_perlio_fd_refcnt_size = new_max;
2274 PL_perlio_fd_refcnt = new_array;
2275
95b63a38
JH
2276 PerlIO_debug("Zeroing %p, %d\n",
2277 (void*)(new_array + old_max),
2278 new_max - old_max);
22c96fc1
NC
2279
2280 Zero(new_array + old_max, new_max - old_max, int);
2281}
2282
2283
93a8090d
NIS
2284void
2285PerlIO_init(pTHX)
2286{
8b84d7dd 2287 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
96a5add6 2288 PERL_UNUSED_CONTEXT;
93a8090d
NIS
2289}
2290
168d5872
NIS
2291void
2292PerlIOUnix_refcnt_inc(int fd)
2293{
27da23d5 2294 dTHX;
22c96fc1 2295 if (fd >= 0) {
97aff369 2296 dVAR;
22c96fc1 2297
8b84d7dd 2298#ifdef USE_ITHREADS
6cb8cb21 2299 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2300#endif
22c96fc1
NC
2301 if (fd >= PL_perlio_fd_refcnt_size)
2302 S_more_refcounted_fds(aTHX_ fd);
2303
27da23d5 2304 PL_perlio_fd_refcnt[fd]++;
8b84d7dd 2305 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2306 /* diag_listed_as: refcnt_inc: fd %d%s */
8b84d7dd
RGS
2307 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2308 fd, PL_perlio_fd_refcnt[fd]);
2309 }
2310 PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2311 fd, PL_perlio_fd_refcnt[fd]);
22c96fc1 2312
8b84d7dd 2313#ifdef USE_ITHREADS
6cb8cb21 2314 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2315#endif
8b84d7dd 2316 } else {
12605ff9 2317 /* diag_listed_as: refcnt_inc: fd %d%s */
8b84d7dd 2318 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
168d5872
NIS
2319 }
2320}
2321
168d5872
NIS
2322int
2323PerlIOUnix_refcnt_dec(int fd)
2324{
2325 int cnt = 0;
22c96fc1 2326 if (fd >= 0) {
97aff369 2327 dVAR;
8b84d7dd 2328#ifdef USE_ITHREADS
6cb8cb21 2329 MUTEX_LOCK(&PL_perlio_mutex);
168d5872 2330#endif
8b84d7dd 2331 if (fd >= PL_perlio_fd_refcnt_size) {
12605ff9 2332 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2333 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
8b84d7dd
RGS
2334 fd, PL_perlio_fd_refcnt_size);
2335 }
2336 if (PL_perlio_fd_refcnt[fd] <= 0) {
12605ff9 2337 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2338 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
8b84d7dd
RGS
2339 fd, PL_perlio_fd_refcnt[fd]);
2340 }
27da23d5 2341 cnt = --PL_perlio_fd_refcnt[fd];
8b84d7dd
RGS
2342 PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt);
2343#ifdef USE_ITHREADS
6cb8cb21 2344 MUTEX_UNLOCK(&PL_perlio_mutex);
168d5872 2345#endif
8b84d7dd 2346 } else {
12605ff9 2347 /* diag_listed_as: refcnt_dec: fd %d%s */
2bcd6579 2348 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
168d5872
NIS
2349 }
2350 return cnt;
2351}
2352
2e0cfa16
FC
2353int
2354PerlIOUnix_refcnt(int fd)
2355{
2356 dTHX;
2357 int cnt = 0;
2358 if (fd >= 0) {
2359 dVAR;
2360#ifdef USE_ITHREADS
2361 MUTEX_LOCK(&PL_perlio_mutex);
2362#endif
2363 if (fd >= PL_perlio_fd_refcnt_size) {
2364 /* diag_listed_as: refcnt: fd %d%s */
2365 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2366 fd, PL_perlio_fd_refcnt_size);
2367 }
2368 if (PL_perlio_fd_refcnt[fd] <= 0) {
2369 /* diag_listed_as: refcnt: fd %d%s */
2370 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2371 fd, PL_perlio_fd_refcnt[fd]);
2372 }
2373 cnt = PL_perlio_fd_refcnt[fd];
2374#ifdef USE_ITHREADS
2375 MUTEX_UNLOCK(&PL_perlio_mutex);
2376#endif
2377 } else {
2378 /* diag_listed_as: refcnt: fd %d%s */
2379 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2380 }
2381 return cnt;
2382}
2383
694c95cf
JH
2384void
2385PerlIO_cleanup(pTHX)
2386{
97aff369 2387 dVAR;
694c95cf
JH
2388 int i;
2389#ifdef USE_ITHREADS
a25429c6 2390 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
9f4bd222
NIS
2391#else
2392 PerlIO_debug("Cleanup layers\n");
694c95cf 2393#endif
e47547a8 2394
694c95cf
JH
2395 /* Raise STDIN..STDERR refcount so we don't close them */
2396 for (i=0; i < 3; i++)
2397 PerlIOUnix_refcnt_inc(i);
2398 PerlIO_cleantable(aTHX_ &PL_perlio);
2399 /* Restore STDIN..STDERR refcount */
2400 for (i=0; i < 3; i++)
2401 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS
2402
2403 if (PL_known_layers) {
2404 PerlIO_list_free(aTHX_ PL_known_layers);
2405 PL_known_layers = NULL;
2406 }
27da23d5 2407 if (PL_def_layerlist) {
9f4bd222
NIS
2408 PerlIO_list_free(aTHX_ PL_def_layerlist);
2409 PL_def_layerlist = NULL;
2410 }
6cb8cb21
RGS
2411}
2412
0934c9d9 2413void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
6cb8cb21 2414{
53d44271 2415 dVAR;
4f3da17a
DM
2416#if 0
2417/* XXX we can't rely on an interpreter being present at this late stage,
2418 XXX so we can't use a function like PerlLIO_write that relies on one
2419 being present (at least in win32) :-(.
2420 Disable for now.
2421*/
6cb8cb21
RGS
2422#ifdef DEBUGGING
2423 {
2424 /* By now all filehandles should have been closed, so any
2425 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2426 * errors. */
77db880c
JH
2427#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2428#define PERLIO_TEARDOWN_MESSAGE_FD 2
2429 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
6cb8cb21
RGS
2430 int i;
2431 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
77db880c
JH
2432 if (PL_perlio_fd_refcnt[i]) {
2433 const STRLEN len =
2434 my_snprintf(buf, sizeof(buf),
2435 "PerlIO_teardown: fd %d refcnt=%d\n",
2436 i, PL_perlio_fd_refcnt[i]);
2437 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2438 }
6cb8cb21
RGS
2439 }
2440 }
2441#endif
4f3da17a 2442#endif
eae082a0
JH
2443 /* Not bothering with PL_perlio_mutex since by now
2444 * all the interpreters are gone. */
1cd82952
RGS
2445 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2446 && PL_perlio_fd_refcnt) {
eae082a0 2447 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
432ce874
YO
2448 PL_perlio_fd_refcnt = NULL;
2449 PL_perlio_fd_refcnt_size = 0;
1cd82952 2450 }
694c95cf
JH
2451}
2452
9e353e3b 2453/*--------------------------------------------------------------------------------------*/
14a5cf38 2454/*
71200d45 2455 * Bottom-most level for UNIX-like case
14a5cf38 2456 */
9e353e3b 2457
14a5cf38 2458typedef struct {
22569500
NIS
2459 struct _PerlIO base; /* The generic part */
2460 int fd; /* UNIX like file descriptor */
2461 int oflags; /* open/fcntl flags */
9e353e3b
NIS
2462} PerlIOUnix;
2463
abf9167d
DM
2464static void
2465S_lockcnt_dec(pTHX_ const void* f)
2466{
2467 PerlIO_lockcnt((PerlIO*)f)--;
2468}
2469
2470
2471/* call the signal handler, and if that handler happens to clear
2472 * this handle, free what we can and return true */
2473
2474static bool
2475S_perlio_async_run(pTHX_ PerlIO* f) {
2476 ENTER;
2477 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2478 PerlIO_lockcnt(f)++;
2479 PERL_ASYNC_CHECK();
be48bbe8
CS
2480 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2481 LEAVE;
abf9167d 2482 return 0;
be48bbe8 2483 }
abf9167d
DM
2484 /* we've just run some perl-level code that could have done
2485 * anything, including closing the file or clearing this layer.
2486 * If so, free any lower layers that have already been
2487 * cleared, then return an error. */
2488 while (PerlIOValid(f) &&
2489 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2490 {
2491 const PerlIOl *l = *f;
2492 *f = l->next;
2493 Safefree(l);
2494 }
be48bbe8 2495 LEAVE;
abf9167d
DM
2496 return 1;
2497}
2498
6f9d8c32 2499int
9e353e3b 2500PerlIOUnix_oflags(const char *mode)
760ac839 2501{
14a5cf38 2502 int oflags = -1;
3b6c1aba 2503 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH
2504 mode++;
2505 switch (*mode) {
2506 case 'r':
2507 oflags = O_RDONLY;
2508 if (*++mode == '+') {
2509 oflags = O_RDWR;
2510 mode++;
2511 }
2512 break;
2513
2514 case 'w':
2515 oflags = O_CREAT | O_TRUNC;
2516 if (*++mode == '+') {
2517 oflags |= O_RDWR;
2518 mode++;
2519 }
2520 else
2521 oflags |= O_WRONLY;
2522 break;
2523
2524 case 'a':
2525 oflags = O_CREAT | O_APPEND;
2526 if (*++mode == '+') {
2527 oflags |= O_RDWR;
2528 mode++;
2529 }
2530 else
2531 oflags |= O_WRONLY;
2532 break;
2533 }
43e5477e
JH
2534
2535 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2536
2537 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2538 * of them in, and then bit-and-masking the other them away, won't
2539 * have much of an effect. */
2540 switch (*mode) {
2541 case 'b':
2542#if O_TEXT != O_BINARY
2543 oflags |= O_BINARY;
14a5cf38 2544 oflags &= ~O_TEXT;
43e5477e
JH
2545#endif
2546 mode++;
2547 break;
2548 case 't':
2549#if O_TEXT != O_BINARY
14a5cf38
JH
2550 oflags |= O_TEXT;
2551 oflags &= ~O_BINARY;
43e5477e
JH
2552#endif
2553 mode++;
2554 break;
2555 default:
2556# if O_BINARY != 0
2557 /* bit-or:ing with zero O_BINARY would be useless. */
93f31ee9
PG
2558 /*
2559 * If neither "t" nor "b" was specified, open the file
2560 * in O_BINARY mode.
43e5477e
JH
2561 *
2562 * Note that if something else than the zero byte was seen
2563 * here (e.g. bogus mode "rx"), just few lines later we will
2564 * set the errno and invalidate the flags.
93f31ee9
PG
2565 */
2566 oflags |= O_BINARY;
43e5477e
JH
2567# endif
2568 break;
93f31ee9 2569 }
14a5cf38 2570 if (*mode || oflags == -1) {
93189314 2571 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH
2572 oflags = -1;
2573 }
2574 return oflags;
9e353e3b
NIS
2575}
2576
2577IV
f62ce20a 2578PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2579{
96a5add6 2580 PERL_UNUSED_CONTEXT;
14a5cf38 2581 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS
2582}
2583
aa063c35
NIS
2584static void
2585PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
4b803d04 2586{
de009b76 2587 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
6caa5a9c 2588#if defined(WIN32)
aa063c35
NIS
2589 Stat_t st;
2590 if (PerlLIO_fstat(fd, &st) == 0) {
6caa5a9c 2591 if (!S_ISREG(st.st_mode)) {
aa063c35 2592 PerlIO_debug("%d is not regular file\n",fd);
6caa5a9c
NIS
2593 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2594 }
aa063c35
NIS
2595 else {
2596 PerlIO_debug("%d _is_ a regular file\n",fd);
2597 }
6caa5a9c
NIS
2598 }
2599#endif
aa063c35
NIS
2600 s->fd = fd;
2601 s->oflags = imode;
2602 PerlIOUnix_refcnt_inc(fd);
96a5add6 2603 PERL_UNUSED_CONTEXT;
aa063c35
NIS
2604}
2605
2606IV
2607PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2608{
2609 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2610 if (*PerlIONext(f)) {
4b069b44 2611 /* We never call down so do any pending stuff now */
03c0554d 2612 PerlIO_flush(PerlIONext(f));
14a5cf38 2613 /*
71200d45 2614 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2615 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2616 * Should the value on NULL mode be 0 or -1?
14a5cf38 2617 */
acbd16bf 2618 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
aa063c35 2619 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH
2620 }
2621 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
6caa5a9c 2622
14a5cf38 2623 return code;
4b803d04
NIS
2624}
2625
c2fcde81
JH
2626IV
2627PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2628{
de009b76 2629 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
0723351e 2630 Off_t new_loc;
96a5add6 2631 PERL_UNUSED_CONTEXT;
c2fcde81
JH
2632 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2633#ifdef ESPIPE
2634 SETERRNO(ESPIPE, LIB_INVARG);
2635#else
2636 SETERRNO(EINVAL, LIB_INVARG);
2637#endif
2638 return -1;
2639 }
0723351e
NC
2640 new_loc = PerlLIO_lseek(fd, offset, whence);
2641 if (new_loc == (Off_t) - 1)
dcda55fc 2642 return -1;
c2fcde81
JH
2643 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2644 return 0;
2645}
2646
9e353e3b 2647PerlIO *
14a5cf38
JH
2648PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2649 IV n, const char *mode, int fd, int imode,
2650 int perm, PerlIO *f, int narg, SV **args)
2651{
d9dac8cd 2652 if (PerlIOValid(f)) {
cc6623a8 2653 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2654 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH
2655 }
2656 if (narg > 0) {
3b6c1aba 2657 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH
2658 mode++;
2659 else {
2660 imode = PerlIOUnix_oflags(mode);
5e2ce0f3
CB
2661#ifdef VMS
2662 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2663#else
14a5cf38 2664 perm = 0666;
5e2ce0f3 2665#endif
14a5cf38
JH
2666 }
2667 if (imode != -1) {
41188aa0
TC
2668 STRLEN len;
2669 const char *path = SvPV_const(*args, len);
2670 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 2671 return NULL;
14a5cf38
JH
2672 fd = PerlLIO_open3(path, imode, perm);
2673 }
2674 }
2675 if (fd >= 0) {
3b6c1aba 2676 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH
2677 mode++;
2678 if (!f) {
2679 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS
2680 }
2681 if (!PerlIOValid(f)) {
a33cf58c 2682 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
0a20f69b 2683 PerlLIO_close(fd);
a33cf58c
NIS
2684 return NULL;
2685 }
d9dac8cd 2686 }
aa063c35 2687 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2688 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
c2fcde81
JH
2689 if (*mode == IoTYPE_APPEND)
2690 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH
2691 return f;
2692 }
2693 else {
2694 if (f) {
6f207bd3 2695 NOOP;
14a5cf38 2696 /*
71200d45 2697 * FIXME: pop layers ???
14a5cf38
JH
2698 */
2699 }
2700 return NULL;
2701 }
9e353e3b
NIS
2702}
2703
71200d45 2704PerlIO *
ecdeb87c 2705PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2706{
dcda55fc 2707 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2708 int fd = os->fd;
ecdeb87c
NIS
2709 if (flags & PERLIO_DUP_FD) {
2710 fd = PerlLIO_dup(fd);
2711 }
22c96fc1 2712 if (fd >= 0) {
ecdeb87c 2713 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS
2714 if (f) {
2715 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
aa063c35 2716 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS
2717 return f;
2718 }
0a20f69b 2719 PerlLIO_close(fd);
71200d45
NIS
2720 }
2721 return NULL;
2722}
2723
2724
9e353e3b 2725SSize_t
f62ce20a 2726PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2727{
97aff369 2728 dVAR;
abf9167d
DM
2729 int fd;
2730 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2731 return -1;
2732 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2733#ifdef PERLIO_STD_SPECIAL
2734 if (fd == 0)
2735 return PERLIO_STD_IN(fd, vbuf, count);
2736#endif
81428673 2737 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2738 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
263df5f1 2739 return 0;
1fd8f4ce 2740 }
14a5cf38 2741 while (1) {
b464bac0 2742 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2743 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2744 if (len < 0) {
2745 if (errno != EAGAIN) {
2746 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2747 }
2748 }
2749 else if (len == 0 && count != 0) {
14a5cf38 2750 PerlIOBase(f)->flags |= PERLIO_F_EOF;
ba85f2ea
NIS
2751 SETERRNO(0,0);
2752 }
14a5cf38
JH
2753 return len;
2754 }
abf9167d
DM
2755 /* EINTR */
2756 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2757 return -1;
14a5cf38 2758 }
b464bac0 2759 /*NOTREACHED*/
9e353e3b
NIS
2760}
2761
2762SSize_t
f62ce20a 2763PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2764{
97aff369 2765 dVAR;
abf9167d
DM
2766 int fd;
2767 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2768 return -1;
2769 fd = PerlIOSelf(f, PerlIOUnix)->fd;
27da23d5
JH
2770#ifdef PERLIO_STD_SPECIAL
2771 if (fd == 1 || fd == 2)
2772 return PERLIO_STD_OUT(fd, vbuf, count);
2773#endif
14a5cf38 2774 while (1) {
de009b76 2775 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2776 if (len >= 0 || errno != EINTR) {
ba85f2ea
NIS
2777 if (len < 0) {
2778 if (errno != EAGAIN) {
2779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2780 }
2781 }
14a5cf38
JH
2782 return len;
2783 }
abf9167d
DM
2784 /* EINTR */
2785 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2786 return -1;
06da4f11 2787 }
1b6737cc 2788 /*NOTREACHED*/
9e353e3b
NIS
2789}
2790
9e353e3b 2791Off_t
f62ce20a 2792PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2793{
96a5add6
AL
2794 PERL_UNUSED_CONTEXT;
2795
14a5cf38 2796 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS
2797}
2798
2556f95e
GF
2799
2800IV
2376d97d 2801PerlIOUnix_close(pTHX_ PerlIO *f)
2556f95e 2802{
97aff369 2803 dVAR;
de009b76 2804 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2805 int code = 0;
168d5872
NIS
2806 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2807 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS
2808 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2809 return 0;
22569500 2810 }
93a8090d
NIS
2811 }
2812 else {
93189314 2813 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS
2814 return -1;
2815 }
14a5cf38
JH
2816 while (PerlLIO_close(fd) != 0) {
2817 if (errno != EINTR) {
2818 code = -1;
2819 break;
2820 }
abf9167d
DM
2821 /* EINTR */
2822 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2823 return -1;
14a5cf38
JH
2824 }
2825 if (code == 0) {
2826 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2827 }
2828 return code;
9e353e3b
NIS
2829}
2830
27da23d5 2831PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2832 sizeof(PerlIO_funcs),
14a5cf38
JH
2833 "unix",
2834 sizeof(PerlIOUnix),
2835 PERLIO_K_RAW,
2836 PerlIOUnix_pushed,
2376d97d 2837 PerlIOBase_popped,
14a5cf38 2838 PerlIOUnix_open,
86e05cf2 2839 PerlIOBase_binmode, /* binmode */
14a5cf38
JH
2840 NULL,
2841 PerlIOUnix_fileno,
71200d45 2842 PerlIOUnix_dup,
14a5cf38
JH
2843 PerlIOUnix_read,
2844 PerlIOBase_unread,
2845 PerlIOUnix_write,
2846 PerlIOUnix_seek,
2847 PerlIOUnix_tell,
2848 PerlIOUnix_close,
22569500
NIS
2849 PerlIOBase_noop_ok, /* flush */
2850 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH
2851 PerlIOBase_eof,
2852 PerlIOBase_error,
2853 PerlIOBase_clearerr,
2854 PerlIOBase_setlinebuf,
22569500
NIS
2855 NULL, /* get_base */
2856 NULL, /* get_bufsiz */
2857 NULL, /* get_ptr */
2858 NULL, /* get_cnt */
2859 NULL, /* set_ptrcnt */
9e353e3b
NIS
2860};
2861
2862/*--------------------------------------------------------------------------------------*/
14a5cf38 2863/*
71200d45 2864 * stdio as a layer
14a5cf38 2865 */
9e353e3b 2866
313e59c8
NIS
2867#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2868/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2869 broken by the last second glibc 2.3 fix
2870 */
2871#define STDIO_BUFFER_WRITABLE
2872#endif
2873
2874
14a5cf38
JH
2875typedef struct {
2876 struct _PerlIO base;
22569500 2877 FILE *stdio; /* The stream */
9e353e3b
NIS
2878} PerlIOStdio;
2879
2880IV
f62ce20a 2881PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2882{
96a5add6
AL
2883 PERL_UNUSED_CONTEXT;
2884
c4420975
AL
2885 if (PerlIOValid(f)) {
2886 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2887 if (s)
2888 return PerlSIO_fileno(s);
439ba545
NIS
2889 }
2890 errno = EBADF;
2891 return -1;
9e353e3b
NIS
2892}
2893
766a733e 2894char *
14a5cf38
JH
2895PerlIOStdio_mode(const char *mode, char *tmode)
2896{
de009b76 2897 char * const ret = tmode;
a0625d38
SR
2898 if (mode) {
2899 while (*mode) {
2900 *tmode++ = *mode++;
2901 }
14a5cf38 2902 }
95005ad8 2903#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH
2904 *tmode++ = 'b';
2905#endif
14a5cf38
JH
2906 *tmode = '\0';
2907 return ret;
2908}
2909
4b803d04 2910IV
2dc2558e 2911PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2912{
1fd8f4ce
NIS
2913 PerlIO *n;
2914 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
46c461b5 2915 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS
2916 if (toptab == tab) {
2917 /* Top is already stdio - pop self (duplicate) and use original */
2918 PerlIO_pop(aTHX_ f);
2919 return 0;
2920 } else {
de009b76 2921 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS
2922 char tmode[8];
2923 FILE *stdio;
81428673 2924 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS
2925 mode = PerlIOStdio_mode(mode, tmode)))) {
2926 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2927 /* We never call down so do any pending stuff now */
2928 PerlIO_flush(PerlIONext(f));
2a600bb8 2929 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
81428673 2930 }
1fd8f4ce
NIS
2931 else {
2932 return -1;
2933 }
2934 }
14a5cf38 2935 }
2dc2558e 2936 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS
2937}
2938
22569500 2939
9e353e3b 2940PerlIO *
4b069b44 2941PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2942{
14a5cf38
JH
2943 dTHX;
2944 PerlIO *f = NULL;
2945 if (stdio) {
22569500 2946 PerlIOStdio *s;
375ed12a
JH
2947 int fd0 = fileno(stdio);
2948 if (fd0 < 0) {
2949 return NULL;
2950 }
4b069b44
NIS
2951 if (!mode || !*mode) {
2952 /* We need to probe to see how we can open the stream
2953 so start with read/write and then try write and read
2954 we dup() so that we can fclose without loosing the fd.
2955
2956 Note that the errno value set by a failing fdopen
2957 varies between stdio implementations.
2958 */
375ed12a
JH
2959 const int fd = PerlLIO_dup(fd0);
2960 FILE *f2;
2961 if (fd < 0) {
2962 return f;
2963 }
2964 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2965 if (!f2) {
a33cf58c 2966 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS
2967 }
2968 if (!f2) {
a33cf58c 2969 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS
2970 }
2971 if (!f2) {
2972 /* Don't seem to be able to open */
2973 PerlLIO_close(fd);
2974 return f;
2975 }
2976 fclose(f2);
22569500 2977 }
de092133 2978 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS
2979 s = PerlIOSelf(f, PerlIOStdio);
2980 s->stdio = stdio;
c586124f 2981 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 2982 }
14a5cf38
JH
2983 }
2984 return f;
9e353e3b
NIS
2985}
2986
2987PerlIO *
14a5cf38
JH
2988PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2989 IV n, const char *mode, int fd, int imode,
2990 int perm, PerlIO *f, int narg, SV **args)
2991{
2992 char tmode[8];
d9dac8cd 2993 if (PerlIOValid(f)) {
41188aa0
TC
2994 STRLEN len;
2995 const char * const path = SvPV_const(*args, len);
dcda55fc 2996 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015 2997 FILE *stdio;
41188aa0 2998 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 2999 return NULL;
1751d015 3000 PerlIOUnix_refcnt_dec(fileno(s->stdio));
de092133
JH
3001 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3002 s->stdio);
14a5cf38
JH
3003 if (!s->stdio)
3004 return NULL;
3005 s->stdio = stdio;
1751d015 3006 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH
3007 return f;
3008 }
3009 else {
3010 if (narg > 0) {
41188aa0
TC
3011 STRLEN len;
3012 const char * const path = SvPV_const(*args, len);
3013 if (!IS_SAFE_PATHNAME(path, len, "open"))
c8028aa6 3014 return NULL;
3b6c1aba 3015 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH
3016 mode++;
3017 fd = PerlLIO_open3(path, imode, perm);
3018 }
3019 else {
95005ad8
GH
3020 FILE *stdio;
3021 bool appended = FALSE;
3022#ifdef __CYGWIN__
3023 /* Cygwin wants its 'b' early. */
3024 appended = TRUE;
3025 mode = PerlIOStdio_mode(mode, tmode);
3026#endif
3027 stdio = PerlSIO_fopen(path, mode);
6f0313ac 3028 if (stdio) {
6f0313ac
JH
3029 if (!f) {
3030 f = PerlIO_allocate(aTHX);
3031 }
95005ad8
GH
3032 if (!appended)
3033 mode = PerlIOStdio_mode(mode, tmode);
3034 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3035 if (f) {
0f0f9e2b
JH
3036 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3037 PerlIOUnix_refcnt_inc(fileno(stdio));
3038 } else {
3039 PerlSIO_fclose(stdio);
6f0313ac
JH
3040 }
3041 return f;
3042 }
3043 else {
3044 return NULL;
3045 }
14a5cf38
JH
3046 }
3047 }
3048 if (fd >= 0) {
3049 FILE *stdio = NULL;
3050 int init = 0;
3b6c1aba 3051 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH
3052 init = 1;
3053 mode++;
3054 }
3055 if (init) {
3056 switch (fd) {
3057 case 0:
3058 stdio = PerlSIO_stdin;
3059 break;
3060 case 1:
3061 stdio = PerlSIO_stdout;
3062 break;
3063 case 2:
3064 stdio = PerlSIO_stderr;
3065 break;
3066 }
3067 }
3068 else {
3069 stdio = PerlSIO_fdopen(fd, mode =
3070 PerlIOStdio_mode(mode, tmode));
3071 }
3072 if (stdio) {
d9dac8cd
NIS
3073 if (!f) {
3074 f = PerlIO_allocate(aTHX);
3075 }
a33cf58c 3076 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
1a159fba
JH
3077 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3078 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 3079 }
14a5cf38
JH
3080 return f;
3081 }
0a20f69b 3082 PerlLIO_close(fd);
14a5cf38
JH
3083 }
3084 }
ee518936 3085 return NULL;
9e353e3b
NIS
3086}
3087
1751d015 3088PerlIO *
ecdeb87c 3089PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS
3090{
3091 /* This assumes no layers underneath - which is what
3092 happens, but is not how I remember it. NI-S 2001/10/16
3093 */
ecdeb87c 3094 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 3095 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
de009b76 3096 const int fd = fileno(stdio);
9217ff3f 3097 char mode[8];
ecdeb87c 3098 if (flags & PERLIO_DUP_FD) {
de009b76 3099 const int dfd = PerlLIO_dup(fileno(stdio));
9217ff3f
NIS
3100 if (dfd >= 0) {
3101 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3102 goto set_this;
ecdeb87c
NIS
3103 }
3104 else {
6f207bd3 3105 NOOP;
ecdeb87c
NIS
3106 /* FIXME: To avoid messy error recovery if dup fails
3107 re-use the existing stdio as though flag was not set
3108 */
3109 }
3110 }
9217ff3f
NIS
3111 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3112 set_this:
694c95cf 3113 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
40596bc5
SP
3114 if(stdio) {
3115 PerlIOUnix_refcnt_inc(fileno(stdio));
3116 }
1751d015
NIS
3117 }
3118 return f;
3119}
3120
0d7a5398
NIS
3121static int
3122PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3123{
96a5add6
AL
3124 PERL_UNUSED_CONTEXT;
3125
0d7a5398 3126 /* XXX this could use PerlIO_canset_fileno() and
37725cdc 3127 * PerlIO_set_fileno() support from Configure
0d7a5398 3128 */
ef8eacb8
AT
3129# if defined(__UCLIBC__)
3130 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3131 f->__filedes = -1;
3132 return 1;
3133# elif defined(__GLIBC__)
0d7a5398 3134 /* There may be a better way for GLIBC:
37725cdc 3135 - libio.h defines a flag to not close() on cleanup
0d7a5398
NIS
3136 */
3137 f->_fileno = -1;
3138 return 1;
bdea967c 3139# elif defined(__sun)
f5992bc4 3140 PERL_UNUSED_ARG(f);
cfedb851 3141 return 0;
0d7a5398
NIS
3142# elif defined(__hpux)
3143 f->__fileH = 0xff;
3144 f->__fileL = 0xff;
3145 return 1;
9837d373 3146 /* Next one ->_file seems to be a reasonable fallback, i.e. if
37725cdc 3147 your platform does not have special entry try this one.
9837d373
NIS
3148 [For OSF only have confirmation for Tru64 (alpha)
3149 but assume other OSFs will be similar.]
37725cdc 3150 */
9837d373 3151# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
0d7a5398
NIS
3152 f->_file = -1;
3153 return 1;
3154# elif defined(__FreeBSD__)
3155 /* There may be a better way on FreeBSD:
37725cdc
NIS
3156 - we could insert a dummy func in the _close function entry
3157 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3158 */
3159 f->_file = -1;
0c49ea6a
SU
3160 return 1;
3161# elif defined(__OpenBSD__)
3162 /* There may be a better way on OpenBSD:
3163 - we could insert a dummy func in the _close function entry
3164 f->_close = (int (*)(void *)) dummy_close;
3165 */
3166 f->_file = -1;
0d7a5398 3167 return 1;
59ad941d
IZ
3168# elif defined(__EMX__)
3169 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3170 f->_handle = -1;
3171 return 1;
0d7a5398
NIS
3172# elif defined(__CYGWIN__)
3173 /* There may be a better way on CYGWIN:
37725cdc
NIS
3174 - we could insert a dummy func in the _close function entry
3175 f->_close = (int (*)(void *)) dummy_close;
0d7a5398
NIS
3176 */
3177 f->_file = -1;
3178 return 1;
3179# elif defined(WIN32)
378eeda7 3180# if defined(UNDER_CE)
b475b3e6
JH
3181 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3182 structure at all
3183 */
0d7a5398
NIS
3184# else
3185 f->_file = -1;
3186# endif
3187 return 1;
3188# else
3189#if 0
37725cdc 3190 /* Sarathy's code did this - we fall back to a dup/dup2 hack
0d7a5398 3191 (which isn't thread safe) instead
37725cdc 3192 */
0d7a5398
NIS
3193# error "Don't know how to set FILE.fileno on your platform"
3194#endif
8772537c 3195 PERL_UNUSED_ARG(f);
0d7a5398
NIS
3196 return 0;
3197# endif
3198}
3199
1751d015 3200IV
f62ce20a 3201PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 3202{
c4420975 3203 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS
3204 if (!stdio) {
3205 errno = EBADF;
3206 return -1;
3207 }
9217ff3f 3208 else {
de009b76 3209 const int fd = fileno(stdio);
0d7a5398 3210 int invalidate = 0;
bbfd922f 3211 IV result = 0;
1d791a44 3212 int dupfd = -1;
4ee39169 3213 dSAVEDERRNO;
a2e578da
MHM
3214#ifdef USE_ITHREADS
3215 dVAR;
3216#endif
0d7a5398 3217#ifdef SOCKS5_VERSION_NAME
37725cdc
NIS
3218 /* Socks lib overrides close() but stdio isn't linked to
3219 that library (though we are) - so we must call close()
3220 on sockets on stdio's behalf.
3221 */
0d7a5398
NIS
3222 int optval;
3223 Sock_size_t optlen = sizeof(int);
6b4ce6c8 3224 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
37725cdc 3225 invalidate = 1;
0d7a5398 3226#endif
d8723f43
NC
3227 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3228 that a subsequent fileno() on it returns -1. Don't want to croak()
3229 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3230 trying to close an already closed handle which somehow it still has
3231 a reference to. (via.xs, I'm looking at you). */
3232 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3233 /* File descriptor still in use */
0d7a5398 3234 invalidate = 1;
d8723f43 3235 }
0d7a5398 3236 if (invalidate) {
6b4ce6c8
AL
3237 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3238 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3239 return 0;
3240 if (stdio == stdout || stdio == stderr)
3241 return PerlIO_flush(f);
37725cdc
NIS
3242 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3243 Use Sarathy's trick from maint-5.6 to invalidate the
3244 fileno slot of the FILE *
3245 */
bbfd922f 3246 result = PerlIO_flush(f);
4ee39169 3247 SAVE_ERRNO;
6b4ce6c8 3248 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
711e8db2 3249 if (!invalidate) {
9bab90c0
NC
3250#ifdef USE_ITHREADS
3251 MUTEX_LOCK(&PL_perlio_mutex);
5ca745d2
NC
3252 /* Right. We need a mutex here because for a brief while we
3253 will have the situation that fd is actually closed. Hence if
3254 a second thread were to get into this block, its dup() would
3255 likely return our fd as its dupfd. (after all, it is closed)
9bab90c0
NC
3256 Then if we get to the dup2() first, we blat the fd back
3257 (messing up its temporary as a side effect) only for it to
3258 then close its dupfd (== our fd) in its close(dupfd) */
3259
3260 /* There is, of course, a race condition, that any other thread
3261 trying to input/output/whatever on this fd will be stuffed
5ca745d2
NC
3262 for the duration of this little manoeuvrer. Perhaps we
3263 should hold an IO mutex for the duration of every IO
3264 operation if we know that invalidate doesn't work on this
3265 platform, but that would suck, and could kill performance.
9bab90c0
NC
3266
3267 Except that correctness trumps speed.
3268 Advice from klortho #11912. */
3269#endif
6b4ce6c8 3270 dupfd = PerlLIO_dup(fd);
711e8db2 3271#ifdef USE_ITHREADS
9bab90c0
NC
3272 if (dupfd < 0) {
3273 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2
NC
3274 /* Oh cXap. This isn't going to go well. Not sure if we can
3275 recover from here, or if closing this particular FILE *
3276 is a good idea now. */
3277 }
3278#endif
3279 }
94ccb807
JH
3280 } else {
3281 SAVE_ERRNO; /* This is here only to silence compiler warnings */
37725cdc 3282 }
0d7a5398 3283 result = PerlSIO_fclose(stdio);
37725cdc
NIS
3284 /* We treat error from stdio as success if we invalidated
3285 errno may NOT be expected EBADF
e8529473
NIS
3286 */
3287 if (invalidate && result != 0) {
4ee39169 3288 RESTORE_ERRNO;
0d7a5398 3289 result = 0;
37725cdc 3290 }
6b4ce6c8
AL
3291#ifdef SOCKS5_VERSION_NAME
3292 /* in SOCKS' case, let close() determine return value */
3293 result = close(fd);
3294#endif
1d791a44 3295 if (dupfd >= 0) {
0d7a5398 3296 PerlLIO_dup2(dupfd,fd);
9bab90c0 3297 PerlLIO_close(dupfd);
711e8db2 3298#ifdef USE_ITHREADS
9bab90c0 3299 MUTEX_UNLOCK(&PL_perlio_mutex);
711e8db2 3300#endif
9217ff3f
NIS
3301 }
3302 return result;
37725cdc 3303 }
1751d015
NIS
3304}
3305
9e353e3b 3306SSize_t
f62ce20a 3307PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3308{
97aff369 3309 dVAR;
abf9167d 3310 FILE * s;
14a5cf38 3311 SSize_t got = 0;
abf9167d
DM
3312 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3313 return -1;
3314 s = PerlIOSelf(f, PerlIOStdio)->stdio;
4d948241
NIS
3315 for (;;) {
3316 if (count == 1) {
3317 STDCHAR *buf = (STDCHAR *) vbuf;
3318 /*
3319 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3320 * stdio does not do that for fread()
3321 */
de009b76 3322 const int ch = PerlSIO_fgetc(s);
4d948241
NIS
3323 if (ch != EOF) {
3324 *buf = ch;
3325 got = 1;
3326 }
14a5cf38 3327 }
4d948241
NIS
3328 else
3329 got = PerlSIO_fread(vbuf, 1, count, s);
b1d8b47a
CS
3330 if (got == 0 && PerlSIO_ferror(s))
3331 got = -1;
42a7a32f 3332 if (got >= 0 || errno != EINTR)
4d948241 3333 break;
abf9167d
DM
3334 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3335 return -1;
42a7a32f 3336 SETERRNO(0,0); /* just in case */
14a5cf38 3337 }
14a5cf38 3338 return got;
9e353e3b
NIS
3339}
3340
3341SSize_t
f62ce20a 3342PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3343{
14a5cf38 3344 SSize_t unread = 0;
c4420975 3345 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3346
313e59c8 3347#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3348 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS
3349 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3350 STDCHAR *base = PerlIO_get_base(f);
3351 SSize_t cnt = PerlIO_get_cnt(f);
3352 STDCHAR *ptr = PerlIO_get_ptr(f);
3353 SSize_t avail = ptr - base;
3354 if (avail > 0) {
3355 if (avail > count) {
3356 avail = count;
3357 }
3358 ptr -= avail;
3359 Move(buf-avail,ptr,avail,STDCHAR);
3360 count -= avail;
3361 unread += avail;
3362 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS
3363 if (PerlSIO_feof(s) && unread >= 0)
3364 PerlSIO_clearerr(s);
3365 }
3366 }
313e59c8
NIS
3367 else
3368#endif
3369 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS
3370 /* We can get pointer to buffer but not its base
3371 Do ungetc() but check chars are ending up in the
3372 buffer
3373 */
3374 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3375 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3376 while (count > 0) {
de009b76 3377 const int ch = *--buf & 0xFF;
9f7cd136
NIS
3378 if (ungetc(ch,s) != ch) {
3379 /* ungetc did not work */
3380 break;
3381 }
3382 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3383 /* Did not change pointer as expected */
375ed12a
JH
3384 if (fgetc(s) != EOF) /* get char back again */
3385 break;
9f7cd136
NIS
3386 }
3387 /* It worked ! */
3388 count--;
3389 unread++;
93679785
NIS
3390 }
3391 }
3392
3393 if (count > 0) {
3394 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH
3395 }
3396 return unread;
9e353e3b
NIS
3397}
3398
3399SSize_t
f62ce20a 3400PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3401{
97aff369 3402 dVAR;
4d948241 3403 SSize_t got;
abf9167d
DM
3404 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3405 return -1;
4d948241
NIS
3406 for (;;) {
3407 got = PerlSIO_fwrite(vbuf, 1, count,
3408 PerlIOSelf(f, PerlIOStdio)->stdio);
42a7a32f 3409 if (got >= 0 || errno != EINTR)
4d948241 3410 break;
abf9167d
DM
3411 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3412 return -1;
42a7a32f 3413 SETERRNO(0,0); /* just in case */
4d948241
NIS
3414 }
3415 return got;
9e353e3b
NIS
3416}
3417
94a175e1 3418IV
f62ce20a 3419PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3420{
c4420975 3421 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3422 PERL_UNUSED_CONTEXT;
3423
94a175e1 3424 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS
3425}
3426
3427Off_t
f62ce20a 3428PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3429{
c4420975 3430 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3431 PERL_UNUSED_CONTEXT;
3432
94a175e1 3433 return PerlSIO_ftell(stdio);
9e353e3b
NIS
3434}
3435
3436IV
f62ce20a 3437PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3438{
c4420975 3439 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
96a5add6
AL
3440 PERL_UNUSED_CONTEXT;
3441
14a5cf38
JH
3442 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3443 return PerlSIO_fflush(stdio);
3444 }
3445 else {
6f207bd3 3446 NOOP;
88b61e10 3447#if 0
14a5cf38
JH
3448 /*
3449 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3450 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3451 * design is to do _this_ but not have layer above flush this
71200d45 3452 * layer read-to-read
14a5cf38
JH
3453 */
3454 /*
71200d45 3455 * Not writeable - sync by attempting a seek
14a5cf38 3456 */
4ee39169 3457 dSAVE_ERRNO;
14a5cf38 3458 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
4ee39169 3459 RESTORE_ERRNO;
88b61e10 3460#endif
14a5cf38
JH
3461 }
3462 return 0;
9e353e3b
NIS
3463}
3464
3465IV
f62ce20a 3466PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3467{
96a5add6
AL
3468 PERL_UNUSED_CONTEXT;
3469
14a5cf38 3470 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3471}
3472
3473IV
f62ce20a 3474PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3475{
96a5add6
AL
3476 PERL_UNUSED_CONTEXT;
3477
263df5f1 3478 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3479}
3480
3481void
f62ce20a 3482PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3483{
96a5add6
AL
3484 PERL_UNUSED_CONTEXT;
3485
14a5cf38 3486 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS
3487}
3488
3489void
f62ce20a 3490PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3491{
96a5add6
AL
3492 PERL_UNUSED_CONTEXT;
3493
9e353e3b 3494#ifdef HAS_SETLINEBUF
14a5cf38 3495 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3496#else
bd61b366 3497 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS
3498#endif
3499}
3500
3501#ifdef FILE_base
3502STDCHAR *
f62ce20a 3503PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3504{
c4420975 3505 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3506 return (STDCHAR*)PerlSIO_get_base(stdio);