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