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