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