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