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