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