This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate:
[perl5.git] / perlio.c
CommitLineData
14a5cf38 1/*
4cd59068 2 * perlio.c Copyright (c) 1996-2006, 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
40d34c0d
SB		 12/* This file contains the functions needed to implement PerlIO, which
13 * is Perl's private replacement for the C stdio library. This is used
14 * by default unless you compile with -Uuseperlio or run with
15 * PERLIO=:stdio (but don't do this unless you know what you're doing)
16 */
17
d31a8517 18/*
71200d45 19 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
14a5cf38 20 * at the dispatch tables, even when we do not need it for other reasons.
71200d45 21 * Invent a dSYS macro to abstract this out
14a5cf38 22 */
7bcba3d4
NIS		 23#ifdef PERL_IMPLICIT_SYS
24#define dSYS dTHX
25#else
26#define dSYS dNOOP
27#endif
28
760ac839 29#define VOIDUSED 1
12ae5dfc
JH		 30#ifdef PERL_MICRO
31# include "uconfig.h"
32#else
33# include "config.h"
34#endif
760ac839 35
6f9d8c32 36#define PERLIO_NOT_STDIO 0
760ac839 37#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
14a5cf38 38/*
71200d45 39 * #define PerlIO FILE
14a5cf38 40 */
760ac839
LW		 41#endif
42/*
6f9d8c32 43 * This file provides those parts of PerlIO abstraction
88b61e10 44 * which are not #defined in perlio.h.
6f9d8c32 45 * Which these are depends on various Configure #ifdef's
760ac839
LW		 46 */
47
48#include "EXTERN.h"
864dbfa3 49#define PERL_IN_PERLIO_C
760ac839
LW		 50#include "perl.h"
51
32af7c23
CL		 52#ifdef PERL_IMPLICIT_CONTEXT
53#undef dSYS
54#define dSYS dTHX
55#endif
56
0c4f7ff0
NIS		 57#include "XSUB.h"
58
cf7b4f3b
JH		 59#define PERLIO_MAX_REFCOUNTABLE_FD 2048
60
f0798ba3
OS		 61#ifdef __Lynx__
62/* Missing proto on LynxOS */
63int mkstemp(char*);
64#endif
65
0710cc63
JH		 66/* Call the callback or PerlIOBase, and return failure. */
67#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
68 if (PerlIOValid(f)) { \
217ef1d7 69 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
0710cc63
JH		 70 if (tab && tab->callback) \
71 return (*tab->callback) args; \
72 else \
73 return PerlIOBase_ ## base args; \
74 } \
75 else \
76 SETERRNO(EBADF, SS_IVCHAN); \
77 return failure
78
79/* Call the callback or fail, and return failure. */
80#define Perl_PerlIO_or_fail(f, callback, failure, args) \
81 if (PerlIOValid(f)) { \
217ef1d7 82 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
0710cc63
JH		 83 if (tab && tab->callback) \
84 return (*tab->callback) args; \
85 SETERRNO(EINVAL, LIB_INVARG); \
86 } \
87 else \
88 SETERRNO(EBADF, SS_IVCHAN); \
89 return failure
90
91/* Call the callback or PerlIOBase, and be void. */
92#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
93 if (PerlIOValid(f)) { \
217ef1d7 94 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
0710cc63
JH		 95 if (tab && tab->callback) \
96 (*tab->callback) args; \
97 else \
98 PerlIOBase_ ## base args; \
99 } \
100 else \
101 SETERRNO(EBADF, SS_IVCHAN)
102
103/* Call the callback or fail, and be void. */
104#define Perl_PerlIO_or_fail_void(f, callback, args) \
105 if (PerlIOValid(f)) { \
217ef1d7 106 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
0710cc63
JH		 107 if (tab && tab->callback) \
108 (*tab->callback) args; \
109 else \
110 SETERRNO(EINVAL, LIB_INVARG); \
111 } \
112 else \
113 SETERRNO(EBADF, SS_IVCHAN)
114
e2052ea3
NC		 115#if defined(__osf__) && _XOPEN_SOURCE < 500
116extern int fseeko(FILE *, off_t, int);
117extern off_t ftello(FILE *);
118#endif
119
5082993f 120#ifndef USE_SFIO
0bfdb59a
NC		 121
122EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
123
5082993f
NC		 124int
125perlsio_binmode(FILE *fp, int iotype, int mode)
126{
127 /*
128 * This used to be contents of do_binmode in doio.c
129 */
130#ifdef DOSISH
131# if defined(atarist) || defined(__MINT__)
132 if (!fflush(fp)) {
133 if (mode & O_BINARY)
134 ((FILE *) fp)->_flag |= _IOBIN;
135 else
136 ((FILE *) fp)->_flag &= ~_IOBIN;
137 return 1;
138 }
139 return 0;
140# else
141 dTHX;
142#ifdef NETWARE
143 if (PerlLIO_setmode(fp, mode) != -1) {
144#else
145 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
146#endif
147# if defined(WIN32) && defined(__BORLANDC__)
148 /*
149 * The translation mode of the stream is maintained independent
150of
151 * the translation mode of the fd in the Borland RTL (heavy
152 * digging through their runtime sources reveal). User has to
153set
154 * the mode explicitly for the stream (though they don't
155document
156 * this anywhere). GSAR 97-5-24
157 */
158 fseek(fp, 0L, 0);
159 if (mode & O_BINARY)
160 fp->flags |= _F_BIN;
161 else
162 fp->flags &= ~_F_BIN;
163# endif
164 return 1;
165 }
166 else
167 return 0;
168# endif
169#else
170# if defined(USEMYBINMODE)
171 dTHX;
172 if (my_binmode(fp, iotype, mode) != FALSE)
173 return 1;
174 else
175 return 0;
176# else
177 PERL_UNUSED_ARG(fp);
178 PERL_UNUSED_ARG(iotype);
179 PERL_UNUSED_ARG(mode);
180 return 1;
181# endif
182#endif
183}
184#endif /* sfio */
185
06c7082d 186#ifndef O_ACCMODE
22569500 187#define O_ACCMODE 3 /* Assume traditional implementation */
06c7082d
NIS		 188#endif
189
190int
191PerlIO_intmode2str(int rawmode, char *mode, int *writing)
192{
f1c3982b 193 const int result = rawmode & O_ACCMODE;
06c7082d
NIS		 194 int ix = 0;
195 int ptype;
196 switch (result) {
197 case O_RDONLY:
198 ptype = IoTYPE_RDONLY;
199 break;
200 case O_WRONLY:
201 ptype = IoTYPE_WRONLY;
202 break;
203 case O_RDWR:
204 default:
205 ptype = IoTYPE_RDWR;
206 break;
207 }
208 if (writing)
209 *writing = (result != O_RDONLY);
210
211 if (result == O_RDONLY) {
212 mode[ix++] = 'r';
213 }
214#ifdef O_APPEND
215 else if (rawmode & O_APPEND) {
216 mode[ix++] = 'a';
217 if (result != O_WRONLY)
218 mode[ix++] = '+';
219 }
220#endif
221 else {
222 if (result == O_WRONLY)
223 mode[ix++] = 'w';
224 else {
225 mode[ix++] = 'r';
226 mode[ix++] = '+';
227 }
228 }
229 if (rawmode & O_BINARY)
230 mode[ix++] = 'b';
231 mode[ix] = '\0';
232 return ptype;
233}
234
eb73beca
NIS		 235#ifndef PERLIO_LAYERS
236int
237PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
238{
6874a2de
NIS		 239 if (!names || !*names
240 || strEQ(names, ":crlf")
241 || strEQ(names, ":raw")
242 || strEQ(names, ":bytes")
243 ) {
14a5cf38
JH		 244 return 0;
245 }
246 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
247 /*
71200d45 248 * NOTREACHED
14a5cf38
JH		 249 */
250 return -1;
eb73beca
NIS		 251}
252
13621cfb
NIS		 253void
254PerlIO_destruct(pTHX)
255{
256}
257
f5b9d040
NIS		 258int
259PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
260{
92bff44d 261#ifdef USE_SFIO
4f1e9d25
AL		 262 PERL_UNUSED_ARG(iotype);
263 PERL_UNUSED_ARG(mode);
264 PERL_UNUSED_ARG(names);
14a5cf38 265 return 1;
92bff44d 266#else
14a5cf38 267 return perlsio_binmode(fp, iotype, mode);
92bff44d 268#endif
f5b9d040 269}
60382766 270
e0fa5af2 271PerlIO *
ecdeb87c 272PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
e0fa5af2 273{
cf7b4f3b 274#if defined(PERL_MICRO) || defined(SYMBIAN)
0553478e
NIS		 275 return NULL;
276#else
277#ifdef PERL_IMPLICIT_SYS
22569500 278 return PerlSIO_fdupopen(f);
0553478e 279#else
30753f56
NIS		 280#ifdef WIN32
281 return win32_fdupopen(f);
282#else
e0fa5af2 283 if (f) {
547d29e4 284 const int fd = PerlLIO_dup(PerlIO_fileno(f));
e0fa5af2 285 if (fd >= 0) {
06c7082d 286 char mode[8];
a5936e02 287#ifdef DJGPP
81ec6716
AL		 288 const int omode = djgpp_get_stream_mode(f);
289#else
290 const int omode = fcntl(fd, F_GETFL);
a5936e02 291#endif
06c7082d 292 PerlIO_intmode2str(omode,mode,NULL);
e0fa5af2 293 /* the r+ is a hack */
06c7082d 294 return PerlIO_fdopen(fd, mode);
e0fa5af2
NIS		 295 }
296 return NULL;
297 }
298 else {
93189314 299 SETERRNO(EBADF, SS_IVCHAN);
e0fa5af2 300 }
7114a2d2 301#endif
e0fa5af2 302 return NULL;
0553478e 303#endif
30753f56 304#endif
e0fa5af2
NIS		 305}
306
307
14a5cf38 308/*
71200d45 309 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
14a5cf38 310 */
ee518936
NIS		 311
312PerlIO *
14a5cf38
JH		 313PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
314 int imode, int perm, PerlIO *old, int narg, SV **args)
315{
7cf31beb
NIS		 316 if (narg) {
317 if (narg > 1) {
3b8752bb 318 Perl_croak(aTHX_ "More than one argument to open");
7cf31beb 319 }
14a5cf38
JH		 320 if (*args == &PL_sv_undef)
321 return PerlIO_tmpfile();
322 else {
c06c673c 323 const char *name = SvPV_nolen_const(*args);
f3c7dfbe 324 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH		 325 fd = PerlLIO_open3(name, imode, perm);
326 if (fd >= 0)
f1c3982b 327 return PerlIO_fdopen(fd, mode + 1);
14a5cf38
JH		 328 }
329 else if (old) {
330 return PerlIO_reopen(name, mode, old);
331 }
332 else {
333 return PerlIO_open(name, mode);
334 }
335 }
336 }
337 else {
338 return PerlIO_fdopen(fd, (char *) mode);
339 }
340 return NULL;
ee518936
NIS		 341}
342
0c4f7ff0
NIS		 343XS(XS_PerlIO__Layer__find)
344{
14a5cf38
JH		 345 dXSARGS;
346 if (items < 2)
347 Perl_croak(aTHX_ "Usage class->find(name[,load])");
348 else {
81ec6716 349 const char * const name = SvPV_nolen_const(ST(1));
14a5cf38
JH		 350 ST(0) = (strEQ(name, "crlf")
351 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
352 XSRETURN(1);
353 }
0c4f7ff0
NIS		 354}
355
356
357void
358Perl_boot_core_PerlIO(pTHX)
359{
14a5cf38 360 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
0c4f7ff0
NIS		 361}
362
ac27b0f5
NIS		 363#endif
364
32e30700 365
6f9d8c32 366#ifdef PERLIO_IS_STDIO
760ac839
LW		 367
368void
e8632036 369PerlIO_init(pTHX)
760ac839 370{
1e7ed80e 371 PERL_UNUSED_CONTEXT;
14a5cf38
JH		 372 /*
373 * Does nothing (yet) except force this file to be included in perl
71200d45 374 * binary. That allows this file to force inclusion of other functions
14a5cf38 375 * that may be required by loadable extensions e.g. for
71200d45 376 * FileHandle::tmpfile
14a5cf38 377 */
760ac839
LW		 378}
379
33dcbb9a 380#undef PerlIO_tmpfile
381PerlIO *
8ac85365 382PerlIO_tmpfile(void)
33dcbb9a 383{
14a5cf38 384 return tmpfile();
33dcbb9a 385}
386
22569500 387#else /* PERLIO_IS_STDIO */
760ac839
LW		 388
389#ifdef USE_SFIO
390
391#undef HAS_FSETPOS
392#undef HAS_FGETPOS
393
14a5cf38
JH		 394/*
395 * This section is just to make sure these functions get pulled in from
71200d45 396 * libsfio.a
14a5cf38 397 */
760ac839
LW		 398
399#undef PerlIO_tmpfile
400PerlIO *
c78749f2 401PerlIO_tmpfile(void)
760ac839 402{
14a5cf38 403 return sftmp(0);
760ac839
LW		 404}
405
406void
e8632036 407PerlIO_init(pTHX)
760ac839 408{
1e7ed80e 409 PERL_UNUSED_CONTEXT;
14a5cf38
JH		 410 /*
411 * Force this file to be included in perl binary. Which allows this
412 * file to force inclusion of other functions that may be required by
71200d45 413 * loadable extensions e.g. for FileHandle::tmpfile
14a5cf38 414 */
760ac839 415
14a5cf38 416 /*
71200d45 417 * Hack sfio does its own 'autoflush' on stdout in common cases. Flush
14a5cf38 418 * results in a lot of lseek()s to regular files and lot of small
71200d45 419 * writes to pipes.
14a5cf38
JH		 420 */
421 sfset(sfstdout, SF_SHARE, 0);
760ac839
LW		 422}
423
b9d6bf13 424/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */
92bff44d 425PerlIO *
4b069b44 426PerlIO_importFILE(FILE *stdio, const char *mode)
92bff44d 427{
f1c3982b 428 const int fd = fileno(stdio);
4b069b44 429 if (!mode || !*mode) {
81428673 430 mode = "r+";
4b069b44
NIS		 431 }
432 return PerlIO_fdopen(fd, mode);
92bff44d
NIS		 433}
434
435FILE *
436PerlIO_findFILE(PerlIO *pio)
437{
f1c3982b
NC		 438 const int fd = PerlIO_fileno(pio);
439 FILE * const f = fdopen(fd, "r+");
14a5cf38
JH		 440 PerlIO_flush(pio);
441 if (!f && errno == EINVAL)
442 f = fdopen(fd, "w");
443 if (!f && errno == EINVAL)
444 f = fdopen(fd, "r");
445 return f;
92bff44d
NIS		 446}
447
448
22569500 449#else /* USE_SFIO */
6f9d8c32 450/*======================================================================================*/
14a5cf38 451/*
71200d45 452 * Implement all the PerlIO interface ourselves.
9e353e3b 453 */
760ac839 454
76ced9ad
NIS		 455#include "perliol.h"
456
14a5cf38
JH		 457/*
458 * We _MUST_ have <unistd.h> if we are using lseek() and may have large
71200d45 459 * files
14a5cf38 460 */
02f66e2f
NIS		 461#ifdef I_UNISTD
462#include <unistd.h>
463#endif
06da4f11
NIS		 464#ifdef HAS_MMAP
465#include <sys/mman.h>
466#endif
467
6f9d8c32 468void
14a5cf38
JH		 469PerlIO_debug(const char *fmt, ...)
470{
471 static int dbg = 0;
472 va_list ap;
473 dSYS;
474 va_start(ap, fmt);
4ba2a8a0
JH		 475 if (!dbg) {
476 if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) {
477 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
478 if (s && *s)
479 dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666);
480 else
481 dbg = -1;
482 } else {
483 /* tainting or set*id, so ignore the environment, and ensure we
484 skip these tests next time through. */
14a5cf38 485 dbg = -1;
4ba2a8a0 486 }
14a5cf38
JH		 487 }
488 if (dbg > 0) {
489 dTHX;
70ace5da 490#ifdef USE_ITHREADS
81ec6716 491 const char * const s = CopFILE(PL_curcop);
70ace5da
NIS		 492 /* Use fixed buffer as sv_catpvf etc. needs SVs */
493 char buffer[1024];
b25a8111
NC		 494 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
495 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
496 PerlLIO_write(dbg, buffer, len1 + len2);
70ace5da 497#else
81ec6716
AL		 498 const char *s = CopFILE(PL_curcop);
499 STRLEN len;
d7559646 500 SV * const sv = newSVpvs("");
81ec6716 501 Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s ? s : "(none)",
14a5cf38
JH		 502 (IV) CopLINE(PL_curcop));
503 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
504
23c2bb70 505 s = SvPV_const(sv, len);
14a5cf38
JH		 506 PerlLIO_write(dbg, s, len);
507 SvREFCNT_dec(sv);
70ace5da 508#endif
14a5cf38
JH		 509 }
510 va_end(ap);
6f9d8c32
NIS		 511}
512
9e353e3b
NIS		 513/*--------------------------------------------------------------------------------------*/
514
14a5cf38 515/*
71200d45 516 * Inner level routines
14a5cf38 517 */
9e353e3b 518
14a5cf38 519/*
71200d45 520 * Table of pointers to the PerlIO structs (malloc'ed)
14a5cf38 521 */
05d1247b 522#define PERLIO_TABLE_SIZE 64
6f9d8c32 523
760ac839 524PerlIO *
5f1a76d0 525PerlIO_allocate(pTHX)
6f9d8c32 526{
14a5cf38 527 /*
71200d45 528 * Find a free slot in the table, allocating new table as necessary
14a5cf38
JH		 529 */
530 PerlIO **last;
531 PerlIO *f;
a1ea730d 532 last = &PL_perlio;
14a5cf38
JH		 533 while ((f = *last)) {
534 int i;
535 last = (PerlIO **) (f);
536 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
537 if (!*++f) {
538 return f;
539 }
540 }
541 }
cd7a8267 542 Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
14a5cf38
JH		 543 if (!f) {
544 return NULL;
545 }
546 *last = f;
547 return f + 1;
05d1247b
NIS		 548}
549
a1ea730d
NIS		 550#undef PerlIO_fdupopen
551PerlIO *
ecdeb87c 552PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
a1ea730d 553{
04892f78 554 if (PerlIOValid(f)) {
f1c3982b 555 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
fe5a182c 556 PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param);
0710cc63
JH		 557 if (tab && tab->Dup)
558 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
559 else {
560 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
561 }
a1ea730d 562 }
0710cc63
JH		 563 else
564 SETERRNO(EBADF, SS_IVCHAN);
565
566 return NULL;
a1ea730d
NIS		 567}
568
569void
5f1a76d0 570PerlIO_cleantable(pTHX_ PerlIO **tablep)
05d1247b 571{
81ec6716 572 PerlIO * const table = *tablep;
14a5cf38
JH		 573 if (table) {
574 int i;
575 PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
576 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
81ec6716 577 PerlIO * const f = table + i;
14a5cf38
JH		 578 if (*f) {
579 PerlIO_close(f);
580 }
581 }
3a1ee7e8 582 Safefree(table);
14a5cf38 583 *tablep = NULL;
05d1247b 584 }
05d1247b
NIS		 585}
586
fcf2db38
NIS		 587
588PerlIO_list_t *
3a1ee7e8 589PerlIO_list_alloc(pTHX)
fcf2db38 590{
14a5cf38 591 PerlIO_list_t *list;
1e7ed80e 592 PERL_UNUSED_CONTEXT;
cd7a8267 593 Newxz(list, 1, PerlIO_list_t);
14a5cf38
JH		 594 list->refcnt = 1;
595 return list;
fcf2db38
NIS		 596}
597
598void
3a1ee7e8 599PerlIO_list_free(pTHX_ PerlIO_list_t *list)
fcf2db38 600{
14a5cf38
JH		 601 if (list) {
602 if (--list->refcnt == 0) {
603 if (list->array) {
14a5cf38
JH		 604 IV i;
605 for (i = 0; i < list->cur; i++) {
606 if (list->array[i].arg)
607 SvREFCNT_dec(list->array[i].arg);
608 }
609 Safefree(list->array);
610 }
611 Safefree(list);
612 }
613 }
fcf2db38
NIS		 614}
615
616void
3a1ee7e8 617PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
14a5cf38 618{
14a5cf38 619 PerlIO_pair_t *p;
2ebc12fe
NC		 620 PERL_UNUSED_CONTEXT;
621
14a5cf38
JH		 622 if (list->cur >= list->len) {
623 list->len += 8;
624 if (list->array)
625 Renew(list->array, list->len, PerlIO_pair_t);
626 else
cd7a8267 627 Newx(list->array, list->len, PerlIO_pair_t);
14a5cf38
JH		 628 }
629 p = &(list->array[list->cur++]);
630 p->funcs = funcs;
631 if ((p->arg = arg)) {
be2d5e07 632 SvREFCNT_inc_simple_void_NN(arg);
14a5cf38 633 }
fcf2db38
NIS		 634}
635
3a1ee7e8
NIS		 636PerlIO_list_t *
637PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
638{
be2d5e07 639 PerlIO_list_t *list = NULL;
694c95cf
JH		 640 if (proto) {
641 int i;
642 list = PerlIO_list_alloc(aTHX);
643 for (i=0; i < proto->cur; i++) {
0e2d6244 644 SV *arg = NULL;
694c95cf
JH		 645 if (proto->array[i].arg)
646 arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param);
647 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
648 }
3a1ee7e8
NIS		 649 }
650 return list;
651}
4a4a6116 652
05d1247b 653void
3a1ee7e8 654PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
9a6404c5 655{
3aaf42a7 656#ifdef USE_ITHREADS
3a1ee7e8
NIS		 657 PerlIO **table = &proto->Iperlio;
658 PerlIO *f;
659 PL_perlio = NULL;
660 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
661 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
662 PerlIO_allocate(aTHX); /* root slot is never used */
2190c7e7 663 PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
3a1ee7e8
NIS		 664 while ((f = *table)) {
665 int i;
666 table = (PerlIO **) (f++);
667 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
668 if (*f) {
93a8090d 669 (void) fp_dup(f, 0, param);
3a1ee7e8
NIS		 670 }
671 f++;
672 }
673 }
ce7d4f40 674#else
2190c7e7 675 PERL_UNUSED_CONTEXT;
ce7d4f40
AL		 676 PERL_UNUSED_ARG(proto);
677 PERL_UNUSED_ARG(param);
3aaf42a7 678#endif
9a6404c5
DM		 679}
680
681void
13621cfb
NIS		 682PerlIO_destruct(pTHX)
683{
a1ea730d 684 PerlIO **table = &PL_perlio;
14a5cf38 685 PerlIO *f;
694c95cf 686#ifdef USE_ITHREADS
2190c7e7 687 PerlIO_debug("Destruct %p\n",(void*)aTHX);
694c95cf 688#endif
14a5cf38
JH		 689 while ((f = *table)) {
690 int i;
691 table = (PerlIO **) (f++);
692 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
693 PerlIO *x = f;
81ec6716 694 const PerlIOl *l;
14a5cf38
JH		 695 while ((l = *x)) {
696 if (l->tab->kind & PERLIO_K_DESTRUCT) {
697 PerlIO_debug("Destruct popping %s\n", l->tab->name);
698 PerlIO_flush(x);
699 PerlIO_pop(aTHX_ x);
700 }
701 else {
702 x = PerlIONext(x);
703 }
704 }
705 f++;
706 }
707 }
13621cfb
NIS		 708}
709
710void
a999f61b 711PerlIO_pop(pTHX_ PerlIO *f)
760ac839 712{
81ec6716 713 const PerlIOl *l = *f;
14a5cf38 714 if (l) {
fe5a182c 715 PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
14a5cf38
JH		 716 if (l->tab->Popped) {
717 /*
718 * If popped returns non-zero do not free its layer structure
719 * it has either done so itself, or it is shared and still in
71200d45 720 * use
14a5cf38 721 */
f62ce20a 722 if ((*l->tab->Popped) (aTHX_ f) != 0)
14a5cf38
JH		 723 return;
724 }
b47cad08 725 *f = l->next;
3a1ee7e8 726 Safefree(l);
a8c08ecd 727 }
6f9d8c32
NIS		 728}
729
5095c3e6
JH		 730/* Return as an array the stack of layers on a filehandle. Note that
731 * the stack is returned top-first in the array, and there are three
732 * times as many array elements as there are layers in the stack: the
733 * first element of a layer triplet is the name, the second one is the
734 * arguments, and the third one is the flags. */
735
736AV *
737PerlIO_get_layers(pTHX_ PerlIO *f)
738{
81ec6716 739 AV * const av = newAV();
5095c3e6 740
81ec6716
AL		 741 if (PerlIOValid(f)) {
742 PerlIOl *l = PerlIOBase(f);
743
744 while (l) {
745 SV * const name = l->tab && l->tab->name ?
746 newSVpv(l->tab->name, 0) : &PL_sv_undef;
747 SV * const arg = l->tab && l->tab->Getarg ?
748 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
749 av_push(av, name);
750 av_push(av, arg);
751 av_push(av, newSViv((IV)l->flags));
752 l = l->next;
753 }
754 }
5095c3e6 755
81ec6716 756 return av;
5095c3e6
JH		 757}
758
9e353e3b 759/*--------------------------------------------------------------------------------------*/
14a5cf38 760/*
71200d45 761 * XS Interface for perl code
14a5cf38 762 */
9e353e3b 763
fcf2db38 764PerlIO_funcs *
2edd7e44 765PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
f3862f8b 766{
14a5cf38
JH		 767 IV i;
768 if ((SSize_t) len <= 0)
769 len = strlen(name);
3a1ee7e8 770 for (i = 0; i < PL_known_layers->cur; i++) {
217ef1d7 771 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
9e4d75e1 772 if (memEQ(f->name, name, len) && f->name[len] == 0) {
fe5a182c 773 PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f);
14a5cf38
JH		 774 return f;
775 }
776 }
3a1ee7e8
NIS		 777 if (load && PL_subname && PL_def_layerlist
778 && PL_def_layerlist->cur >= 2) {
d7a09b41
SR		 779 if (PL_in_load_module) {
780 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
781 return NULL;
782 } else {
d7559646 783 SV * const pkgsv = newSVpvs("PerlIO");
217ef1d7
AL		 784 SV * const layer = newSVpvn(name, len);
785 CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
786 ENTER;
d7a09b41 787 SAVEINT(PL_in_load_module);
338501c1 788 if (cv) {
2098fb77 789 SAVEGENERICSV(PL_warnhook);
be2d5e07 790 PL_warnhook = (SV *) (SvREFCNT_inc_simple_NN(cv));
338501c1 791 }
d7a09b41
SR		 792 PL_in_load_module++;
793 /*
794 * The two SVs are magically freed by load_module
795 */
0e2d6244 796 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
d7a09b41
SR		 797 PL_in_load_module--;
798 LEAVE;
799 return PerlIO_find_layer(aTHX_ name, len, 0);
800 }
14a5cf38
JH		 801 }
802 PerlIO_debug("Cannot find %.*s\n", (int) len, name);
803 return NULL;
f3862f8b
NIS		 804}
805
2a1bc955 806#ifdef USE_ATTRIBUTES_FOR_PERLIO
b13b2135
NIS		 807
808static int
809perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
810{
14a5cf38 811 if (SvROK(sv)) {
81ec6716
AL		 812 IO * const io = GvIOn((GV *) SvRV(sv));
813 PerlIO * const ifp = IoIFP(io);
814 PerlIO * const ofp = IoOFP(io);
14a5cf38
JH		 815 Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp);
816 }
817 return 0;
b13b2135
NIS		 818}
819
820static int
821perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
822{
14a5cf38 823 if (SvROK(sv)) {
81ec6716
AL		 824 IO * const io = GvIOn((GV *) SvRV(sv));
825 PerlIO * const ifp = IoIFP(io);
826 PerlIO * const ofp = IoOFP(io);
14a5cf38
JH		 827 Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp);
828 }
829 return 0;
b13b2135
NIS		 830}
831
832static int
833perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
834{
14a5cf38
JH		 835 Perl_warn(aTHX_ "clear %" SVf, sv);
836 return 0;
b13b2135
NIS		 837}
838
839static int
840perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
841{
14a5cf38
JH		 842 Perl_warn(aTHX_ "free %" SVf, sv);
843 return 0;
b13b2135
NIS		 844}
845
846MGVTBL perlio_vtab = {
14a5cf38
JH		 847 perlio_mg_get,
848 perlio_mg_set,
22569500 849 NULL, /* len */
14a5cf38
JH		 850 perlio_mg_clear,
851 perlio_mg_free
b13b2135
NIS		 852};
853
854XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
855{
14a5cf38 856 dXSARGS;
81ec6716
AL		 857 SV * const sv = SvRV(ST(1));
858 AV * const av = newAV();
14a5cf38
JH		 859 MAGIC *mg;
860 int count = 0;
861 int i;
862 sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0);
863 SvRMAGICAL_off(sv);
864 mg = mg_find(sv, PERL_MAGIC_ext);
865 mg->mg_virtual = &perlio_vtab;
866 mg_magical(sv);
867 Perl_warn(aTHX_ "attrib %" SVf, sv);
868 for (i = 2; i < items; i++) {
869 STRLEN len;
81ec6716
AL		 870 const char * const name = SvPV_const(ST(i), len);
871 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
14a5cf38 872 if (layer) {
be2d5e07 873 av_push(av, SvREFCNT_inc_simple_NN(layer));
14a5cf38
JH		 874 }
875 else {
876 ST(count) = ST(i);
877 count++;
878 }
879 }
880 SvREFCNT_dec(av);
881 XSRETURN(count);
882}
883
22569500 884#endif /* USE_ATTIBUTES_FOR_PERLIO */
2a1bc955 885
e3f3bf95
NIS		 886SV *
887PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
f3862f8b 888{
d7559646 889 HV * const stash = gv_stashpvs("PerlIO::Layer", TRUE);
217ef1d7 890 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
14a5cf38 891 return sv;
e3f3bf95
NIS		 892}
893
338501c1
JH		 894XS(XS_PerlIO__Layer__NoWarnings)
895{
0710cc63 896 /* This is used as a %SIG{__WARN__} handler to supress warnings
338501c1
JH		 897 during loading of layers.
898 */
899 dXSARGS;
900 if (items)
c06c673c 901 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0)));
338501c1
JH		 902 XSRETURN(0);
903}
904
0c4f7ff0
NIS		 905XS(XS_PerlIO__Layer__find)
906{
14a5cf38
JH		 907 dXSARGS;
908 if (items < 2)
909 Perl_croak(aTHX_ "Usage class->find(name[,load])");
910 else {
f1c3982b 911 STRLEN len;
217ef1d7 912 const char * const name = SvPV_const(ST(1), len);
f1c3982b 913 const bool load = (items > 2) ? SvTRUE(ST(2)) : 0;
217ef1d7 914 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
14a5cf38
JH		 915 ST(0) =
916 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
917 &PL_sv_undef;
918 XSRETURN(1);
919 }
0c4f7ff0
NIS		 920}
921
e3f3bf95
NIS		 922void
923PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
924{
3a1ee7e8
NIS		 925 if (!PL_known_layers)
926 PL_known_layers = PerlIO_list_alloc(aTHX);
0e2d6244 927 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
fe5a182c 928 PerlIO_debug("define %s %p\n", tab->name, (void*)tab);
f3862f8b
NIS		 929}
930
1141d9f8 931int
fcf2db38 932PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
1141d9f8 933{
14a5cf38
JH		 934 if (names) {
935 const char *s = names;
936 while (*s) {
937 while (isSPACE(*s) || *s == ':')
938 s++;
939 if (*s) {
940 STRLEN llen = 0;
941 const char *e = s;
0e2d6244 942 const char *as = NULL;
14a5cf38
JH		 943 STRLEN alen = 0;
944 if (!isIDFIRST(*s)) {
945 /*
946 * Message is consistent with how attribute lists are
947 * passed. Even though this means "foo : : bar" is
71200d45 948 * seen as an invalid separator character.
14a5cf38 949 */
f1c3982b 950 const char q = ((*s == '\'') ? '"' : '\'');
99ef548b 951 if (ckWARN(WARN_LAYER))
22569500 952 Perl_warner(aTHX_ packWARN(WARN_LAYER),
9e4d75e1 953 "Invalid separator character %c%c%c in PerlIO layer specification %s",
1e616cf5 954 q, *s, q, s);
93189314 955 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 956 return -1;
957 }
958 do {
959 e++;
960 } while (isALNUM(*e));
961 llen = e - s;
962 if (*e == '(') {
963 int nesting = 1;
964 as = ++e;
965 while (nesting) {
966 switch (*e++) {
967 case ')':
968 if (--nesting == 0)
969 alen = (e - 1) - as;
970 break;
971 case '(':
972 ++nesting;
973 break;
974 case '\\':
975 /*
976 * It's a nul terminated string, not allowed
977 * to \ the terminating null. Anything other
71200d45 978 * character is passed over.
14a5cf38
JH		 979 */
980 if (*e++) {
981 break;
982 }
983 /*
71200d45 984 * Drop through
14a5cf38
JH		 985 */
986 case '\0':
987 e--;
22569500
NIS		 988 if (ckWARN(WARN_LAYER))
989 Perl_warner(aTHX_ packWARN(WARN_LAYER),
9e4d75e1 990 "Argument list not closed for PerlIO layer \"%.*s\"",
14a5cf38
JH		 991 (int) (e - s), s);
992 return -1;
993 default:
994 /*
71200d45 995 * boring.
14a5cf38
JH		 996 */
997 break;
998 }
999 }
1000 }
1001 if (e > s) {
217ef1d7 1002 PerlIO_funcs * const layer =
14a5cf38
JH		 1003 PerlIO_find_layer(aTHX_ s, llen, 1);
1004 if (layer) {
3a1ee7e8 1005 PerlIO_list_push(aTHX_ av, layer,
14a5cf38
JH		 1006 (as) ? newSVpvn(as,
1007 alen) :
1008 &PL_sv_undef);
1009 }
1010 else {
f5e9f069 1011 if (ckWARN(WARN_LAYER))
9e4d75e1 1012 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
14a5cf38
JH		 1013 (int) llen, s);
1014 return -1;
1015 }
1016 }
1017 s = e;
1018 }
1019 }
1020 }
1021 return 0;
1141d9f8
NIS		 1022}
1023
dfebf958 1024void
fcf2db38 1025PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
dfebf958 1026{
cf7b4f3b 1027 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
35990314 1028#ifdef PERLIO_USING_CRLF
6ce75a77 1029 tab = &PerlIO_crlf;
846be114 1030#else
6ce75a77 1031 if (PerlIO_stdio.Set_ptrcnt)
22569500 1032 tab = &PerlIO_stdio;
846be114 1033#endif
14a5cf38 1034 PerlIO_debug("Pushing %s\n", tab->name);
3a1ee7e8 1035 PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0),
14a5cf38 1036 &PL_sv_undef);
dfebf958
NIS		 1037}
1038
e3f3bf95 1039SV *
14a5cf38 1040PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
e3f3bf95 1041{
14a5cf38 1042 return av->array[n].arg;
e3f3bf95
NIS		 1043}
1044
f3862f8b 1045PerlIO_funcs *
14a5cf38 1046PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
f3862f8b 1047{
14a5cf38
JH		 1048 if (n >= 0 && n < av->cur) {
1049 PerlIO_debug("Layer %" IVdf " is %s\n", n,
1050 av->array[n].funcs->name);
1051 return av->array[n].funcs;
1052 }
1053 if (!def)
1054 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1055 return def;
e3f3bf95
NIS		 1056}
1057
4ec2216f
NIS		 1058IV
1059PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1060{
4f1e9d25
AL		 1061 PERL_UNUSED_ARG(mode);
1062 PERL_UNUSED_ARG(arg);
1063 PERL_UNUSED_ARG(tab);
4ec2216f
NIS		 1064 if (PerlIOValid(f)) {
1065 PerlIO_flush(f);
1066 PerlIO_pop(aTHX_ f);
1067 return 0;
1068 }
1069 return -1;
1070}
1071
cf7b4f3b 1072PERLIO_FUNCS_DECL(PerlIO_remove) = {
4ec2216f
NIS		 1073 sizeof(PerlIO_funcs),
1074 "pop",
1075 0,
1076 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1077 PerlIOPop_pushed,
1078 NULL,
1079 NULL,
1080 NULL,
1081 NULL,
1082 NULL,
1083 NULL,
1084 NULL,
1085 NULL,
1086 NULL,
1087 NULL,
f1c3982b
NC		 1088 NULL,
1089 NULL,
4ec2216f
NIS		 1090 NULL, /* flush */
1091 NULL, /* fill */
1092 NULL,
1093 NULL,
1094 NULL,
1095 NULL,
1096 NULL, /* get_base */
1097 NULL, /* get_bufsiz */
1098 NULL, /* get_ptr */
1099 NULL, /* get_cnt */
1100 NULL, /* set_ptrcnt */
1101};
1102
fcf2db38 1103PerlIO_list_t *
e3f3bf95
NIS		 1104PerlIO_default_layers(pTHX)
1105{
3a1ee7e8 1106 if (!PL_def_layerlist) {
81ec6716 1107 const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO");
cf7b4f3b 1108 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
3a1ee7e8 1109 PL_def_layerlist = PerlIO_list_alloc(aTHX);
cf7b4f3b 1110 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
7b24b0b0 1111#if defined(WIN32)
cf7b4f3b 1112 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
2f8118af 1113#if 0
14a5cf38 1114 osLayer = &PerlIO_win32;
0c4128ad 1115#endif
2f8118af 1116#endif
cf7b4f3b
JH		 1117 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1118 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1119 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1120 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
06da4f11 1121#ifdef HAS_MMAP
cf7b4f3b 1122 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
06da4f11 1123#endif
cf7b4f3b
JH		 1124 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1125 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1126 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
3a1ee7e8 1127 PerlIO_list_push(aTHX_ PL_def_layerlist,
14a5cf38
JH		 1128 PerlIO_find_layer(aTHX_ osLayer->name, 0, 0),
1129 &PL_sv_undef);
1130 if (s) {
3a1ee7e8 1131 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
14a5cf38
JH		 1132 }
1133 else {
3a1ee7e8 1134 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
14a5cf38 1135 }
1141d9f8 1136 }
3a1ee7e8
NIS		 1137 if (PL_def_layerlist->cur < 2) {
1138 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
f3862f8b 1139 }
3a1ee7e8 1140 return PL_def_layerlist;
e3f3bf95
NIS		 1141}
1142
0c4f7ff0
NIS		 1143void
1144Perl_boot_core_PerlIO(pTHX)
1145{
1146#ifdef USE_ATTRIBUTES_FOR_PERLIO
14a5cf38
JH		 1147 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1148 __FILE__);
0c4f7ff0 1149#endif
14a5cf38 1150 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
338501c1 1151 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
0c4f7ff0 1152}
e3f3bf95
NIS		 1153
1154PerlIO_funcs *
1155PerlIO_default_layer(pTHX_ I32 n)
1156{
217ef1d7 1157 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
14a5cf38
JH		 1158 if (n < 0)
1159 n += av->cur;
cf7b4f3b 1160 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
f3862f8b
NIS		 1161}
1162
a999f61b
NIS		 1163#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1164#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
60382766
NIS		 1165
1166void
1141d9f8 1167PerlIO_stdstreams(pTHX)
60382766 1168{
a1ea730d 1169 if (!PL_perlio) {
14a5cf38
JH		 1170 PerlIO_allocate(aTHX);
1171 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1172 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1173 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1174 }
60382766
NIS		 1175}
1176
1177PerlIO *
cf7b4f3b 1178PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
14a5cf38 1179{
2dc2558e
NIS		 1180 if (tab->fsize != sizeof(PerlIO_funcs)) {
1181 mismatch:
1182 Perl_croak(aTHX_ "Layer does not match this perl");
1183 }
1184 if (tab->size) {
481da01c 1185 PerlIOl *l;
2dc2558e
NIS		 1186 if (tab->size < sizeof(PerlIOl)) {
1187 goto mismatch;
1188 }
1189 /* Real layer with a data area */
550aaea5
NC		 1190 if (f) {
1191 char *temp;
1192 Newxz(temp, tab->size, char);
1193 l = (PerlIOl*)temp;
1194 if (l) {
1195 l->next = *f;
1196 l->tab = (PerlIO_funcs*) tab;
1197 *f = l;
1198 PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1199 (void*)f, tab->name,
1200 (mode) ? mode : "(Null)", (void*)arg);
1201 if (*l->tab->Pushed &&
1202 (*l->tab->Pushed)
1203 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1204 PerlIO_pop(aTHX_ f);
1205 return NULL;
1206 }
2dc2558e 1207 }
550aaea5
NC		 1208 else
1209 return NULL;
2dc2558e
NIS		 1210 }
1211 }
1212 else if (f) {
1213 /* Pseudo-layer where push does its own stack adjust */
00f51856
NIS		 1214 PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1215 (mode) ? mode : "(Null)", (void*)arg);
0710cc63 1216 if (tab->Pushed &&
cf7b4f3b 1217 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
0710cc63 1218 return NULL;
14a5cf38
JH		 1219 }
1220 }
1221 return f;
60382766
NIS		 1222}
1223
dfebf958 1224IV
86e05cf2
NIS		 1225PerlIOBase_binmode(pTHX_ PerlIO *f)
1226{
1227 if (PerlIOValid(f)) {
1228 /* Is layer suitable for raw stream ? */
1229 if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1230 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1231 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1232 }
1233 else {
1234 /* Not suitable - pop it */
1235 PerlIO_pop(aTHX_ f);
1236 }
1237 return 0;
1238 }
1239 return -1;
1240}
1241
1242IV
2dc2558e 1243PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
dfebf958 1244{
4f1e9d25
AL		 1245 PERL_UNUSED_ARG(mode);
1246 PERL_UNUSED_ARG(arg);
1247 PERL_UNUSED_ARG(tab);
86e05cf2 1248
04892f78 1249 if (PerlIOValid(f)) {
86e05cf2 1250 PerlIO *t;
f1c3982b 1251 const PerlIOl *l;
14a5cf38 1252 PerlIO_flush(f);
86e05cf2
NIS		 1253 /*
1254 * Strip all layers that are not suitable for a raw stream
1255 */
1256 t = f;
1257 while (t && (l = *t)) {
1258 if (l->tab->Binmode) {
1259 /* Has a handler - normal case */
1260 if ((*l->tab->Binmode)(aTHX_ f) == 0) {
1261 if (*t == l) {
1262 /* Layer still there - move down a layer */
1263 t = PerlIONext(t);
1264 }
1265 }
1266 else {
1267 return -1;
1268 }
14a5cf38
JH		 1269 }
1270 else {
86e05cf2
NIS		 1271 /* No handler - pop it */
1272 PerlIO_pop(aTHX_ t);
14a5cf38
JH		 1273 }
1274 }
86e05cf2
NIS		 1275 if (PerlIOValid(f)) {
1276 PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
1277 return 0;
1278 }
14a5cf38
JH		 1279 }
1280 return -1;
dfebf958
NIS		 1281}
1282
ac27b0f5 1283int
14a5cf38 1284PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
d9dac8cd 1285 PerlIO_list_t *layers, IV n, IV max)
14a5cf38 1286{
14a5cf38
JH		 1287 int code = 0;
1288 while (n < max) {
4f1e9d25 1289 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
14a5cf38
JH		 1290 if (tab) {
1291 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1292 code = -1;
1293 break;
1294 }
1295 }
1296 n++;
1297 }
1298 return code;
e3f3bf95
NIS		 1299}
1300
1301int
ac27b0f5
NIS		 1302PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1303{
14a5cf38 1304 int code = 0;
53f1b6d2 1305 if (f && names) {
4f1e9d25 1306 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
14a5cf38
JH		 1307 code = PerlIO_parse_layers(aTHX_ layers, names);
1308 if (code == 0) {
d9dac8cd 1309 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
14a5cf38 1310 }
3a1ee7e8 1311 PerlIO_list_free(aTHX_ layers);
ac27b0f5 1312 }
14a5cf38 1313 return code;
ac27b0f5
NIS		 1314}
1315
f3862f8b 1316
60382766 1317/*--------------------------------------------------------------------------------------*/
14a5cf38 1318/*
71200d45 1319 * Given the abstraction above the public API functions
14a5cf38 1320 */
60382766
NIS		 1321
1322int
f5b9d040 1323PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
76ced9ad 1324{
7b146116
NC		 1325 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1326 (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
1327 iotype, mode, (names) ? names : "(Null)");
1328
03c0554d
NIS		 1329 if (names) {
1330 /* Do not flush etc. if (e.g.) switching encodings.
1331 if a pushed layer knows it needs to flush lower layers
1332 (for example :unix which is never going to call them)
1333 it can do the flush when it is pushed.
1334 */
1335 return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
1336 }
1337 else {
86e05cf2 1338 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
35990314 1339#ifdef PERLIO_USING_CRLF
03c0554d
NIS		 1340 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1341 O_BINARY so we can look for it in mode.
1342 */
1343 if (!(mode & O_BINARY)) {
1344 /* Text mode */
86e05cf2
NIS		 1345 /* FIXME?: Looking down the layer stack seems wrong,
1346 but is a way of reaching past (say) an encoding layer
1347 to flip CRLF-ness of the layer(s) below
1348 */
03c0554d
NIS		 1349 while (*f) {
1350 /* Perhaps we should turn on bottom-most aware layer
1351 e.g. Ilya's idea that UNIX TTY could serve
1352 */
1353 if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
1354 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1355 /* Not in text mode - flush any pending stuff and flip it */
1356 PerlIO_flush(f);
1357 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1358 }
1359 /* Only need to turn it on in one layer so we are done */
1360 return TRUE;
ed53a2bb 1361 }
03c0554d 1362 f = PerlIONext(f);
14a5cf38 1363 }
03c0554d
NIS		 1364 /* Not finding a CRLF aware layer presumably means we are binary
1365 which is not what was requested - so we failed
1366 We _could_ push :crlf layer but so could caller
1367 */
1368 return FALSE;
14a5cf38 1369 }
6ce75a77 1370#endif
86e05cf2
NIS		 1371 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1372 So code that used to be here is now in PerlIORaw_pushed().
03c0554d 1373 */
0e2d6244 1374 return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE;
14a5cf38 1375 }
f5b9d040
NIS		 1376}
1377
f5b9d040 1378int
e87a358a 1379PerlIO__close(pTHX_ PerlIO *f)
f5b9d040 1380{
0710cc63 1381 if (PerlIOValid(f)) {
217ef1d7 1382 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
0710cc63
JH		 1383 if (tab && tab->Close)
1384 return (*tab->Close)(aTHX_ f);
1385 else
1386 return PerlIOBase_close(aTHX_ f);
1387 }
14a5cf38 1388 else {
93189314 1389 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH		 1390 return -1;
1391 }
76ced9ad
NIS		 1392}
1393
b931b1d9 1394int
e87a358a 1395Perl_PerlIO_close(pTHX_ PerlIO *f)
b931b1d9 1396{
f1c3982b 1397 const int code = PerlIO__close(aTHX_ f);
0710cc63
JH		 1398 while (PerlIOValid(f)) {
1399 PerlIO_pop(aTHX_ f);
f6c77cf1 1400 }
14a5cf38 1401 return code;
b931b1d9
NIS		 1402}
1403
b931b1d9 1404int
e87a358a 1405Perl_PerlIO_fileno(pTHX_ PerlIO *f)
b931b1d9 1406{
0710cc63 1407 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
b931b1d9
NIS		 1408}
1409
1141d9f8
NIS		 1410static const char *
1411PerlIO_context_layers(pTHX_ const char *mode)
1412{
14a5cf38
JH		 1413 const char *type = NULL;
1414 /*
71200d45 1415 * Need to supply default layer info from open.pm
14a5cf38
JH		 1416 */
1417 if (PL_curcop) {
81ec6716 1418 SV * const layers = PL_curcop->cop_io;
14a5cf38
JH		 1419 if (layers) {
1420 STRLEN len;
23c2bb70 1421 type = SvPV_const(layers, len);
14a5cf38
JH		 1422 if (type && mode[0] != 'r') {
1423 /*
33086015 1424 * Skip to write part, which is separated by a '\0'
14a5cf38 1425 */
33086015
NC		 1426 STRLEN read_len = strlen(type);
1427 if (read_len < len) {
1428 type += read_len + 1;
14a5cf38
JH		 1429 }
1430 }
1431 }
1432 }
1433 return type;
1141d9f8
NIS		 1434}
1435
fcf2db38 1436static PerlIO_funcs *
2edd7e44
NIS		 1437PerlIO_layer_from_ref(pTHX_ SV *sv)
1438{
14a5cf38 1439 /*
71200d45 1440 * For any scalar type load the handler which is bundled with perl
14a5cf38 1441 */
095ea9f7
TS		 1442 if (SvTYPE(sv) < SVt_PVAV) {
1443 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1444 /* This isn't supposed to happen, since PerlIO::scalar is core,
1445 * but could happen anyway in smaller installs or with PAR */
1446 if (!f && ckWARN(WARN_LAYER))
1447 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1448 return f;
1449 }
14a5cf38
JH		 1450
1451 /*
71200d45 1452 * For other types allow if layer is known but don't try and load it
14a5cf38
JH		 1453 */
1454 switch (SvTYPE(sv)) {
1455 case SVt_PVAV:
d7559646 1456 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
14a5cf38 1457 case SVt_PVHV:
d7559646 1458 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
14a5cf38 1459 case SVt_PVCV:
d7559646 1460 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
14a5cf38 1461 case SVt_PVGV:
d7559646 1462 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
9660d211
AL		 1463 default:
1464 return NULL;
14a5cf38 1465 }
2edd7e44
NIS		 1466}
1467
fcf2db38 1468PerlIO_list_t *
14a5cf38
JH		 1469PerlIO_resolve_layers(pTHX_ const char *layers,
1470 const char *mode, int narg, SV **args)
1471{
1472 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1473 int incdef = 1;
a1ea730d 1474 if (!PL_perlio)
14a5cf38
JH		 1475 PerlIO_stdstreams(aTHX);
1476 if (narg) {
81ec6716 1477 SV * const arg = *args;
14a5cf38 1478 /*
71200d45
NIS		 1479 * If it is a reference but not an object see if we have a handler
1480 * for it
14a5cf38
JH		 1481 */
1482 if (SvROK(arg) && !sv_isobject(arg)) {
217ef1d7 1483 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
14a5cf38 1484 if (handler) {
3a1ee7e8
NIS		 1485 def = PerlIO_list_alloc(aTHX);
1486 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
14a5cf38
JH		 1487 incdef = 0;
1488 }
1489 /*
e934609f 1490 * Don't fail if handler cannot be found :via(...) etc. may do
14a5cf38 1491 * something sensible else we will just stringfy and open
71200d45 1492 * resulting string.
14a5cf38
JH		 1493 */
1494 }
1495 }
7b146116 1496 if (!layers || !*layers)
14a5cf38
JH		 1497 layers = PerlIO_context_layers(aTHX_ mode);
1498 if (layers && *layers) {
1499 PerlIO_list_t *av;
1500 if (incdef) {
f1c3982b 1501 IV i;
3a1ee7e8 1502 av = PerlIO_list_alloc(aTHX);
14a5cf38 1503 for (i = 0; i < def->cur; i++) {
3a1ee7e8 1504 PerlIO_list_push(aTHX_ av, def->array[i].funcs,
14a5cf38
JH		 1505 def->array[i].arg);
1506 }
1507 }
1508 else {
1509 av = def;
1510 }
0cff2cf3
NIS		 1511 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1512 return av;
1513 }
1514 else {
1515 PerlIO_list_free(aTHX_ av);
be2d5e07 1516 return NULL;
0cff2cf3 1517 }
14a5cf38
JH		 1518 }
1519 else {
1520 if (incdef)
1521 def->refcnt++;
1522 return def;
1523 }
ee518936
NIS		 1524}
1525
1526PerlIO *
14a5cf38
JH		 1527PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1528 int imode, int perm, PerlIO *f, int narg, SV **args)
1529{
1530 if (!f && narg == 1 && *args == &PL_sv_undef) {
1531 if ((f = PerlIO_tmpfile())) {
7b146116 1532 if (!layers || !*layers)
14a5cf38
JH		 1533 layers = PerlIO_context_layers(aTHX_ mode);
1534 if (layers && *layers)
1535 PerlIO_apply_layers(aTHX_ f, mode, layers);
1536 }
1537 }
1538 else {
f1c3982b 1539 PerlIO_list_t *layera;
14a5cf38
JH		 1540 IV n;
1541 PerlIO_funcs *tab = NULL;
04892f78 1542 if (PerlIOValid(f)) {
14a5cf38 1543 /*
71200d45
NIS		 1544 * This is "reopen" - it is not tested as perl does not use it
1545 * yet
14a5cf38
JH		 1546 */
1547 PerlIOl *l = *f;
3a1ee7e8 1548 layera = PerlIO_list_alloc(aTHX);
14a5cf38 1549 while (l) {
217ef1d7 1550 SV * const arg = (l->tab->Getarg)
04892f78
NIS		 1551 ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0)
1552 : &PL_sv_undef;
3a1ee7e8 1553 PerlIO_list_push(aTHX_ layera, l->tab, arg);
14a5cf38
JH		 1554 l = *PerlIONext(&l);
1555 }
1556 }
1557 else {
1558 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
0cff2cf3
NIS		 1559 if (!layera) {
1560 return NULL;
1561 }
14a5cf38
JH		 1562 }
1563 /*
71200d45 1564 * Start at "top" of layer stack
14a5cf38
JH		 1565 */
1566 n = layera->cur - 1;
1567 while (n >= 0) {
217ef1d7 1568 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
14a5cf38
JH		 1569 if (t && t->Open) {
1570 tab = t;
1571 break;
1572 }
1573 n--;
1574 }
1575 if (tab) {
1576 /*
71200d45 1577 * Found that layer 'n' can do opens - call it
14a5cf38 1578 */
7cf31beb 1579 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
3b8752bb 1580 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
7cf31beb 1581 }
14a5cf38 1582 PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
7b146116
NC		 1583 tab->name, layers ? layers : "(Null)", mode, fd,
1584 imode, perm, (void*)f, narg, (void*)args);
0710cc63
JH		 1585 if (tab->Open)
1586 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1587 f, narg, args);
1588 else {
1589 SETERRNO(EINVAL, LIB_INVARG);
1590 f = NULL;
1591 }
14a5cf38
JH		 1592 if (f) {
1593 if (n + 1 < layera->cur) {
1594 /*
1595 * More layers above the one that we used to open -
71200d45 1596 * apply them now
14a5cf38 1597 */
d9dac8cd
NIS		 1598 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1599 /* If pushing layers fails close the file */
1600 PerlIO_close(f);
14a5cf38
JH		 1601 f = NULL;
1602 }
1603 }
1604 }
1605 }
3a1ee7e8 1606 PerlIO_list_free(aTHX_ layera);
14a5cf38
JH		 1607 }
1608 return f;
ee518936 1609}
b931b1d9
NIS		 1610
1611
9e353e3b 1612SSize_t
e87a358a 1613Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1614{
0710cc63 1615 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1616}
1617
313ca112 1618SSize_t
e87a358a 1619Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1620{
0710cc63 1621 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1622}
1623
9e353e3b 1624SSize_t
e87a358a 1625Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 1626{
0710cc63 1627 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
760ac839
LW		 1628}
1629
6f9d8c32 1630int
e87a358a 1631Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
760ac839 1632{
0710cc63 1633 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
760ac839
LW		 1634}
1635
9e353e3b 1636Off_t
e87a358a 1637Perl_PerlIO_tell(pTHX_ PerlIO *f)
760ac839 1638{
0710cc63 1639 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
760ac839
LW		 1640}
1641
6f9d8c32 1642int
e87a358a 1643Perl_PerlIO_flush(pTHX_ PerlIO *f)
760ac839 1644{
14a5cf38
JH		 1645 if (f) {
1646 if (*f) {
f1c3982b 1647 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
0710cc63
JH		 1648
1649 if (tab && tab->Flush)
f62ce20a 1650 return (*tab->Flush) (aTHX_ f);
0710cc63
JH		 1651 else
1652 return 0; /* If no Flush defined, silently succeed. */
14a5cf38
JH		 1653 }
1654 else {
fe5a182c 1655 PerlIO_debug("Cannot flush f=%p\n", (void*)f);
93189314 1656 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38
JH		 1657 return -1;
1658 }
1659 }
1660 else {
1661 /*
1662 * Is it good API design to do flush-all on NULL, a potentially
1663 * errorneous input? Maybe some magical value (PerlIO*
1664 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1665 * things on fflush(NULL), but should we be bound by their design
71200d45 1666 * decisions? --jhi
14a5cf38 1667 */
a1ea730d 1668 PerlIO **table = &PL_perlio;
14a5cf38
JH		 1669 int code = 0;
1670 while ((f = *table)) {
1671 int i;
1672 table = (PerlIO **) (f++);
1673 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1674 if (*f && PerlIO_flush(f) != 0)
1675 code = -1;
1676 f++;
1677 }
1678 }
1679 return code;
1680 }
760ac839
LW		 1681}
1682
a9c883f6 1683void
f62ce20a 1684PerlIOBase_flush_linebuf(pTHX)
a9c883f6 1685{
a1ea730d 1686 PerlIO **table = &PL_perlio;
14a5cf38
JH		 1687 PerlIO *f;
1688 while ((f = *table)) {
1689 int i;
1690 table = (PerlIO **) (f++);
1691 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1692 if (*f
1693 && (PerlIOBase(f)->
1694 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1695 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1696 PerlIO_flush(f);
1697 f++;
1698 }
a9c883f6 1699 }
a9c883f6
NIS		 1700}
1701
06da4f11 1702int
e87a358a 1703Perl_PerlIO_fill(pTHX_ PerlIO *f)
06da4f11 1704{
0710cc63 1705 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
06da4f11
NIS		 1706}
1707
f3862f8b
NIS		 1708int
1709PerlIO_isutf8(PerlIO *f)
1710{
0710cc63
JH		 1711 if (PerlIOValid(f))
1712 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1713 else
1714 SETERRNO(EBADF, SS_IVCHAN);
1715
1716 return -1;
f3862f8b
NIS		 1717}
1718
6f9d8c32 1719int
e87a358a 1720Perl_PerlIO_eof(pTHX_ PerlIO *f)
760ac839 1721{
0710cc63 1722 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
9e353e3b
NIS		 1723}
1724
9e353e3b 1725int
e87a358a 1726Perl_PerlIO_error(pTHX_ PerlIO *f)
9e353e3b 1727{
0710cc63 1728 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
9e353e3b
NIS		 1729}
1730
9e353e3b 1731void
e87a358a 1732Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
9e353e3b 1733{
0710cc63 1734 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
9e353e3b
NIS		 1735}
1736
9e353e3b 1737void
e87a358a 1738Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 1739{
0710cc63 1740 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
9e353e3b
NIS		 1741}
1742
9e353e3b
NIS		 1743int
1744PerlIO_has_base(PerlIO *f)
1745{
0710cc63 1746 if (PerlIOValid(f)) {
217ef1d7 1747 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
0710cc63
JH		 1748
1749 if (tab)
1750 return (tab->Get_base != NULL);
1751 SETERRNO(EINVAL, LIB_INVARG);
1752 }
1753 else
1754 SETERRNO(EBADF, SS_IVCHAN);
1755
1756 return 0;
760ac839
LW		 1757}
1758
9e353e3b
NIS		 1759int
1760PerlIO_fast_gets(PerlIO *f)
760ac839 1761{
04892f78 1762 if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) {
217ef1d7 1763 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
0710cc63
JH		 1764
1765 if (tab)
1766 return (tab->Set_ptrcnt != NULL);
1767 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 1768 }
0710cc63
JH		 1769 else
1770 SETERRNO(EBADF, SS_IVCHAN);
1771
14a5cf38 1772 return 0;
9e353e3b
NIS		 1773}
1774
9e353e3b
NIS		 1775int
1776PerlIO_has_cntptr(PerlIO *f)
1777{
04892f78 1778 if (PerlIOValid(f)) {
217ef1d7 1779 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
0710cc63
JH		 1780
1781 if (tab)
1782 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1783 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 1784 }
0710cc63
JH		 1785 else
1786 SETERRNO(EBADF, SS_IVCHAN);
1787
14a5cf38 1788 return 0;
9e353e3b
NIS		 1789}
1790
9e353e3b
NIS		 1791int
1792PerlIO_canset_cnt(PerlIO *f)
1793{
04892f78 1794 if (PerlIOValid(f)) {
217ef1d7 1795 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
0710cc63
JH		 1796
1797 if (tab)
1798 return (tab->Set_ptrcnt != NULL);
1799 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 1800 }
0710cc63
JH		 1801 else
1802 SETERRNO(EBADF, SS_IVCHAN);
1803
14a5cf38 1804 return 0;
760ac839
LW		 1805}
1806
888911fc 1807STDCHAR *
e87a358a 1808Perl_PerlIO_get_base(pTHX_ PerlIO *f)
760ac839 1809{
0710cc63 1810 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
9e353e3b
NIS		 1811}
1812
9e353e3b 1813int
e87a358a 1814Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 1815{
0710cc63 1816 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
9e353e3b
NIS		 1817}
1818
9e353e3b 1819STDCHAR *
e87a358a 1820Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
9e353e3b 1821{
0710cc63 1822 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
9e353e3b
NIS		 1823}
1824
05d1247b 1825int
e87a358a 1826Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
9e353e3b 1827{
0710cc63 1828 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
9e353e3b
NIS		 1829}
1830
9e353e3b 1831void
e87a358a 1832Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt)
9e353e3b 1833{
0710cc63 1834 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
9e353e3b
NIS		 1835}
1836
9e353e3b 1837void
e87a358a 1838Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
9e353e3b 1839{
0710cc63 1840 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
9e353e3b
NIS		 1841}
1842
4ec2216f 1843
9e353e3b 1844/*--------------------------------------------------------------------------------------*/
14a5cf38 1845/*
71200d45 1846 * utf8 and raw dummy layers
14a5cf38 1847 */
dfebf958 1848
26fb694e 1849IV
2dc2558e 1850PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
26fb694e 1851{
1e7ed80e 1852 PERL_UNUSED_CONTEXT;
4f1e9d25
AL		 1853 PERL_UNUSED_ARG(mode);
1854 PERL_UNUSED_ARG(arg);
00f51856 1855 if (PerlIOValid(f)) {
14a5cf38
JH		 1856 if (tab->kind & PERLIO_K_UTF8)
1857 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1858 else
1859 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1860 return 0;
1861 }
1862 return -1;
26fb694e
NIS		 1863}
1864
cf7b4f3b 1865PERLIO_FUNCS_DECL(PerlIO_utf8) = {
2dc2558e 1866 sizeof(PerlIO_funcs),
14a5cf38 1867 "utf8",
2dc2558e 1868 0,
6874a2de 1869 PERLIO_K_DUMMY | PERLIO_K_UTF8,
14a5cf38
JH		 1870 PerlIOUtf8_pushed,
1871 NULL,
1872 NULL,
1873 NULL,
1874 NULL,
1875 NULL,
1876 NULL,
1877 NULL,
1878 NULL,
1879 NULL,
1880 NULL,
f1c3982b
NC		 1881 NULL,
1882 NULL,
22569500
NIS		 1883 NULL, /* flush */
1884 NULL, /* fill */
14a5cf38
JH		 1885 NULL,
1886 NULL,
1887 NULL,
1888 NULL,
22569500
NIS		 1889 NULL, /* get_base */
1890 NULL, /* get_bufsiz */
1891 NULL, /* get_ptr */
1892 NULL, /* get_cnt */
1893 NULL, /* set_ptrcnt */
26fb694e
NIS		 1894};
1895
cf7b4f3b 1896PERLIO_FUNCS_DECL(PerlIO_byte) = {
2dc2558e 1897 sizeof(PerlIO_funcs),
14a5cf38 1898 "bytes",
2dc2558e 1899 0,
14a5cf38
JH		 1900 PERLIO_K_DUMMY,
1901 PerlIOUtf8_pushed,
1902 NULL,
1903 NULL,
1904 NULL,
1905 NULL,
1906 NULL,
1907 NULL,
1908 NULL,
1909 NULL,
1910 NULL,
1911 NULL,
f1c3982b
NC		 1912 NULL,
1913 NULL,
22569500
NIS		 1914 NULL, /* flush */
1915 NULL, /* fill */
14a5cf38
JH		 1916 NULL,
1917 NULL,
1918 NULL,
1919 NULL,
22569500
NIS		 1920 NULL, /* get_base */
1921 NULL, /* get_bufsiz */
1922 NULL, /* get_ptr */
1923 NULL, /* get_cnt */
1924 NULL, /* set_ptrcnt */
dfebf958
NIS		 1925};
1926
1927PerlIO *
14a5cf38
JH		 1928PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1929 IV n, const char *mode, int fd, int imode, int perm,
1930 PerlIO *old, int narg, SV **args)
dfebf958 1931{
4f1e9d25
AL		 1932 PerlIO_funcs * const tab = PerlIO_default_btm();
1933 PERL_UNUSED_ARG(self);
0710cc63
JH		 1934 if (tab && tab->Open)
1935 return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
1936 old, narg, args);
1937 SETERRNO(EINVAL, LIB_INVARG);
1938 return NULL;
dfebf958
NIS		 1939}
1940
cf7b4f3b 1941PERLIO_FUNCS_DECL(PerlIO_raw) = {
2dc2558e 1942 sizeof(PerlIO_funcs),
14a5cf38 1943 "raw",
2dc2558e 1944 0,
14a5cf38
JH		 1945 PERLIO_K_DUMMY,
1946 PerlIORaw_pushed,
1947 PerlIOBase_popped,
1948 PerlIORaw_open,
1949 NULL,
1950 NULL,
1951 NULL,
1952 NULL,
1953 NULL,
1954 NULL,
1955 NULL,
1956 NULL,
f1c3982b
NC		 1957 NULL,
1958 NULL,
22569500
NIS		 1959 NULL, /* flush */
1960 NULL, /* fill */
14a5cf38
JH		 1961 NULL,
1962 NULL,
1963 NULL,
1964 NULL,
22569500
NIS		 1965 NULL, /* get_base */
1966 NULL, /* get_bufsiz */
1967 NULL, /* get_ptr */
1968 NULL, /* get_cnt */
1969 NULL, /* set_ptrcnt */
dfebf958
NIS		 1970};
1971/*--------------------------------------------------------------------------------------*/
1972/*--------------------------------------------------------------------------------------*/
14a5cf38 1973/*
71200d45 1974 * "Methods" of the "base class"
14a5cf38 1975 */
9e353e3b
NIS		 1976
1977IV
f62ce20a 1978PerlIOBase_fileno(pTHX_ PerlIO *f)
9e353e3b 1979{
04892f78 1980 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
9e353e3b
NIS		 1981}
1982
f5b9d040 1983char *
81428673 1984PerlIO_modestr(PerlIO * f, char *buf)
14a5cf38
JH		 1985{
1986 char *s = buf;
81428673 1987 if (PerlIOValid(f)) {
f1c3982b 1988 const IV flags = PerlIOBase(f)->flags;
81428673
NIS		 1989 if (flags & PERLIO_F_APPEND) {
1990 *s++ = 'a';
1991 if (flags & PERLIO_F_CANREAD) {
1992 *s++ = '+';
1993 }
14a5cf38 1994 }
81428673
NIS		 1995 else if (flags & PERLIO_F_CANREAD) {
1996 *s++ = 'r';
1997 if (flags & PERLIO_F_CANWRITE)
1998 *s++ = '+';
1999 }
2000 else if (flags & PERLIO_F_CANWRITE) {
2001 *s++ = 'w';
2002 if (flags & PERLIO_F_CANREAD) {
2003 *s++ = '+';
2004 }
14a5cf38 2005 }
35990314 2006#ifdef PERLIO_USING_CRLF
81428673
NIS		 2007 if (!(flags & PERLIO_F_CRLF))
2008 *s++ = 'b';
5f1a76d0 2009#endif
81428673 2010 }
14a5cf38
JH		 2011 *s = '\0';
2012 return buf;
f5b9d040
NIS		 2013}
2014
81428673 2015
76ced9ad 2016IV
2dc2558e 2017PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
9e353e3b 2018{
f1c3982b 2019 PerlIOl * const l = PerlIOBase(f);
1e7ed80e 2020 PERL_UNUSED_CONTEXT;
4f1e9d25 2021 PERL_UNUSED_ARG(arg);
f1c3982b 2022
14a5cf38
JH		 2023 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
2024 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
2025 if (tab->Set_ptrcnt != NULL)
2026 l->flags |= PERLIO_F_FASTGETS;
2027 if (mode) {
f3c7dfbe 2028 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
14a5cf38
JH		 2029 mode++;
2030 switch (*mode++) {
2031 case 'r':
2032 l->flags |= PERLIO_F_CANREAD;
2033 break;
2034 case 'a':
2035 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
2036 break;
2037 case 'w':
2038 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
2039 break;
2040 default:
93189314 2041 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2042 return -1;
2043 }
2044 while (*mode) {
2045 switch (*mode++) {
2046 case '+':
2047 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2048 break;
2049 case 'b':
2050 l->flags &= ~PERLIO_F_CRLF;
2051 break;
2052 case 't':
2053 l->flags |= PERLIO_F_CRLF;
2054 break;
2055 default:
93189314 2056 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2057 return -1;
2058 }
2059 }
2060 }
2061 else {
2062 if (l->next) {
2063 l->flags |= l->next->flags &
2064 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2065 PERLIO_F_APPEND);
2066 }
2067 }
5e2ab84b 2068#if 0
14a5cf38
JH		 2069 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2070 f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2071 l->flags, PerlIO_modestr(f, temp));
5e2ab84b 2072#endif
14a5cf38 2073 return 0;
76ced9ad
NIS		 2074}
2075
2076IV
f62ce20a 2077PerlIOBase_popped(pTHX_ PerlIO *f)
76ced9ad 2078{
1e7ed80e 2079 PERL_UNUSED_CONTEXT;
4f1e9d25 2080 PERL_UNUSED_ARG(f);
14a5cf38 2081 return 0;
760ac839
LW		 2082}
2083
9e353e3b 2084SSize_t
f62ce20a 2085PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2086{
14a5cf38 2087 /*
71200d45 2088 * Save the position as current head considers it
14a5cf38 2089 */
f1c3982b 2090 const Off_t old = PerlIO_tell(f);
0e2d6244 2091 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
14a5cf38 2092 PerlIOSelf(f, PerlIOBuf)->posn = old;
f1c3982b 2093 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
9e353e3b
NIS		 2094}
2095
f6c77cf1 2096SSize_t
f62ce20a 2097PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
f6c77cf1 2098{
14a5cf38
JH		 2099 STDCHAR *buf = (STDCHAR *) vbuf;
2100 if (f) {
64aa19bc
JH		 2101 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2102 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2103 SETERRNO(EBADF, SS_IVCHAN);
14a5cf38 2104 return 0;
64aa19bc 2105 }
14a5cf38 2106 while (count > 0) {
4cd59068
NC		 2107 get_cnt:
2108 {
14a5cf38
JH		 2109 SSize_t avail = PerlIO_get_cnt(f);
2110 SSize_t take = 0;
2111 if (avail > 0)
9f01e09a 2112 take = ((SSize_t)count < avail) ? (SSize_t)count : avail;
14a5cf38
JH		 2113 if (take > 0) {
2114 STDCHAR *ptr = PerlIO_get_ptr(f);
2115 Copy(ptr, buf, take, STDCHAR);
2116 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2117 count -= take;
2118 buf += take;
4cd59068
NC		 2119 if (avail == 0) /* set_ptrcnt could have reset avail */
2120 goto get_cnt;
14a5cf38
JH		 2121 }
2122 if (count > 0 && avail <= 0) {
2123 if (PerlIO_fill(f) != 0)
2124 break;
2125 }
4cd59068 2126 }
14a5cf38
JH		 2127 }
2128 return (buf - (STDCHAR *) vbuf);
2129 }
f6c77cf1 2130 return 0;
f6c77cf1
NIS		 2131}
2132
9e353e3b 2133IV
f62ce20a 2134PerlIOBase_noop_ok(pTHX_ PerlIO *f)
9e353e3b 2135{
1e7ed80e 2136 PERL_UNUSED_CONTEXT;
4f1e9d25 2137 PERL_UNUSED_ARG(f);
14a5cf38 2138 return 0;
9e353e3b
NIS		 2139}
2140
2141IV
f62ce20a 2142PerlIOBase_noop_fail(pTHX_ PerlIO *f)
06da4f11 2143{
1e7ed80e 2144 PERL_UNUSED_CONTEXT;
4f1e9d25 2145 PERL_UNUSED_ARG(f);
14a5cf38 2146 return -1;
06da4f11
NIS		 2147}
2148
2149IV
f62ce20a 2150PerlIOBase_close(pTHX_ PerlIO *f)
9e353e3b 2151{
0710cc63
JH		 2152 IV code = -1;
2153 if (PerlIOValid(f)) {
2154 PerlIO *n = PerlIONext(f);
2155 code = PerlIO_flush(f);
2156 PerlIOBase(f)->flags &=
2157 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2158 while (PerlIOValid(n)) {
f1c3982b 2159 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
0710cc63
JH		 2160 if (tab && tab->Close) {
2161 if ((*tab->Close)(aTHX_ n) != 0)
2162 code = -1;
2163 break;
2164 }
2165 else {
2166 PerlIOBase(n)->flags &=
2167 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2168 }
2169 n = PerlIONext(n);
2170 }
2171 }
2172 else {
2173 SETERRNO(EBADF, SS_IVCHAN);
2174 }
14a5cf38 2175 return code;
9e353e3b
NIS		 2176}
2177
2178IV
f62ce20a 2179PerlIOBase_eof(pTHX_ PerlIO *f)
9e353e3b 2180{
1e7ed80e 2181 PERL_UNUSED_CONTEXT;
04892f78 2182 if (PerlIOValid(f)) {
14a5cf38
JH		 2183 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2184 }
2185 return 1;
9e353e3b
NIS		 2186}
2187
2188IV
f62ce20a 2189PerlIOBase_error(pTHX_ PerlIO *f)
9e353e3b 2190{
1e7ed80e 2191 PERL_UNUSED_CONTEXT;
04892f78 2192 if (PerlIOValid(f)) {
14a5cf38
JH		 2193 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2194 }
2195 return 1;
9e353e3b
NIS		 2196}
2197
2198void
f62ce20a 2199PerlIOBase_clearerr(pTHX_ PerlIO *f)
9e353e3b 2200{
04892f78 2201 if (PerlIOValid(f)) {
81ec6716 2202 PerlIO * const n = PerlIONext(f);
14a5cf38 2203 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
04892f78 2204 if (PerlIOValid(n))
14a5cf38
JH		 2205 PerlIO_clearerr(n);
2206 }
9e353e3b
NIS		 2207}
2208
2209void
f62ce20a 2210PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 2211{
1e7ed80e 2212 PERL_UNUSED_CONTEXT;
04892f78 2213 if (PerlIOValid(f)) {
14a5cf38
JH		 2214 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2215 }
9e353e3b
NIS		 2216}
2217
93a8090d
NIS		 2218SV *
2219PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2220{
2221 if (!arg)
0e2d6244 2222 return NULL;
93a8090d
NIS		 2223#ifdef sv_dup
2224 if (param) {
2225 return sv_dup(arg, param);
2226 }
2227 else {
2228 return newSVsv(arg);
2229 }
2230#else
ce7d4f40 2231 PERL_UNUSED_ARG(param);
93a8090d
NIS		 2232 return newSVsv(arg);
2233#endif
2234}
2235
2236PerlIO *
ecdeb87c 2237PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
93a8090d 2238{
ce7d4f40 2239 PerlIO * const nexto = PerlIONext(o);
04892f78 2240 if (PerlIOValid(nexto)) {
f1c3982b 2241 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
0710cc63
JH		 2242 if (tab && tab->Dup)
2243 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2244 else
2245 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
93a8090d
NIS		 2246 }
2247 if (f) {
81ec6716 2248 PerlIO_funcs * const self = PerlIOBase(o)->tab;
0710cc63 2249 SV *arg;
93a8090d 2250 char buf[8];
fe5a182c
JH		 2251 PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2252 self->name, (void*)f, (void*)o, (void*)param);
0710cc63
JH		 2253 if (self->Getarg)
2254 arg = (*self->Getarg)(aTHX_ o, param, flags);
2255 else {
0e2d6244 2256 arg = NULL;
93a8090d
NIS		 2257 }
2258 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
ecdeb87c 2259 if (arg) {
93a8090d
NIS		 2260 SvREFCNT_dec(arg);
2261 }
2262 }
2263 return f;
2264}
2265
168d5872 2266#ifdef USE_THREADS
93a8090d 2267perl_mutex PerlIO_mutex;
93a8090d 2268#endif
168d5872 2269int PerlIO_fd_refcnt[PERLIO_MAX_REFCOUNTABLE_FD];
93a8090d
NIS		 2270
2271void
2272PerlIO_init(pTHX)
2273{
2274 /* Place holder for stdstreams call ??? */
168d5872 2275#ifdef USE_THREADS
cf7b4f3b 2276 MUTEX_INIT(&PerlIO_mutex);
3ecde996 2277#else
1e7ed80e 2278 PERL_UNUSED_CONTEXT;
93a8090d
NIS		 2279#endif
2280}
2281
168d5872
NIS		 2282void
2283PerlIOUnix_refcnt_inc(int fd)
2284{
2285 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2286#ifdef USE_THREADS
2287 MUTEX_LOCK(&PerlIO_mutex);
2288#endif
2289 PerlIO_fd_refcnt[fd]++;
2290 PerlIO_debug("fd %d refcnt=%d\n",fd,PerlIO_fd_refcnt[fd]);
2291#ifdef USE_THREADS
2292 MUTEX_UNLOCK(&PerlIO_mutex);
2293#endif
2294 }
2295}
2296
168d5872
NIS		 2297int
2298PerlIOUnix_refcnt_dec(int fd)
2299{
2300 int cnt = 0;
2301 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
2302#ifdef USE_THREADS
2303 MUTEX_LOCK(&PerlIO_mutex);
2304#endif
2305 cnt = --PerlIO_fd_refcnt[fd];
2306 PerlIO_debug("fd %d refcnt=%d\n",fd,cnt);
2307#ifdef USE_THREADS
2308 MUTEX_UNLOCK(&PerlIO_mutex);
2309#endif
2310 }
2311 return cnt;
2312}
2313
694c95cf
JH		 2314void
2315PerlIO_cleanup(pTHX)
2316{
2317 int i;
2318#ifdef USE_ITHREADS
2190c7e7 2319 PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX);
9f4bd222
NIS		 2320#else
2321 PerlIO_debug("Cleanup layers\n");
694c95cf
JH		 2322#endif
2323 /* Raise STDIN..STDERR refcount so we don't close them */
2324 for (i=0; i < 3; i++)
2325 PerlIOUnix_refcnt_inc(i);
2326 PerlIO_cleantable(aTHX_ &PL_perlio);
2327 /* Restore STDIN..STDERR refcount */
2328 for (i=0; i < 3; i++)
2329 PerlIOUnix_refcnt_dec(i);
9f4bd222
NIS		 2330
2331 if (PL_known_layers) {
2332 PerlIO_list_free(aTHX_ PL_known_layers);
2333 PL_known_layers = NULL;
2334 }
cf7b4f3b 2335 if (PL_def_layerlist) {
9f4bd222
NIS		 2336 PerlIO_list_free(aTHX_ PL_def_layerlist);
2337 PL_def_layerlist = NULL;
2338 }
694c95cf
JH		 2339}
2340
2341
2342
9e353e3b 2343/*--------------------------------------------------------------------------------------*/
14a5cf38 2344/*
71200d45 2345 * Bottom-most level for UNIX-like case
14a5cf38 2346 */
9e353e3b 2347
14a5cf38 2348typedef struct {
22569500
NIS		 2349 struct _PerlIO base; /* The generic part */
2350 int fd; /* UNIX like file descriptor */
2351 int oflags; /* open/fcntl flags */
9e353e3b
NIS		 2352} PerlIOUnix;
2353
6f9d8c32 2354int
9e353e3b 2355PerlIOUnix_oflags(const char *mode)
760ac839 2356{
14a5cf38 2357 int oflags = -1;
f3c7dfbe 2358 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
14a5cf38
JH		 2359 mode++;
2360 switch (*mode) {
2361 case 'r':
2362 oflags = O_RDONLY;
2363 if (*++mode == '+') {
2364 oflags = O_RDWR;
2365 mode++;
2366 }
2367 break;
2368
2369 case 'w':
2370 oflags = O_CREAT | O_TRUNC;
2371 if (*++mode == '+') {
2372 oflags |= O_RDWR;
2373 mode++;
2374 }
2375 else
2376 oflags |= O_WRONLY;
2377 break;
2378
2379 case 'a':
2380 oflags = O_CREAT | O_APPEND;
2381 if (*++mode == '+') {
2382 oflags |= O_RDWR;
2383 mode++;
2384 }
2385 else
2386 oflags |= O_WRONLY;
2387 break;
2388 }
2389 if (*mode == 'b') {
2390 oflags |= O_BINARY;
2391 oflags &= ~O_TEXT;
2392 mode++;
2393 }
2394 else if (*mode == 't') {
2395 oflags |= O_TEXT;
2396 oflags &= ~O_BINARY;
2397 mode++;
2398 }
2399 /*
71200d45 2400 * Always open in binary mode
14a5cf38
JH		 2401 */
2402 oflags |= O_BINARY;
2403 if (*mode || oflags == -1) {
93189314 2404 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38
JH		 2405 oflags = -1;
2406 }
2407 return oflags;
9e353e3b
NIS		 2408}
2409
2410IV
f62ce20a 2411PerlIOUnix_fileno(pTHX_ PerlIO *f)
9e353e3b 2412{
1e7ed80e 2413 PERL_UNUSED_CONTEXT;
14a5cf38 2414 return PerlIOSelf(f, PerlIOUnix)->fd;
9e353e3b
NIS		 2415}
2416
0710cc63
JH		 2417static void
2418PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2419{
f1c3982b 2420 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
0710cc63
JH		 2421#if defined(WIN32)
2422 Stat_t st;
2423 if (PerlLIO_fstat(fd, &st) == 0) {
2424 if (!S_ISREG(st.st_mode)) {
2425 PerlIO_debug("%d is not regular file\n",fd);
2426 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2427 }
2428 else {
2429 PerlIO_debug("%d _is_ a regular file\n",fd);
2430 }
2431 }
2432#endif
2433 s->fd = fd;
2434 s->oflags = imode;
2435 PerlIOUnix_refcnt_inc(fd);
1e7ed80e 2436 PERL_UNUSED_CONTEXT;
0710cc63
JH		 2437}
2438
4b803d04 2439IV
2dc2558e 2440PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2441{
2dc2558e 2442 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
14a5cf38 2443 if (*PerlIONext(f)) {
4b069b44 2444 /* We never call down so do any pending stuff now */
03c0554d 2445 PerlIO_flush(PerlIONext(f));
14a5cf38 2446 /*
71200d45 2447 * XXX could (or should) we retrieve the oflags from the open file
14a5cf38 2448 * handle rather than believing the "mode" we are passed in? XXX
71200d45 2449 * Should the value on NULL mode be 0 or -1?
14a5cf38 2450 */
0710cc63
JH		 2451 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2452 mode ? PerlIOUnix_oflags(mode) : -1);
14a5cf38
JH		 2453 }
2454 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
0710cc63 2455
14a5cf38 2456 return code;
4b803d04
NIS		 2457}
2458
f3c7dfbe
JH		 2459IV
2460PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2461{
f1c3982b 2462 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
fdc5445c 2463 Off_t new_loc;
1e7ed80e 2464 PERL_UNUSED_CONTEXT;
f3c7dfbe
JH		 2465 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2466#ifdef ESPIPE
2467 SETERRNO(ESPIPE, LIB_INVARG);
2468#else
2469 SETERRNO(EINVAL, LIB_INVARG);
2470#endif
2471 return -1;
2472 }
fdc5445c
NC		 2473 new_loc = PerlLIO_lseek(fd, offset, whence);
2474 if (new_loc == (Off_t) - 1)
81ec6716 2475 return -1;
f3c7dfbe
JH		 2476 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2477 return 0;
2478}
2479
9e353e3b 2480PerlIO *
14a5cf38
JH		 2481PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2482 IV n, const char *mode, int fd, int imode,
2483 int perm, PerlIO *f, int narg, SV **args)
2484{
d9dac8cd 2485 if (PerlIOValid(f)) {
14a5cf38 2486 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
f62ce20a 2487 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
14a5cf38
JH		 2488 }
2489 if (narg > 0) {
f3c7dfbe 2490 if (*mode == IoTYPE_NUMERIC)
14a5cf38
JH		 2491 mode++;
2492 else {
2493 imode = PerlIOUnix_oflags(mode);
2494 perm = 0666;
2495 }
2496 if (imode != -1) {
c06c673c 2497 const char *path = SvPV_nolen_const(*args);
14a5cf38
JH		 2498 fd = PerlLIO_open3(path, imode, perm);
2499 }
2500 }
2501 if (fd >= 0) {
f3c7dfbe 2502 if (*mode == IoTYPE_IMPLICIT)
14a5cf38
JH		 2503 mode++;
2504 if (!f) {
2505 f = PerlIO_allocate(aTHX);
d9dac8cd
NIS		 2506 }
2507 if (!PerlIOValid(f)) {
a33cf58c
NIS		 2508 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2509 return NULL;
2510 }
d9dac8cd 2511 }
0710cc63 2512 PerlIOUnix_setfd(aTHX_ f, fd, imode);
14a5cf38 2513 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
f3c7dfbe
JH		 2514 if (*mode == IoTYPE_APPEND)
2515 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
14a5cf38
JH		 2516 return f;
2517 }
2518 else {
2519 if (f) {
c9c8c8e1 2520 NOOP;
14a5cf38 2521 /*
71200d45 2522 * FIXME: pop layers ???
14a5cf38
JH		 2523 */
2524 }
2525 return NULL;
2526 }
9e353e3b
NIS		 2527}
2528
71200d45 2529PerlIO *
ecdeb87c 2530PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 2531{
81ec6716 2532 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
93a8090d 2533 int fd = os->fd;
ecdeb87c
NIS		 2534 if (flags & PERLIO_DUP_FD) {
2535 fd = PerlLIO_dup(fd);
2536 }
93a8090d 2537 if (fd >= 0 && fd < PERLIO_MAX_REFCOUNTABLE_FD) {
ecdeb87c 2538 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 2539 if (f) {
2540 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
0710cc63 2541 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
71200d45
NIS		 2542 return f;
2543 }
71200d45
NIS		 2544 }
2545 return NULL;
2546}
2547
2548
9e353e3b 2549SSize_t
f62ce20a 2550PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2551{
f1c3982b 2552 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
cf7b4f3b
JH		 2553#ifdef PERLIO_STD_SPECIAL
2554 if (fd == 0)
2555 return PERLIO_STD_IN(fd, vbuf, count);
2556#endif
81428673 2557 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
1fd8f4ce 2558 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
14a5cf38 2559 return 0;
1fd8f4ce 2560 }
14a5cf38 2561 while (1) {
481da01c 2562 const SSize_t len = PerlLIO_read(fd, vbuf, count);
14a5cf38 2563 if (len >= 0 || errno != EINTR) {
2b5504d2
JH		 2564 if (len < 0) {
2565 if (errno != EAGAIN) {
2566 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2567 }
2568 }
2569 else if (len == 0 && count != 0) {
14a5cf38 2570 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2b5504d2
JH		 2571 SETERRNO(0,0);
2572 }
14a5cf38
JH		 2573 return len;
2574 }
2575 PERL_ASYNC_CHECK();
2576 }
481da01c 2577 /*NOTREACHED*/
9e353e3b
NIS		 2578}
2579
2580SSize_t
f62ce20a 2581PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2582{
f1c3982b 2583 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
cf7b4f3b
JH		 2584#ifdef PERLIO_STD_SPECIAL
2585 if (fd == 1 || fd == 2)
2586 return PERLIO_STD_OUT(fd, vbuf, count);
2587#endif
14a5cf38 2588 while (1) {
f1c3982b 2589 const SSize_t len = PerlLIO_write(fd, vbuf, count);
14a5cf38 2590 if (len >= 0 || errno != EINTR) {
2b5504d2
JH		 2591 if (len < 0) {
2592 if (errno != EAGAIN) {
2593 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2594 }
2595 }
14a5cf38
JH		 2596 return len;
2597 }
2598 PERL_ASYNC_CHECK();
06da4f11 2599 }
ce7d4f40 2600 /*NOTREACHED*/
9e353e3b
NIS		 2601}
2602
9e353e3b 2603Off_t
f62ce20a 2604PerlIOUnix_tell(pTHX_ PerlIO *f)
9e353e3b 2605{
1e7ed80e
AL		 2606 PERL_UNUSED_CONTEXT;
2607
14a5cf38 2608 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
9e353e3b
NIS		 2609}
2610
71200d45 2611
9e353e3b 2612IV
f62ce20a 2613PerlIOUnix_close(pTHX_ PerlIO *f)
9e353e3b 2614{
f1c3982b 2615 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
14a5cf38 2616 int code = 0;
168d5872
NIS		 2617 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2618 if (PerlIOUnix_refcnt_dec(fd) > 0) {
93a8090d
NIS		 2619 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2620 return 0;
22569500 2621 }
93a8090d
NIS		 2622 }
2623 else {
93189314 2624 SETERRNO(EBADF,SS_IVCHAN);
93a8090d
NIS		 2625 return -1;
2626 }
14a5cf38
JH		 2627 while (PerlLIO_close(fd) != 0) {
2628 if (errno != EINTR) {
2629 code = -1;
2630 break;
2631 }
2632 PERL_ASYNC_CHECK();
2633 }
2634 if (code == 0) {
2635 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2636 }
2637 return code;
9e353e3b
NIS		 2638}
2639
cf7b4f3b 2640PERLIO_FUNCS_DECL(PerlIO_unix) = {
2dc2558e 2641 sizeof(PerlIO_funcs),
14a5cf38
JH		 2642 "unix",
2643 sizeof(PerlIOUnix),
2644 PERLIO_K_RAW,
2645 PerlIOUnix_pushed,
44798d05 2646 PerlIOBase_popped,
14a5cf38 2647 PerlIOUnix_open,
86e05cf2 2648 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 2649 NULL,
2650 PerlIOUnix_fileno,
71200d45 2651 PerlIOUnix_dup,
14a5cf38
JH		 2652 PerlIOUnix_read,
2653 PerlIOBase_unread,
2654 PerlIOUnix_write,
2655 PerlIOUnix_seek,
2656 PerlIOUnix_tell,
2657 PerlIOUnix_close,
22569500
NIS		 2658 PerlIOBase_noop_ok, /* flush */
2659 PerlIOBase_noop_fail, /* fill */
14a5cf38
JH		 2660 PerlIOBase_eof,
2661 PerlIOBase_error,
2662 PerlIOBase_clearerr,
2663 PerlIOBase_setlinebuf,
22569500
NIS		 2664 NULL, /* get_base */
2665 NULL, /* get_bufsiz */
2666 NULL, /* get_ptr */
2667 NULL, /* get_cnt */
2668 NULL, /* set_ptrcnt */
9e353e3b
NIS		 2669};
2670
2671/*--------------------------------------------------------------------------------------*/
14a5cf38 2672/*
71200d45 2673 * stdio as a layer
14a5cf38 2674 */
9e353e3b 2675
313e59c8
NIS		 2676#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2677/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2678 broken by the last second glibc 2.3 fix
2679 */
2680#define STDIO_BUFFER_WRITABLE
2681#endif
2682
2683
14a5cf38
JH		 2684typedef struct {
2685 struct _PerlIO base;
22569500 2686 FILE *stdio; /* The stream */
9e353e3b
NIS		 2687} PerlIOStdio;
2688
2689IV
f62ce20a 2690PerlIOStdio_fileno(pTHX_ PerlIO *f)
9e353e3b 2691{
1e7ed80e
AL		 2692 PERL_UNUSED_CONTEXT;
2693
81ec6716
AL		 2694 if (PerlIOValid(f)) {
2695 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2696 if (s)
2697 return PerlSIO_fileno(s);
439ba545
NIS		 2698 }
2699 errno = EBADF;
2700 return -1;
9e353e3b
NIS		 2701}
2702
766a733e 2703char *
14a5cf38
JH		 2704PerlIOStdio_mode(const char *mode, char *tmode)
2705{
f1c3982b 2706 char * const ret = tmode;
c6d8632b
SR		 2707 if (mode) {
2708 while (*mode) {
2709 *tmode++ = *mode++;
2710 }
14a5cf38 2711 }
b497ec0e 2712#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
6ce75a77
JH		 2713 *tmode++ = 'b';
2714#endif
14a5cf38
JH		 2715 *tmode = '\0';
2716 return ret;
2717}
2718
4b803d04 2719IV
2dc2558e 2720PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4b803d04 2721{
1fd8f4ce
NIS		 2722 PerlIO *n;
2723 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
217ef1d7 2724 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
1fd8f4ce
NIS		 2725 if (toptab == tab) {
2726 /* Top is already stdio - pop self (duplicate) and use original */
2727 PerlIO_pop(aTHX_ f);
2728 return 0;
2729 } else {
f1c3982b 2730 const int fd = PerlIO_fileno(n);
1fd8f4ce
NIS		 2731 char tmode[8];
2732 FILE *stdio;
81428673 2733 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
1fd8f4ce
NIS		 2734 mode = PerlIOStdio_mode(mode, tmode)))) {
2735 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2736 /* We never call down so do any pending stuff now */
2737 PerlIO_flush(PerlIONext(f));
81428673 2738 }
1fd8f4ce
NIS		 2739 else {
2740 return -1;
2741 }
2742 }
14a5cf38 2743 }
2dc2558e 2744 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4b803d04
NIS		 2745}
2746
22569500 2747
9e353e3b 2748PerlIO *
4b069b44 2749PerlIO_importFILE(FILE *stdio, const char *mode)
9e353e3b 2750{
14a5cf38
JH		 2751 dTHX;
2752 PerlIO *f = NULL;
2753 if (stdio) {
22569500 2754 PerlIOStdio *s;
4b069b44
NIS		 2755 if (!mode || !*mode) {
2756 /* We need to probe to see how we can open the stream
2757 so start with read/write and then try write and read
2758 we dup() so that we can fclose without loosing the fd.
2759
2760 Note that the errno value set by a failing fdopen
2761 varies between stdio implementations.
2762 */
f1c3982b 2763 const int fd = PerlLIO_dup(fileno(stdio));
a33cf58c 2764 FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
4b069b44 2765 if (!f2) {
a33cf58c 2766 f2 = PerlSIO_fdopen(fd, (mode = "w"));
4b069b44
NIS		 2767 }
2768 if (!f2) {
a33cf58c 2769 f2 = PerlSIO_fdopen(fd, (mode = "r"));
4b069b44
NIS		 2770 }
2771 if (!f2) {
2772 /* Don't seem to be able to open */
2773 PerlLIO_close(fd);
2774 return f;
2775 }
2776 fclose(f2);
22569500 2777 }
0e2d6244 2778 if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
a33cf58c
NIS		 2779 s = PerlIOSelf(f, PerlIOStdio);
2780 s->stdio = stdio;
2781 }
14a5cf38
JH		 2782 }
2783 return f;
9e353e3b
NIS		 2784}
2785
2786PerlIO *
14a5cf38
JH		 2787PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2788 IV n, const char *mode, int fd, int imode,
2789 int perm, PerlIO *f, int narg, SV **args)
2790{
2791 char tmode[8];
d9dac8cd 2792 if (PerlIOValid(f)) {
81ec6716
AL		 2793 const char * const path = SvPV_nolen_const(*args);
2794 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS		 2795 FILE *stdio;
2796 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2797 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH		 2798 s->stdio);
2799 if (!s->stdio)
2800 return NULL;
2801 s->stdio = stdio;
1751d015 2802 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH		 2803 return f;
2804 }
2805 else {
2806 if (narg > 0) {
81ec6716 2807 const char * const path = SvPV_nolen_const(*args);
f3c7dfbe 2808 if (*mode == IoTYPE_NUMERIC) {
14a5cf38
JH		 2809 mode++;
2810 fd = PerlLIO_open3(path, imode, perm);
2811 }
2812 else {
b497ec0e
GH		 2813 FILE *stdio;
2814 bool appended = FALSE;
2815#ifdef __CYGWIN__
2816 /* Cygwin wants its 'b' early. */
2817 appended = TRUE;
2818 mode = PerlIOStdio_mode(mode, tmode);
2819#endif
2820 stdio = PerlSIO_fopen(path, mode);
ca60f64c 2821 if (stdio) {
ca60f64c
JH		 2822 if (!f) {
2823 f = PerlIO_allocate(aTHX);
2824 }
b497ec0e
GH		 2825 if (!appended)
2826 mode = PerlIOStdio_mode(mode, tmode);
2827 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
2828 if (f) {
eb527b6b
NC		 2829 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2830 PerlIOUnix_refcnt_inc(fileno(stdio));
2831 } else {
2832 PerlSIO_fclose(stdio);
ca60f64c
JH		 2833 }
2834 return f;
2835 }
2836 else {
2837 return NULL;
2838 }
14a5cf38
JH		 2839 }
2840 }
2841 if (fd >= 0) {
2842 FILE *stdio = NULL;
2843 int init = 0;
f3c7dfbe 2844 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 2845 init = 1;
2846 mode++;
2847 }
2848 if (init) {
2849 switch (fd) {
2850 case 0:
2851 stdio = PerlSIO_stdin;
2852 break;
2853 case 1:
2854 stdio = PerlSIO_stdout;
2855 break;
2856 case 2:
2857 stdio = PerlSIO_stderr;
2858 break;
2859 }
2860 }
2861 else {
2862 stdio = PerlSIO_fdopen(fd, mode =
2863 PerlIOStdio_mode(mode, tmode));
2864 }
2865 if (stdio) {
d9dac8cd
NIS		 2866 if (!f) {
2867 f = PerlIO_allocate(aTHX);
2868 }
a33cf58c 2869 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
550aaea5
NC		 2870 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2871 PerlIOUnix_refcnt_inc(fileno(stdio));
a33cf58c 2872 }
14a5cf38
JH		 2873 return f;
2874 }
2875 }
2876 }
ee518936 2877 return NULL;
9e353e3b
NIS		 2878}
2879
1751d015 2880PerlIO *
ecdeb87c 2881PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS		 2882{
2883 /* This assumes no layers underneath - which is what
2884 happens, but is not how I remember it. NI-S 2001/10/16
2885 */
ecdeb87c 2886 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 2887 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
f1c3982b 2888 const int fd = fileno(stdio);
763da913 2889 char mode[8];
ecdeb87c 2890 if (flags & PERLIO_DUP_FD) {
f1c3982b 2891 const int dfd = PerlLIO_dup(fileno(stdio));
763da913
NIS		 2892 if (dfd >= 0) {
2893 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
2894 goto set_this;
ecdeb87c
NIS		 2895 }
2896 else {
c9c8c8e1 2897 NOOP;
ecdeb87c
NIS		 2898 /* FIXME: To avoid messy error recovery if dup fails
2899 re-use the existing stdio as though flag was not set
2900 */
2901 }
2902 }
763da913
NIS		 2903 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
2904 set_this:
694c95cf
JH		 2905 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2906 PerlIOUnix_refcnt_inc(fileno(stdio));
1751d015
NIS		 2907 }
2908 return f;
2909}
2910
338501c1
JH		 2911static int
2912PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
2913{
1e7ed80e
AL		 2914 PERL_UNUSED_CONTEXT;
2915
338501c1 2916 /* XXX this could use PerlIO_canset_fileno() and
0710cc63 2917 * PerlIO_set_fileno() support from Configure
338501c1 2918 */
5d5a1cff
AT		 2919# if defined(__UCLIBC__)
2920 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
2921 f->__filedes = -1;
2922 return 1;
2923# elif defined(__GLIBC__)
338501c1 2924 /* There may be a better way for GLIBC:
0710cc63 2925 - libio.h defines a flag to not close() on cleanup
338501c1
JH		 2926 */
2927 f->_fileno = -1;
2928 return 1;
2929# elif defined(__sun__)
481ddcff 2930 PERL_UNUSED_ARG(f);
550aaea5 2931 return 0;
338501c1
JH		 2932# elif defined(__hpux)
2933 f->__fileH = 0xff;
2934 f->__fileL = 0xff;
2935 return 1;
2936 /* Next one ->_file seems to be a reasonable fallback, i.e. if
0710cc63 2937 your platform does not have special entry try this one.
338501c1
JH		 2938 [For OSF only have confirmation for Tru64 (alpha)
2939 but assume other OSFs will be similar.]
0710cc63 2940 */
338501c1
JH		 2941# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
2942 f->_file = -1;
2943 return 1;
2944# elif defined(__FreeBSD__)
2945 /* There may be a better way on FreeBSD:
0710cc63
JH		 2946 - we could insert a dummy func in the _close function entry
2947 f->_close = (int (*)(void *)) dummy_close;
338501c1
JH		 2948 */
2949 f->_file = -1;
304e8f30
NC		 2950 return 1;
2951# elif defined(__OpenBSD__)
2952 /* There may be a better way on OpenBSD:
2953 - we could insert a dummy func in the _close function entry
2954 f->_close = (int (*)(void *)) dummy_close;
2955 */
2956 f->_file = -1;
338501c1 2957 return 1;
17999b1c
IZ		 2958# elif defined(__EMX__)
2959 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
2960 f->_handle = -1;
2961 return 1;
338501c1
JH		 2962# elif defined(__CYGWIN__)
2963 /* There may be a better way on CYGWIN:
0710cc63
JH		 2964 - we could insert a dummy func in the _close function entry
2965 f->_close = (int (*)(void *)) dummy_close;
338501c1
JH		 2966 */
2967 f->_file = -1;
2968 return 1;
2969# elif defined(WIN32)
2970# if defined(__BORLANDC__)
2971 f->fd = PerlLIO_dup(fileno(f));
511118e1
JH		 2972# elif defined(UNDER_CE)
2973 /* WIN_CE does not have access to FILE internals, it hardly has FILE
2974 structure at all
2975 */
338501c1
JH		 2976# else
2977 f->_file = -1;
2978# endif
2979 return 1;
2980# else
2981#if 0
0710cc63 2982 /* Sarathy's code did this - we fall back to a dup/dup2 hack
338501c1 2983 (which isn't thread safe) instead
0710cc63 2984 */
338501c1
JH		 2985# error "Don't know how to set FILE.fileno on your platform"
2986#endif
4f1e9d25 2987 PERL_UNUSED_ARG(f);
338501c1
JH		 2988 return 0;
2989# endif
2990}
2991
1751d015 2992IV
f62ce20a 2993PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 2994{
81ec6716 2995 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
439ba545
NIS		 2996 if (!stdio) {
2997 errno = EBADF;
2998 return -1;
2999 }
763da913 3000 else {
f1c3982b 3001 const int fd = fileno(stdio);
338501c1
JH		 3002 int invalidate = 0;
3003 IV result = 0;
3004 int saveerr = 0;
3005 int dupfd = 0;
3006#ifdef SOCKS5_VERSION_NAME
0710cc63
JH		 3007 /* Socks lib overrides close() but stdio isn't linked to
3008 that library (though we are) - so we must call close()
3009 on sockets on stdio's behalf.
3010 */
338501c1
JH		 3011 int optval;
3012 Sock_size_t optlen = sizeof(int);
550aaea5 3013 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
0710cc63 3014 invalidate = 1;
338501c1 3015#endif
550aaea5 3016 if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */
338501c1 3017 invalidate = 1;
338501c1 3018 if (invalidate) {
550aaea5
NC		 3019 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3020 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3021 return 0;
3022 if (stdio == stdout || stdio == stderr)
3023 return PerlIO_flush(f);
0710cc63
JH		 3024 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3025 Use Sarathy's trick from maint-5.6 to invalidate the
3026 fileno slot of the FILE *
3027 */
338501c1
JH		 3028 result = PerlIO_flush(f);
3029 saveerr = errno;
550aaea5
NC		 3030 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3031 if (!invalidate)
3032 dupfd = PerlLIO_dup(fd);
0710cc63 3033 }
338501c1 3034 result = PerlSIO_fclose(stdio);
0710cc63
JH		 3035 /* We treat error from stdio as success if we invalidated
3036 errno may NOT be expected EBADF
338501c1
JH		 3037 */
3038 if (invalidate && result != 0) {
3039 errno = saveerr;
3040 result = 0;
0710cc63 3041 }
550aaea5
NC		 3042#ifdef SOCKS5_VERSION_NAME
3043 /* in SOCKS' case, let close() determine return value */
3044 result = close(fd);
3045#endif
338501c1
JH		 3046 if (dupfd) {
3047 PerlLIO_dup2(dupfd,fd);
c89468fe 3048 PerlLIO_close(dupfd);
763da913
NIS		 3049 }
3050 return result;
0710cc63 3051 }
1751d015
NIS		 3052}
3053
9e353e3b 3054SSize_t
f62ce20a 3055PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 3056{
81ec6716 3057 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3058 SSize_t got = 0;
338501c1
JH		 3059 for (;;) {
3060 if (count == 1) {
3061 STDCHAR *buf = (STDCHAR *) vbuf;
3062 /*
3063 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3064 * stdio does not do that for fread()
3065 */
f1c3982b 3066 const int ch = PerlSIO_fgetc(s);
338501c1
JH		 3067 if (ch != EOF) {
3068 *buf = ch;
3069 got = 1;
3070 }
14a5cf38 3071 }
338501c1
JH		 3072 else
3073 got = PerlSIO_fread(vbuf, 1, count, s);
f8818d10
JH		 3074 if (got == 0 && PerlSIO_ferror(s))
3075 got = -1;
2b5504d2 3076 if (got >= 0 || errno != EINTR)
338501c1
JH		 3077 break;
3078 PERL_ASYNC_CHECK();
2b5504d2 3079 SETERRNO(0,0); /* just in case */
14a5cf38 3080 }
14a5cf38 3081 return got;
9e353e3b
NIS		 3082}
3083
3084SSize_t
f62ce20a 3085PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3086{
14a5cf38 3087 SSize_t unread = 0;
81ec6716 3088 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3089
313e59c8 3090#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3091 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3092 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3093 STDCHAR *base = PerlIO_get_base(f);
3094 SSize_t cnt = PerlIO_get_cnt(f);
3095 STDCHAR *ptr = PerlIO_get_ptr(f);
3096 SSize_t avail = ptr - base;
3097 if (avail > 0) {
3098 if (avail > count) {
3099 avail = count;
3100 }
3101 ptr -= avail;
3102 Move(buf-avail,ptr,avail,STDCHAR);
3103 count -= avail;
3104 unread += avail;
3105 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
9f7cd136
NIS		 3106 if (PerlSIO_feof(s) && unread >= 0)
3107 PerlSIO_clearerr(s);
3108 }
3109 }
313e59c8
NIS		 3110 else
3111#endif
3112 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3113 /* We can get pointer to buffer but not its base
3114 Do ungetc() but check chars are ending up in the
3115 buffer
3116 */
3117 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3118 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3119 while (count > 0) {
f1c3982b 3120 const int ch = *--buf & 0xFF;
9f7cd136
NIS		 3121 if (ungetc(ch,s) != ch) {
3122 /* ungetc did not work */
3123 break;
3124 }
3125 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3126 /* Did not change pointer as expected */
3127 fgetc(s); /* get char back again */
3128 break;
3129 }
3130 /* It worked ! */
3131 count--;
3132 unread++;
93679785
NIS		 3133 }
3134 }
3135
3136 if (count > 0) {
3137 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 3138 }
3139 return unread;
9e353e3b
NIS		 3140}
3141
3142SSize_t
f62ce20a 3143PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 3144{
338501c1
JH		 3145 SSize_t got;
3146 for (;;) {
3147 got = PerlSIO_fwrite(vbuf, 1, count,
3148 PerlIOSelf(f, PerlIOStdio)->stdio);
2b5504d2 3149 if (got >= 0 || errno != EINTR)
338501c1
JH		 3150 break;
3151 PERL_ASYNC_CHECK();
2b5504d2 3152 SETERRNO(0,0); /* just in case */
338501c1
JH		 3153 }
3154 return got;
9e353e3b
NIS		 3155}
3156
3157IV
f62ce20a 3158PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3159{
81ec6716 3160 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
1e7ed80e
AL		 3161 PERL_UNUSED_CONTEXT;
3162
14a5cf38 3163 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS		 3164}
3165
3166Off_t
f62ce20a 3167PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 3168{
81ec6716 3169 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
1e7ed80e
AL		 3170 PERL_UNUSED_CONTEXT;
3171
14a5cf38 3172 return PerlSIO_ftell(stdio);
9e353e3b
NIS		 3173}
3174
3175IV
f62ce20a 3176PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 3177{
81ec6716 3178 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
1e7ed80e
AL		 3179 PERL_UNUSED_CONTEXT;
3180
14a5cf38
JH		 3181 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3182 return PerlSIO_fflush(stdio);
3183 }
3184 else {
c9c8c8e1 3185 NOOP;
88b61e10 3186#if 0
14a5cf38
JH		 3187 /*
3188 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 3189 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 3190 * design is to do _this_ but not have layer above flush this
71200d45 3191 * layer read-to-read
14a5cf38
JH		 3192 */
3193 /*
71200d45 3194 * Not writeable - sync by attempting a seek
14a5cf38 3195 */
88070769 3196 const int err = errno;
14a5cf38
JH		 3197 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3198 errno = err;
88b61e10 3199#endif
14a5cf38
JH		 3200 }
3201 return 0;
9e353e3b
NIS		 3202}
3203
3204IV
f62ce20a 3205PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 3206{
1e7ed80e
AL		 3207 PERL_UNUSED_CONTEXT;
3208
14a5cf38 3209 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3210}
3211
3212IV
f62ce20a 3213PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 3214{
1e7ed80e
AL		 3215 PERL_UNUSED_CONTEXT;
3216
14a5cf38 3217 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3218}
3219
3220void
f62ce20a 3221PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 3222{
1e7ed80e
AL		 3223 PERL_UNUSED_CONTEXT;
3224
14a5cf38 3225 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 3226}
3227
3228void
f62ce20a 3229PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b 3230{
1e7ed80e
AL		 3231 PERL_UNUSED_CONTEXT;
3232
9e353e3b 3233#ifdef HAS_SETLINEBUF
14a5cf38 3234 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 3235#else
0e2d6244 3236 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
9e353e3b
NIS		 3237#endif
3238}
3239
3240#ifdef FILE_base
3241STDCHAR *
f62ce20a 3242PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 3243{
81ec6716 3244 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3245 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS		 3246}
3247
3248Size_t
f62ce20a 3249PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3250{
81ec6716 3251 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3252 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS		 3253}
3254#endif
3255
3256#ifdef USE_STDIO_PTR
3257STDCHAR *
f62ce20a 3258PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3259{
81ec6716 3260 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 3261 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS		 3262}
3263
3264SSize_t
f62ce20a 3265PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3266{
81ec6716 3267 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3268 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS		 3269}
3270
3271void
f62ce20a 3272PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3273{
81ec6716 3274 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 3275 if (ptr != NULL) {
9e353e3b 3276#ifdef STDIO_PTR_LVALUE
22569500 3277 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
9e353e3b 3278#ifdef STDIO_PTR_LVAL_SETS_CNT
14a5cf38 3279 if (PerlSIO_get_cnt(stdio) != (cnt)) {
14a5cf38
JH		 3280 assert(PerlSIO_get_cnt(stdio) == (cnt));
3281 }
9e353e3b
NIS		 3282#endif
3283#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 3284 /*
71200d45 3285 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH		 3286 */
3287 return;
9e353e3b 3288#endif
22569500 3289#else /* STDIO_PTR_LVALUE */
14a5cf38 3290 PerlProc_abort();
22569500 3291#endif /* STDIO_PTR_LVALUE */
14a5cf38
JH		 3292 }
3293 /*
71200d45 3294 * Now (or only) set cnt
14a5cf38 3295 */
9e353e3b 3296#ifdef STDIO_CNT_LVALUE
14a5cf38 3297 PerlSIO_set_cnt(stdio, cnt);
22569500 3298#else /* STDIO_CNT_LVALUE */
9e353e3b 3299#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH		 3300 PerlSIO_set_ptr(stdio,
3301 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3302 cnt));
22569500 3303#else /* STDIO_PTR_LVAL_SETS_CNT */
14a5cf38 3304 PerlProc_abort();
22569500
NIS		 3305#endif /* STDIO_PTR_LVAL_SETS_CNT */
3306#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS		 3307}
3308
93679785 3309
9e353e3b
NIS		 3310#endif
3311
93679785
NIS		 3312IV
3313PerlIOStdio_fill(pTHX_ PerlIO *f)
3314{
81ec6716 3315 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
93679785 3316 int c;
1e7ed80e
AL		 3317 PERL_UNUSED_CONTEXT;
3318
93679785
NIS		 3319 /*
3320 * fflush()ing read-only streams can cause trouble on some stdio-s
3321 */
3322 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3323 if (PerlSIO_fflush(stdio) != 0)
3324 return EOF;
3325 }
3326 c = PerlSIO_fgetc(stdio);
3327 if (c == EOF)
3328 return EOF;
3329
3330#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
313e59c8
NIS		 3331
3332#ifdef STDIO_BUFFER_WRITABLE
9f7cd136 3333 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
93679785
NIS		 3334 /* Fake ungetc() to the real buffer in case system's ungetc
3335 goes elsewhere
3336 */
3337 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3338 SSize_t cnt = PerlSIO_get_cnt(stdio);
3339 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3340 if (ptr == base+1) {
3341 *--ptr = (STDCHAR) c;
3342 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3343 if (PerlSIO_feof(stdio))
3344 PerlSIO_clearerr(stdio);
3345 return 0;
3346 }
3347 }
313e59c8
NIS		 3348 else
3349#endif
3350 if (PerlIO_has_cntptr(f)) {
9f7cd136
NIS		 3351 STDCHAR ch = c;
3352 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3353 return 0;
3354 }
3355 }
93679785
NIS		 3356#endif
3357
3358#if defined(VMS)
3359 /* An ungetc()d char is handled separately from the regular
3360 * buffer, so we stuff it in the buffer ourselves.
3361 * Should never get called as should hit code above
3362 */
bad9695d
NIS		 3363 *(--((*stdio)->_ptr)) = (unsigned char) c;
3364 (*stdio)->_cnt++;
93679785
NIS		 3365#else
3366 /* If buffer snoop scheme above fails fall back to
9f7cd136 3367 using ungetc().
93679785
NIS		 3368 */
3369 if (PerlSIO_ungetc(c, stdio) != c)
3370 return EOF;
3371#endif
3372 return 0;
3373}
3374
3375
3376
cf7b4f3b 3377PERLIO_FUNCS_DECL(PerlIO_stdio) = {
2dc2558e 3378 sizeof(PerlIO_funcs),
14a5cf38
JH		 3379 "stdio",
3380 sizeof(PerlIOStdio),
86e05cf2 3381 PERLIO_K_BUFFERED|PERLIO_K_RAW,
1fd8f4ce 3382 PerlIOStdio_pushed,
44798d05 3383 PerlIOBase_popped,
14a5cf38 3384 PerlIOStdio_open,
86e05cf2 3385 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 3386 NULL,
3387 PerlIOStdio_fileno,
71200d45 3388 PerlIOStdio_dup,
14a5cf38
JH		 3389 PerlIOStdio_read,
3390 PerlIOStdio_unread,
3391 PerlIOStdio_write,
3392 PerlIOStdio_seek,
3393 PerlIOStdio_tell,
3394 PerlIOStdio_close,
3395 PerlIOStdio_flush,
3396 PerlIOStdio_fill,
3397 PerlIOStdio_eof,
3398 PerlIOStdio_error,
3399 PerlIOStdio_clearerr,
3400 PerlIOStdio_setlinebuf,
9e353e3b 3401#ifdef FILE_base
14a5cf38
JH		 3402 PerlIOStdio_get_base,
3403 PerlIOStdio_get_bufsiz,
9e353e3b 3404#else
14a5cf38
JH		 3405 NULL,
3406 NULL,
9e353e3b
NIS		 3407#endif
3408#ifdef USE_STDIO_PTR
14a5cf38
JH		 3409 PerlIOStdio_get_ptr,
3410 PerlIOStdio_get_cnt,
ff0950a8 3411# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
4376702e 3412 PerlIOStdio_set_ptrcnt,
ff0950a8
JH		 3413# else
3414 NULL,
3415# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3416#else
3417 NULL,
14a5cf38
JH		 3418 NULL,
3419 NULL,
ff0950a8 3420#endif /* USE_STDIO_PTR */
9e353e3b
NIS		 3421};
3422
b9d6bf13
JH		 3423/* Note that calls to PerlIO_exportFILE() are reversed using
3424 * PerlIO_releaseFILE(), not importFILE. */
9e353e3b 3425FILE *
81428673 3426PerlIO_exportFILE(PerlIO * f, const char *mode)
9e353e3b 3427{
e87a358a 3428 dTHX;
81428673
NIS		 3429 FILE *stdio = NULL;
3430 if (PerlIOValid(f)) {
3431 char buf[8];
3432 PerlIO_flush(f);
3433 if (!mode || !*mode) {
3434 mode = PerlIO_modestr(f, buf);
3435 }
3436 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3437 if (stdio) {
3438 PerlIOl *l = *f;
f824e39a 3439 PerlIO *f2;
81428673
NIS		 3440 /* De-link any lower layers so new :stdio sticks */
3441 *f = NULL;
0e2d6244 3442 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
f824e39a 3443 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
81428673
NIS		 3444 s->stdio = stdio;
3445 /* Link previous lower layers under new one */
3446 *PerlIONext(f) = l;
3447 }
3448 else {
3449 /* restore layers list */
3450 *f = l;
3451 }
a33cf58c 3452 }
14a5cf38
JH		 3453 }
3454 return stdio;
9e353e3b
NIS		 3455}
3456
81428673 3457
9e353e3b
NIS		 3458FILE *
3459PerlIO_findFILE(PerlIO *f)
3460{
14a5cf38
JH		 3461 PerlIOl *l = *f;
3462 while (l) {
3463 if (l->tab == &PerlIO_stdio) {
3464 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3465 return s->stdio;
3466 }
3467 l = *PerlIONext(&l);
f7e7eb72 3468 }
4b069b44 3469 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
0e2d6244 3470 return PerlIO_exportFILE(f, NULL);
9e353e3b
NIS		 3471}
3472
b9d6bf13 3473/* Use this to reverse PerlIO_exportFILE calls. */
9e353e3b
NIS		 3474void
3475PerlIO_releaseFILE(PerlIO *p, FILE *f)
3476{
22569500
NIS		 3477 PerlIOl *l;
3478 while ((l = *p)) {
3479 if (l->tab == &PerlIO_stdio) {
3480 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3481 if (s->stdio == f) {
3482 dTHX;
3483 PerlIO_pop(aTHX_ p);
3484 return;
3485 }
3486 }
3487 p = PerlIONext(p);
3488 }
3489 return;
9e353e3b
NIS		 3490}
3491
3492/*--------------------------------------------------------------------------------------*/
14a5cf38 3493/*
71200d45 3494 * perlio buffer layer
14a5cf38 3495 */
9e353e3b 3496
5e2ab84b 3497IV
2dc2558e 3498PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 3499{
14a5cf38 3500 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
f1c3982b 3501 const int fd = PerlIO_fileno(f);
14a5cf38
JH		 3502 if (fd >= 0 && PerlLIO_isatty(fd)) {
3503 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3504 }
4b069b44 3505 if (*PerlIONext(f)) {
f1c3982b 3506 const Off_t posn = PerlIO_tell(PerlIONext(f));
4b069b44
NIS		 3507 if (posn != (Off_t) - 1) {
3508 b->posn = posn;
3509 }
14a5cf38 3510 }
2dc2558e 3511 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b
NIS		 3512}
3513
9e353e3b 3514PerlIO *
14a5cf38
JH		 3515PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3516 IV n, const char *mode, int fd, int imode, int perm,
3517 PerlIO *f, int narg, SV **args)
3518{
04892f78 3519 if (PerlIOValid(f)) {
14a5cf38 3520 PerlIO *next = PerlIONext(f);
67bae6b3
JH		 3521 PerlIO_funcs *tab =
3522 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3523 if (tab && tab->Open)
3524 next =
3525 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3526 next, narg, args);
2dc2558e 3527 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
14a5cf38
JH		 3528 return NULL;
3529 }
3530 }
3531 else {
04892f78 3532 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38 3533 int init = 0;
f3c7dfbe 3534 if (*mode == IoTYPE_IMPLICIT) {
14a5cf38
JH		 3535 init = 1;
3536 /*
71200d45 3537 * mode++;
14a5cf38
JH		 3538 */
3539 }
67bae6b3
JH		 3540 if (tab && tab->Open)
3541 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3542 f, narg, args);
3543 else
3544 SETERRNO(EINVAL, LIB_INVARG);
14a5cf38 3545 if (f) {
22569500 3546 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
b26b1ab5
NC		 3547 /*
3548 * if push fails during open, open fails. close will pop us.
3549 */
3550 PerlIO_close (f);
3551 return NULL;
3552 } else {
3553 fd = PerlIO_fileno(f);
b26b1ab5
NC		 3554 if (init && fd == 2) {
3555 /*
3556 * Initial stderr is unbuffered
3557 */
3558 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3559 }
23b84778
IZ		 3560#ifdef PERLIO_USING_CRLF
3561# ifdef PERLIO_IS_BINMODE_FD
3562 if (PERLIO_IS_BINMODE_FD(fd))
0e2d6244 3563 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
23b84778
IZ		 3564 else
3565# endif
3566 /*
3567 * do something about failing setmode()? --jhi
3568 */
3569 PerlLIO_setmode(fd, O_BINARY);
3570#endif
14a5cf38
JH		 3571 }
3572 }
ee518936 3573 }
14a5cf38 3574 return f;
9e353e3b
NIS		 3575}
3576
14a5cf38
JH		 3577/*
3578 * This "flush" is akin to sfio's sync in that it handles files in either
4cd59068
NC		 3579 * read or write state. For write state, we put the postponed data through
3580 * the next layers. For read state, we seek() the next layers to the
3581 * offset given by current position in the buffer, and discard the buffer
3582 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3583 * in any case?). Then the pass the stick further in chain.
14a5cf38 3584 */
9e353e3b 3585IV
f62ce20a 3586PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 3587{
81ec6716 3588 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3589 int code = 0;
04892f78 3590 PerlIO *n = PerlIONext(f);
14a5cf38
JH		 3591 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3592 /*
71200d45 3593 * write() the buffer
14a5cf38 3594 */
f1c3982b
NC		 3595 const STDCHAR *buf = b->buf;
3596 const STDCHAR *p = buf;
14a5cf38
JH		 3597 while (p < b->ptr) {
3598 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3599 if (count > 0) {
3600 p += count;
3601 }
3602 else if (count < 0 || PerlIO_error(n)) {
3603 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3604 code = -1;
3605 break;
3606 }
3607 }
3608 b->posn += (p - buf);
3609 }
3610 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3611 STDCHAR *buf = PerlIO_get_base(f);
3612 /*
71200d45 3613 * Note position change
14a5cf38
JH		 3614 */
3615 b->posn += (b->ptr - buf);
3616 if (b->ptr < b->end) {
4b069b44
NIS		 3617 /* We did not consume all of it - try and seek downstream to
3618 our logical position
14a5cf38 3619 */
4b069b44 3620 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
04892f78
NIS		 3621 /* Reload n as some layers may pop themselves on seek */
3622 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38 3623 }
ba5c3fe9 3624 else {
4b069b44
NIS		 3625 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3626 data is lost for good - so return saying "ok" having undone
3627 the position adjust
3628 */
3629 b->posn -= (b->ptr - buf);
ba5c3fe9
NIS		 3630 return code;
3631 }
14a5cf38
JH		 3632 }
3633 }
3634 b->ptr = b->end = b->buf;
3635 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78 3636 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
04892f78 3637 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH		 3638 code = -1;
3639 return code;
6f9d8c32
NIS		 3640}
3641
4cd59068
NC		 3642/* This discards the content of the buffer after b->ptr, and rereads
3643 * the buffer from the position off in the layer downstream; here off
3644 * is at offset corresponding to b->ptr - b->buf.
3645 */
06da4f11 3646IV
f62ce20a 3647PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 3648{
81ec6716 3649 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3650 PerlIO *n = PerlIONext(f);
3651 SSize_t avail;
3652 /*
4b069b44
NIS		 3653 * Down-stream flush is defined not to loose read data so is harmless.
3654 * we would not normally be fill'ing if there was data left in anycase.
14a5cf38 3655 */
4cd59068 3656 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
14a5cf38
JH		 3657 return -1;
3658 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
f62ce20a 3659 PerlIOBase_flush_linebuf(aTHX);
14a5cf38
JH		 3660
3661 if (!b->buf)
22569500 3662 PerlIO_get_base(f); /* allocate via vtable */
14a5cf38 3663
550aaea5
NC		 3664 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
3665
14a5cf38 3666 b->ptr = b->end = b->buf;
4b069b44
NIS		 3667
3668 if (!PerlIOValid(n)) {
3669 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3670 return -1;
3671 }
3672
14a5cf38
JH		 3673 if (PerlIO_fast_gets(n)) {
3674 /*
04892f78 3675 * Layer below is also buffered. We do _NOT_ want to call its
14a5cf38
JH		 3676 * ->Read() because that will loop till it gets what we asked for
3677 * which may hang on a pipe etc. Instead take anything it has to
71200d45 3678 * hand, or ask it to fill _once_.
14a5cf38
JH		 3679 */
3680 avail = PerlIO_get_cnt(n);
3681 if (avail <= 0) {
3682 avail = PerlIO_fill(n);
3683 if (avail == 0)
3684 avail = PerlIO_get_cnt(n);
3685 else {
3686 if (!PerlIO_error(n) && PerlIO_eof(n))
3687 avail = 0;
3688 }
3689 }
3690 if (avail > 0) {
3691 STDCHAR *ptr = PerlIO_get_ptr(n);
81ec6716 3692 const SSize_t cnt = avail;
eb160463 3693 if (avail > (SSize_t)b->bufsiz)
14a5cf38
JH		 3694 avail = b->bufsiz;
3695 Copy(ptr, b->buf, avail, STDCHAR);
3696 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3697 }
3698 }
3699 else {
3700 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3701 }
3702 if (avail <= 0) {
3703 if (avail == 0)
3704 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3705 else
3706 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3707 return -1;
3708 }
3709 b->end = b->buf + avail;
3710 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3711 return 0;
06da4f11
NIS		 3712}
3713
6f9d8c32 3714SSize_t
f62ce20a 3715PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 3716{
04892f78 3717 if (PerlIOValid(f)) {
81ec6716 3718 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3719 if (!b->ptr)
3720 PerlIO_get_base(f);
f62ce20a 3721 return PerlIOBase_read(aTHX_ f, vbuf, count);
14a5cf38
JH		 3722 }
3723 return 0;
6f9d8c32
NIS		 3724}
3725
9e353e3b 3726SSize_t
f62ce20a 3727PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 3728{
14a5cf38 3729 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
81ec6716 3730 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3731 SSize_t unread = 0;
3732 SSize_t avail;
3733 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3734 PerlIO_flush(f);
3735 if (!b->buf)
3736 PerlIO_get_base(f);
3737 if (b->buf) {
3738 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3739 /*
3740 * Buffer is already a read buffer, we can overwrite any chars
71200d45 3741 * which have been read back to buffer start
14a5cf38
JH		 3742 */
3743 avail = (b->ptr - b->buf);
3744 }
3745 else {
3746 /*
3747 * Buffer is idle, set it up so whole buffer is available for
71200d45 3748 * unread
14a5cf38
JH		 3749 */
3750 avail = b->bufsiz;
3751 b->end = b->buf + avail;
3752 b->ptr = b->end;
3753 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3754 /*
71200d45 3755 * Buffer extends _back_ from where we are now
14a5cf38
JH		 3756 */
3757 b->posn -= b->bufsiz;
3758 }
3759 if (avail > (SSize_t) count) {
3760 /*
71200d45 3761 * If we have space for more than count, just move count
14a5cf38
JH		 3762 */
3763 avail = count;
3764 }
3765 if (avail > 0) {
3766 b->ptr -= avail;
3767 buf -= avail;
3768 /*
3769 * In simple stdio-like ungetc() case chars will be already
71200d45 3770 * there
14a5cf38
JH		 3771 */
3772 if (buf != b->ptr) {
3773 Copy(buf, b->ptr, avail, STDCHAR);
3774 }
3775 count -= avail;
3776 unread += avail;
3777 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3778 }
3779 }
93679785
NIS		 3780 if (count > 0) {
3781 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3782 }
14a5cf38 3783 return unread;
760ac839
LW		 3784}
3785
9e353e3b 3786SSize_t
f62ce20a 3787PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 3788{
f1c3982b 3789 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3790 const STDCHAR *buf = (const STDCHAR *) vbuf;
65b7047c 3791 const STDCHAR *flushptr = buf;
14a5cf38
JH		 3792 Size_t written = 0;
3793 if (!b->buf)
3794 PerlIO_get_base(f);
3795 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3796 return 0;
763da913
NIS		 3797 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3798 if (PerlIO_flush(f) != 0) {
3799 return 0;
3800 }
3801 }
65b7047c
HS		 3802 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3803 flushptr = buf + count;
3804 while (flushptr > buf && *(flushptr - 1) != '\n')
3805 --flushptr;
3806 }
14a5cf38
JH		 3807 while (count > 0) {
3808 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3809 if ((SSize_t) count < avail)
3810 avail = count;
65b7047c
HS		 3811 if (flushptr > buf && flushptr <= buf + avail)
3812 avail = flushptr - buf;
14a5cf38 3813 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
65b7047c
HS		 3814 if (avail) {
3815 Copy(buf, b->ptr, avail, STDCHAR);
3816 count -= avail;
3817 buf += avail;
3818 written += avail;
3819 b->ptr += avail;
3820 if (buf == flushptr)
3821 PerlIO_flush(f);
14a5cf38
JH		 3822 }
3823 if (b->ptr >= (b->buf + b->bufsiz))
3824 PerlIO_flush(f);
3825 }
3826 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3827 PerlIO_flush(f);
3828 return written;
9e353e3b
NIS		 3829}
3830
3831IV
f62ce20a 3832PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3833{
14a5cf38
JH		 3834 IV code;
3835 if ((code = PerlIO_flush(f)) == 0) {
14a5cf38
JH		 3836 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3837 code = PerlIO_seek(PerlIONext(f), offset, whence);
3838 if (code == 0) {
f1c3982b 3839 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3840 b->posn = PerlIO_tell(PerlIONext(f));
3841 }
9e353e3b 3842 }
14a5cf38 3843 return code;
9e353e3b
NIS		 3844}
3845
3846Off_t
f62ce20a 3847PerlIOBuf_tell(pTHX_ PerlIO *f)
9e353e3b 3848{
81ec6716 3849 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3850 /*
71200d45 3851 * b->posn is file position where b->buf was read, or will be written
14a5cf38
JH		 3852 */
3853 Off_t posn = b->posn;
0710cc63 3854 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
763da913
NIS		 3855 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3856#if 1
3857 /* As O_APPEND files are normally shared in some sense it is better
3858 to flush :
3859 */
3860 PerlIO_flush(f);
3861#else
0710cc63 3862 /* when file is NOT shared then this is sufficient */
763da913
NIS		 3863 PerlIO_seek(PerlIONext(f),0, SEEK_END);
3864#endif
3865 posn = b->posn = PerlIO_tell(PerlIONext(f));
3866 }
14a5cf38
JH		 3867 if (b->buf) {
3868 /*
71200d45 3869 * If buffer is valid adjust position by amount in buffer
14a5cf38
JH		 3870 */
3871 posn += (b->ptr - b->buf);
3872 }
3873 return posn;
9e353e3b
NIS		 3874}
3875
3876IV
44798d05
NIS		 3877PerlIOBuf_popped(pTHX_ PerlIO *f)
3878{
f1c3982b
NC		 3879 const IV code = PerlIOBase_popped(aTHX_ f);
3880 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
44798d05
NIS		 3881 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3882 Safefree(b->buf);
3883 }
81ec6716 3884 b->ptr = b->end = b->buf = NULL;
44798d05
NIS		 3885 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3886 return code;
3887}
3888
3889IV
f62ce20a 3890PerlIOBuf_close(pTHX_ PerlIO *f)
9e353e3b 3891{
f1c3982b
NC		 3892 const IV code = PerlIOBase_close(aTHX_ f);
3893 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 3894 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 3895 Safefree(b->buf);
14a5cf38 3896 }
81ec6716 3897 b->ptr = b->end = b->buf = NULL;
14a5cf38
JH		 3898 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3899 return code;
760ac839
LW		 3900}
3901
9e353e3b 3902STDCHAR *
f62ce20a 3903PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3904{
81ec6716 3905 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3906 if (!b->buf)
3907 PerlIO_get_base(f);
3908 return b->ptr;
9e353e3b
NIS		 3909}
3910
05d1247b 3911SSize_t
f62ce20a 3912PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3913{
81ec6716 3914 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3915 if (!b->buf)
3916 PerlIO_get_base(f);
3917 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3918 return (b->end - b->ptr);
3919 return 0;
9e353e3b
NIS		 3920}
3921
3922STDCHAR *
f62ce20a 3923PerlIOBuf_get_base(pTHX_ PerlIO *f)
9e353e3b 3924{
81ec6716 3925 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
1e7ed80e
AL		 3926 PERL_UNUSED_CONTEXT;
3927
14a5cf38
JH		 3928 if (!b->buf) {
3929 if (!b->bufsiz)
3930 b->bufsiz = 4096;
cd7a8267 3931 b->buf = Newxz(b->buf,b->bufsiz, STDCHAR);
14a5cf38
JH		 3932 if (!b->buf) {
3933 b->buf = (STDCHAR *) & b->oneword;
3934 b->bufsiz = sizeof(b->oneword);
3935 }
81ec6716 3936 b->end = b->ptr = b->buf;
06da4f11 3937 }
14a5cf38 3938 return b->buf;
9e353e3b
NIS		 3939}
3940
3941Size_t
f62ce20a 3942PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3943{
81ec6716 3944 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3945 if (!b->buf)
3946 PerlIO_get_base(f);
3947 return (b->end - b->buf);
9e353e3b
NIS		 3948}
3949
3950void
f62ce20a 3951PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3952{
81ec6716 3953 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 3954 if (!b->buf)
3955 PerlIO_get_base(f);
3956 b->ptr = ptr;
3957 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
14a5cf38
JH		 3958 assert(PerlIO_get_cnt(f) == cnt);
3959 assert(b->ptr >= b->buf);
3960 }
3961 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW		 3962}
3963
71200d45 3964PerlIO *
ecdeb87c 3965PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 3966{
ecdeb87c 3967 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 3968}
3969
3970
3971
cf7b4f3b 3972PERLIO_FUNCS_DECL(PerlIO_perlio) = {
2dc2558e 3973 sizeof(PerlIO_funcs),
14a5cf38
JH		 3974 "perlio",
3975 sizeof(PerlIOBuf),
86e05cf2 3976 PERLIO_K_BUFFERED|PERLIO_K_RAW,
14a5cf38 3977 PerlIOBuf_pushed,
44798d05 3978 PerlIOBuf_popped,
14a5cf38 3979 PerlIOBuf_open,
86e05cf2 3980 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 3981 NULL,
3982 PerlIOBase_fileno,
71200d45 3983 PerlIOBuf_dup,
14a5cf38
JH		 3984 PerlIOBuf_read,
3985 PerlIOBuf_unread,
3986 PerlIOBuf_write,
3987 PerlIOBuf_seek,
3988 PerlIOBuf_tell,
3989 PerlIOBuf_close,
3990 PerlIOBuf_flush,
3991 PerlIOBuf_fill,
3992 PerlIOBase_eof,
3993 PerlIOBase_error,
3994 PerlIOBase_clearerr,
3995 PerlIOBase_setlinebuf,
3996 PerlIOBuf_get_base,
3997 PerlIOBuf_bufsiz,
3998 PerlIOBuf_get_ptr,
3999 PerlIOBuf_get_cnt,
4000 PerlIOBuf_set_ptrcnt,
9e353e3b
NIS		 4001};
4002
66ecd56b 4003/*--------------------------------------------------------------------------------------*/
14a5cf38 4004/*
71200d45 4005 * Temp layer to hold unread chars when cannot do it any other way
14a5cf38 4006 */
5e2ab84b
NIS		 4007
4008IV
f62ce20a 4009PerlIOPending_fill(pTHX_ PerlIO *f)
5e2ab84b 4010{
14a5cf38 4011 /*
71200d45 4012 * Should never happen
14a5cf38
JH		 4013 */
4014 PerlIO_flush(f);
4015 return 0;
5e2ab84b
NIS		 4016}
4017
4018IV
f62ce20a 4019PerlIOPending_close(pTHX_ PerlIO *f)
5e2ab84b 4020{
14a5cf38 4021 /*
71200d45 4022 * A tad tricky - flush pops us, then we close new top
14a5cf38
JH		 4023 */
4024 PerlIO_flush(f);
4025 return PerlIO_close(f);
5e2ab84b
NIS		 4026}
4027
4028IV
f62ce20a 4029PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
5e2ab84b 4030{
14a5cf38 4031 /*
71200d45 4032 * A tad tricky - flush pops us, then we seek new top
14a5cf38
JH		 4033 */
4034 PerlIO_flush(f);
4035 return PerlIO_seek(f, offset, whence);
5e2ab84b
NIS		 4036}
4037
4038
4039IV
f62ce20a 4040PerlIOPending_flush(pTHX_ PerlIO *f)
5e2ab84b 4041{
81ec6716 4042 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4043 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 4044 Safefree(b->buf);
14a5cf38
JH		 4045 b->buf = NULL;
4046 }
4047 PerlIO_pop(aTHX_ f);
4048 return 0;
5e2ab84b
NIS		 4049}
4050
4051void
f62ce20a 4052PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
5e2ab84b 4053{
14a5cf38
JH		 4054 if (cnt <= 0) {
4055 PerlIO_flush(f);
4056 }
4057 else {
f62ce20a 4058 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
14a5cf38 4059 }
5e2ab84b
NIS		 4060}
4061
4062IV
2dc2558e 4063PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
5e2ab84b 4064{
f1c3982b 4065 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
81ec6716 4066 PerlIOl * const l = PerlIOBase(f);
14a5cf38 4067 /*
71200d45
NIS		 4068 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4069 * etc. get muddled when it changes mid-string when we auto-pop.
14a5cf38
JH		 4070 */
4071 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4072 (PerlIOBase(PerlIONext(f))->
4073 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4074 return code;
5e2ab84b
NIS		 4075}
4076
4077SSize_t
f62ce20a 4078PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
5e2ab84b 4079{
14a5cf38
JH		 4080 SSize_t avail = PerlIO_get_cnt(f);
4081 SSize_t got = 0;
eb160463 4082 if ((SSize_t)count < avail)
14a5cf38
JH		 4083 avail = count;
4084 if (avail > 0)
f62ce20a 4085 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
eb160463 4086 if (got >= 0 && got < (SSize_t)count) {
f1c3982b 4087 const SSize_t more =
14a5cf38
JH		 4088 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4089 if (more >= 0 || got == 0)
4090 got += more;
4091 }
4092 return got;
5e2ab84b
NIS		 4093}
4094
cf7b4f3b 4095PERLIO_FUNCS_DECL(PerlIO_pending) = {
2dc2558e 4096 sizeof(PerlIO_funcs),
14a5cf38
JH		 4097 "pending",
4098 sizeof(PerlIOBuf),
86e05cf2 4099 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
14a5cf38 4100 PerlIOPending_pushed,
44798d05 4101 PerlIOBuf_popped,
14a5cf38 4102 NULL,
86e05cf2 4103 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4104 NULL,
4105 PerlIOBase_fileno,
71200d45 4106 PerlIOBuf_dup,
14a5cf38
JH		 4107 PerlIOPending_read,
4108 PerlIOBuf_unread,
4109 PerlIOBuf_write,
4110 PerlIOPending_seek,
4111 PerlIOBuf_tell,
4112 PerlIOPending_close,
4113 PerlIOPending_flush,
4114 PerlIOPending_fill,
4115 PerlIOBase_eof,
4116 PerlIOBase_error,
4117 PerlIOBase_clearerr,
4118 PerlIOBase_setlinebuf,
4119 PerlIOBuf_get_base,
4120 PerlIOBuf_bufsiz,
4121 PerlIOBuf_get_ptr,
4122 PerlIOBuf_get_cnt,
4123 PerlIOPending_set_ptrcnt,
5e2ab84b
NIS		 4124};
4125
4126
4127
4128/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4129/*
4130 * crlf - translation On read translate CR,LF to "\n" we do this by
4131 * overriding ptr/cnt entries to hand back a line at a time and keeping a
71200d45 4132 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4cd59068
NC		 4133 *
4134 * c->nl points on the first byte of CR LF pair when it is temporarily
4135 * replaced by LF, or to the last CR of the buffer. In the former case
4136 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4137 * that it ends at c->nl; these two cases can be distinguished by
4138 * *c->nl. c->nl is set during _getcnt() call, and unset during
4139 * _unread() and _flush() calls.
4140 * It only matters for read operations.
66ecd56b
NIS		 4141 */
4142
14a5cf38 4143typedef struct {
22569500
NIS		 4144 PerlIOBuf base; /* PerlIOBuf stuff */
4145 STDCHAR *nl; /* Position of crlf we "lied" about in the
14a5cf38 4146 * buffer */
99efab12
NIS		 4147} PerlIOCrlf;
4148
69eb86fd
NC		 4149/* Inherit the PERLIO_F_UTF8 flag from previous layer.
4150 * Otherwise the :crlf layer would always revert back to
4151 * raw mode.
4152 */
4153static void
4154S_inherit_utf8_flag(PerlIO *f)
4155{
4156 PerlIO *g = PerlIONext(f);
4157 if (PerlIOValid(g)) {
4158 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4159 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4160 }
4161 }
4162}
4163
f5b9d040 4164IV
2dc2558e 4165PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
f5b9d040 4166{
14a5cf38
JH		 4167 IV code;
4168 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2dc2558e 4169 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
5e2ab84b 4170#if 0
14a5cf38
JH		 4171 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4172 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4173 PerlIOBase(f)->flags);
5e2ab84b 4174#endif
74563541
CB		 4175 {
4176 /* Enable the first CRLF capable layer you can find, but if none
4177 * found, the one we just pushed is fine. This results in at
4178 * any given moment at most one CRLF-capable layer being enabled
4179 * in the whole layer stack. */
4180 PerlIO *g = PerlIONext(f);
69eb86fd 4181 while (PerlIOValid(g)) {
74563541
CB		 4182 PerlIOl *b = PerlIOBase(g);
4183 if (b && b->tab == &PerlIO_crlf) {
4184 if (!(b->flags & PERLIO_F_CRLF))
4185 b->flags |= PERLIO_F_CRLF;
69eb86fd 4186 S_inherit_utf8_flag(g);
74563541
CB		 4187 PerlIO_pop(aTHX_ f);
4188 return code;
4189 }
4190 g = PerlIONext(g);
4191 }
4192 }
69eb86fd 4193 S_inherit_utf8_flag(f);
14a5cf38 4194 return code;
f5b9d040
NIS		 4195}
4196
4197
99efab12 4198SSize_t
f62ce20a 4199PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4200{
81ec6716 4201 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4cd59068 4202 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
14a5cf38
JH		 4203 *(c->nl) = 0xd;
4204 c->nl = NULL;
4205 }
4206 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4207 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 4208 else {
4209 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4210 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4211 SSize_t unread = 0;
4212 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4213 PerlIO_flush(f);
4214 if (!b->buf)
4215 PerlIO_get_base(f);
4216 if (b->buf) {
4217 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4218 b->end = b->ptr = b->buf + b->bufsiz;
4219 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4220 b->posn -= b->bufsiz;
4221 }
4222 while (count > 0 && b->ptr > b->buf) {
81ec6716 4223 const int ch = *--buf;
14a5cf38
JH		 4224 if (ch == '\n') {
4225 if (b->ptr - 2 >= b->buf) {
4226 *--(b->ptr) = 0xa;
4227 *--(b->ptr) = 0xd;
4228 unread++;
4229 count--;
4230 }
4231 else {
4cd59068
NC		 4232 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4233 *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */
4234 unread++;
4235 count--;
14a5cf38
JH		 4236 }
4237 }
4238 else {
4239 *--(b->ptr) = ch;
4240 unread++;
4241 count--;
4242 }
4243 }
4244 }
4245 return unread;
4246 }
99efab12
NIS		 4247}
4248
4cd59068 4249/* XXXX This code assumes that buffer size >=2, but does not check it... */
99efab12 4250SSize_t
f62ce20a 4251PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
99efab12 4252{
81ec6716 4253 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4254 if (!b->buf)
4255 PerlIO_get_base(f);
4256 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
81ec6716 4257 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
23b3c6af
NIS		 4258 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
4259 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
14a5cf38
JH		 4260 scan:
4261 while (nl < b->end && *nl != 0xd)
4262 nl++;
4263 if (nl < b->end && *nl == 0xd) {
4264 test:
4265 if (nl + 1 < b->end) {
4266 if (nl[1] == 0xa) {
4267 *nl = '\n';
4268 c->nl = nl;
4269 }
4270 else {
4271 /*
71200d45 4272 * Not CR,LF but just CR
14a5cf38
JH		 4273 */
4274 nl++;
4275 goto scan;
4276 }
4277 }
4278 else {
4279 /*
71200d45 4280 * Blast - found CR as last char in buffer
14a5cf38 4281 */
e87a358a 4282
14a5cf38
JH		 4283 if (b->ptr < nl) {
4284 /*
4285 * They may not care, defer work as long as
71200d45 4286 * possible
14a5cf38 4287 */
a0d1d361 4288 c->nl = nl;
14a5cf38
JH		 4289 return (nl - b->ptr);
4290 }
4291 else {
4292 int code;
22569500 4293 b->ptr++; /* say we have read it as far as
14a5cf38 4294 * flush() is concerned */
22569500 4295 b->buf++; /* Leave space in front of buffer */
e949e37c
NIS		 4296 /* Note as we have moved buf up flush's
4297 posn += ptr-buf
4298 will naturally make posn point at CR
4299 */
22569500
NIS		 4300 b->bufsiz--; /* Buffer is thus smaller */
4301 code = PerlIO_fill(f); /* Fetch some more */
4302 b->bufsiz++; /* Restore size for next time */
4303 b->buf--; /* Point at space */
4304 b->ptr = nl = b->buf; /* Which is what we hand
14a5cf38 4305 * off */
22569500 4306 *nl = 0xd; /* Fill in the CR */
14a5cf38 4307 if (code == 0)
22569500 4308 goto test; /* fill() call worked */
14a5cf38 4309 /*
71200d45 4310 * CR at EOF - just fall through
14a5cf38 4311 */
a0d1d361 4312 /* Should we clear EOF though ??? */
14a5cf38
JH		 4313 }
4314 }
4315 }
4316 }
4317 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4318 }
4319 return 0;
99efab12
NIS		 4320}
4321
4322void
f62ce20a 4323PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
14a5cf38 4324{
81ec6716
AL		 4325 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4326 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38
JH		 4327 if (!b->buf)
4328 PerlIO_get_base(f);
4329 if (!ptr) {
a0d1d361 4330 if (c->nl) {
14a5cf38 4331 ptr = c->nl + 1;
22569500 4332 if (ptr == b->end && *c->nl == 0xd) {
a0d1d361 4333 /* Defered CR at end of buffer case - we lied about count */
22569500
NIS		 4334 ptr--;
4335 }
4336 }
14a5cf38
JH		 4337 else {
4338 ptr = b->end;
14a5cf38
JH		 4339 }
4340 ptr -= cnt;
4341 }
4342 else {
c9c8c8e1 4343 NOOP;
3b4bd3fd 4344#if 0
14a5cf38 4345 /*
71200d45 4346 * Test code - delete when it works ...
14a5cf38 4347 */
3b4bd3fd 4348 IV flags = PerlIOBase(f)->flags;
ba7abf9d 4349 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
22569500 4350 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
a0d1d361
NIS		 4351 /* Defered CR at end of buffer case - we lied about count */
4352 chk--;
22569500 4353 }
14a5cf38
JH		 4354 chk -= cnt;
4355
a0d1d361 4356 if (ptr != chk ) {
99ef548b 4357 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
14a5cf38
JH		 4358 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
4359 b->end, cnt);
4360 }
99ef548b 4361#endif
14a5cf38
JH		 4362 }
4363 if (c->nl) {
4364 if (ptr > c->nl) {
4365 /*
71200d45 4366 * They have taken what we lied about
14a5cf38
JH		 4367 */
4368 *(c->nl) = 0xd;
4369 c->nl = NULL;
4370 ptr++;
4371 }
4372 }
4373 b->ptr = ptr;
4374 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
99efab12
NIS		 4375}
4376
4377SSize_t
f62ce20a 4378PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 4379{
14a5cf38 4380 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 4381 return PerlIOBuf_write(aTHX_ f, vbuf, count);
14a5cf38 4382 else {
81ec6716 4383 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38 4384 const STDCHAR *buf = (const STDCHAR *) vbuf;
81ec6716 4385 const STDCHAR * const ebuf = buf + count;
14a5cf38
JH		 4386 if (!b->buf)
4387 PerlIO_get_base(f);
4388 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4389 return 0;
4390 while (buf < ebuf) {
81ec6716 4391 const STDCHAR * const eptr = b->buf + b->bufsiz;
14a5cf38
JH		 4392 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4393 while (buf < ebuf && b->ptr < eptr) {
4394 if (*buf == '\n') {
4395 if ((b->ptr + 2) > eptr) {
4396 /*
71200d45 4397 * Not room for both
14a5cf38
JH		 4398 */
4399 PerlIO_flush(f);
4400 break;
4401 }
4402 else {
22569500
NIS		 4403 *(b->ptr)++ = 0xd; /* CR */
4404 *(b->ptr)++ = 0xa; /* LF */
14a5cf38
JH		 4405 buf++;
4406 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4407 PerlIO_flush(f);
4408 break;
4409 }
4410 }
4411 }
4412 else {
81ec6716 4413 *(b->ptr)++ = *buf++;
14a5cf38
JH		 4414 }
4415 if (b->ptr >= eptr) {
4416 PerlIO_flush(f);
4417 break;
4418 }
4419 }
4420 }
4421 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4422 PerlIO_flush(f);
4423 return (buf - (STDCHAR *) vbuf);
4424 }
99efab12
NIS		 4425}
4426
4427IV
f62ce20a 4428PerlIOCrlf_flush(pTHX_ PerlIO *f)
99efab12 4429{
81ec6716 4430 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38
JH		 4431 if (c->nl) {
4432 *(c->nl) = 0xd;
4433 c->nl = NULL;
4434 }
f62ce20a 4435 return PerlIOBuf_flush(aTHX_ f);
99efab12
NIS		 4436}
4437
86e05cf2
NIS		 4438IV
4439PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4440{
4441 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4442 /* In text mode - flush any pending stuff and flip it */
4443 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4444#ifndef PERLIO_USING_CRLF
4445 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4446 if (PerlIOBase(f)->tab == &PerlIO_crlf) {
4447 PerlIO_pop(aTHX_ f);
4448 }
4449#endif
4450 }
4451 return 0;
4452}
4453
cf7b4f3b 4454PERLIO_FUNCS_DECL(PerlIO_crlf) = {
2dc2558e 4455 sizeof(PerlIO_funcs),
14a5cf38
JH		 4456 "crlf",
4457 sizeof(PerlIOCrlf),
86e05cf2 4458 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
14a5cf38 4459 PerlIOCrlf_pushed,
44798d05 4460 PerlIOBuf_popped, /* popped */
14a5cf38 4461 PerlIOBuf_open,
86e05cf2 4462 PerlIOCrlf_binmode, /* binmode */
14a5cf38
JH		 4463 NULL,
4464 PerlIOBase_fileno,
71200d45 4465 PerlIOBuf_dup,
f1c3982b 4466 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
22569500
NIS		 4467 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4468 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
14a5cf38
JH		 4469 PerlIOBuf_seek,
4470 PerlIOBuf_tell,
4471 PerlIOBuf_close,
4472 PerlIOCrlf_flush,
4473 PerlIOBuf_fill,
4474 PerlIOBase_eof,
4475 PerlIOBase_error,
4476 PerlIOBase_clearerr,
4477 PerlIOBase_setlinebuf,
4478 PerlIOBuf_get_base,
4479 PerlIOBuf_bufsiz,
4480 PerlIOBuf_get_ptr,
4481 PerlIOCrlf_get_cnt,
4482 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS		 4483};
4484
06da4f11
NIS		 4485#ifdef HAS_MMAP
4486/*--------------------------------------------------------------------------------------*/
14a5cf38 4487/*
71200d45 4488 * mmap as "buffer" layer
14a5cf38 4489 */
06da4f11 4490
14a5cf38 4491typedef struct {
22569500
NIS		 4492 PerlIOBuf base; /* PerlIOBuf stuff */
4493 Mmap_t mptr; /* Mapped address */
4494 Size_t len; /* mapped length */
4495 STDCHAR *bbuf; /* malloced buffer if map fails */
06da4f11
NIS		 4496} PerlIOMmap;
4497
c3d7c7c9
NIS		 4498static size_t page_size = 0;
4499
06da4f11 4500IV
f62ce20a 4501PerlIOMmap_map(pTHX_ PerlIO *f)
06da4f11 4502{
f1c3982b
NC		 4503 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4504 const IV flags = PerlIOBase(f)->flags;
14a5cf38
JH		 4505 IV code = 0;
4506 if (m->len)
4507 abort();
4508 if (flags & PERLIO_F_CANREAD) {
81ec6716 4509 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
f1c3982b 4510 const int fd = PerlIO_fileno(f);
10eefe7f
CB		 4511 Stat_t st;
4512 code = Fstat(fd, &st);
14a5cf38
JH		 4513 if (code == 0 && S_ISREG(st.st_mode)) {
4514 SSize_t len = st.st_size - b->posn;
4515 if (len > 0) {
4516 Off_t posn;
4517 if (!page_size) {
68d873c6 4518#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
14a5cf38 4519 {
93189314 4520 SETERRNO(0, SS_NORMAL);
68d873c6 4521# ifdef _SC_PAGESIZE
14a5cf38 4522 page_size = sysconf(_SC_PAGESIZE);
68d873c6 4523# else
14a5cf38 4524 page_size = sysconf(_SC_PAGE_SIZE);
14aaf8e8 4525# endif
14a5cf38
JH		 4526 if ((long) page_size < 0) {
4527 if (errno) {
4528 SV *error = ERRSV;
4529 char *msg;
4530 STRLEN n_a;
4531 (void) SvUPGRADE(error, SVt_PV);
4532 msg = SvPVx(error, n_a);
4533 Perl_croak(aTHX_ "panic: sysconf: %s",
4534 msg);
4535 }
4536 else
4537 Perl_croak(aTHX_
4538 "panic: sysconf: pagesize unknown");
4539 }
4540 }
68d873c6
JH		 4541#else
4542# ifdef HAS_GETPAGESIZE
14a5cf38 4543 page_size = getpagesize();
68d873c6
JH		 4544# else
4545# if defined(I_SYS_PARAM) && defined(PAGESIZE)
22569500 4546 page_size = PAGESIZE; /* compiletime, bad */
68d873c6
JH		 4547# endif
4548# endif
4549#endif
14a5cf38
JH		 4550 if ((IV) page_size <= 0)
4551 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
4552 (IV) page_size);
4553 }
4554 if (b->posn < 0) {
4555 /*
4556 * This is a hack - should never happen - open should
71200d45 4557 * have set it !
14a5cf38
JH		 4558 */
4559 b->posn = PerlIO_tell(PerlIONext(f));
4560 }
4561 posn = (b->posn / page_size) * page_size;
4562 len = st.st_size - posn;
244f8405 4563 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
14a5cf38 4564 if (m->mptr && m->mptr != (Mmap_t) - 1) {
a5262162 4565#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
14a5cf38 4566 madvise(m->mptr, len, MADV_SEQUENTIAL);
06da4f11 4567#endif
a5262162 4568#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
14a5cf38 4569 madvise(m->mptr, len, MADV_WILLNEED);
a5262162 4570#endif
14a5cf38
JH		 4571 PerlIOBase(f)->flags =
4572 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
4573 b->end = ((STDCHAR *) m->mptr) + len;
4574 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
4575 b->ptr = b->buf;
4576 m->len = len;
4577 }
4578 else {
4579 b->buf = NULL;
4580 }
4581 }
4582 else {
4583 PerlIOBase(f)->flags =
4584 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
4585 b->buf = NULL;
4586 b->ptr = b->end = b->ptr;
4587 code = -1;
4588 }
4589 }
4590 }
4591 return code;
06da4f11
NIS		 4592}
4593
4594IV
e87a358a 4595PerlIOMmap_unmap(pTHX_ PerlIO *f)
06da4f11 4596{
81ec6716 4597 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
14a5cf38
JH		 4598 IV code = 0;
4599 if (m->len) {
81ec6716 4600 PerlIOBuf * const b = &m->base;
14a5cf38 4601 if (b->buf) {
0bfdb59a
NC		 4602 /* The munmap address argument is tricky: depending on the
4603 * standard it is either "void *" or "caddr_t" (which is
4604 * usually "char *" (signed or unsigned). If we cast it
4605 * to "void *", those that have it caddr_t and an uptight
4606 * C++ compiler, will freak out. But casting it as char*
4607 * should work. Maybe. (Using Mmap_t figured out by
4608 * Configure doesn't always work, apparently.) */
4609 code = munmap((char*)m->mptr, m->len);
14a5cf38
JH		 4610 b->buf = NULL;
4611 m->len = 0;
4612 m->mptr = NULL;
4613 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
4614 code = -1;
4615 }
4616 b->ptr = b->end = b->buf;
4617 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4618 }
4619 return code;
06da4f11
NIS		 4620}
4621
4622STDCHAR *
f62ce20a 4623PerlIOMmap_get_base(pTHX_ PerlIO *f)
06da4f11 4624{
81ec6716
AL		 4625 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4626 PerlIOBuf * const b = &m->base;
14a5cf38
JH		 4627 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4628 /*
71200d45 4629 * Already have a readbuffer in progress
14a5cf38
JH		 4630 */
4631 return b->buf;
4632 }
4633 if (b->buf) {
4634 /*
71200d45 4635 * We have a write buffer or flushed PerlIOBuf read buffer
14a5cf38 4636 */
22569500
NIS		 4637 m->bbuf = b->buf; /* save it in case we need it again */
4638 b->buf = NULL; /* Clear to trigger below */
14a5cf38
JH		 4639 }
4640 if (!b->buf) {
22569500 4641 PerlIOMmap_map(aTHX_ f); /* Try and map it */
14a5cf38
JH		 4642 if (!b->buf) {
4643 /*
71200d45 4644 * Map did not work - recover PerlIOBuf buffer if we have one
14a5cf38
JH		 4645 */
4646 b->buf = m->bbuf;
4647 }
4648 }
4649 b->ptr = b->end = b->buf;
4650 if (b->buf)
4651 return b->buf;
f62ce20a 4652 return PerlIOBuf_get_base(aTHX_ f);
06da4f11
NIS		 4653}
4654
4655SSize_t
f62ce20a 4656PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
06da4f11 4657{
81ec6716
AL		 4658 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4659 PerlIOBuf * const b = &m->base;
14a5cf38
JH		 4660 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4661 PerlIO_flush(f);
4662 if (b->ptr && (b->ptr - count) >= b->buf
4663 && memEQ(b->ptr - count, vbuf, count)) {
4664 b->ptr -= count;
4665 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4666 return count;
4667 }
4668 if (m->len) {
4669 /*
71200d45 4670 * Loose the unwritable mapped buffer
14a5cf38
JH		 4671 */
4672 PerlIO_flush(f);
4673 /*
71200d45 4674 * If flush took the "buffer" see if we have one from before
14a5cf38
JH		 4675 */
4676 if (!b->buf && m->bbuf)
4677 b->buf = m->bbuf;
4678 if (!b->buf) {
f62ce20a 4679 PerlIOBuf_get_base(aTHX_ f);
14a5cf38
JH		 4680 m->bbuf = b->buf;
4681 }
4682 }
f62ce20a 4683 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
06da4f11
NIS		 4684}
4685
4686SSize_t
f62ce20a 4687PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
06da4f11 4688{
f1c3982b
NC		 4689 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4690 PerlIOBuf * const b = &m->base;
4691
14a5cf38
JH		 4692 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4693 /*
71200d45 4694 * No, or wrong sort of, buffer
14a5cf38
JH		 4695 */
4696 if (m->len) {
e87a358a 4697 if (PerlIOMmap_unmap(aTHX_ f) != 0)
14a5cf38
JH		 4698 return 0;
4699 }
4700 /*
71200d45 4701 * If unmap took the "buffer" see if we have one from before
14a5cf38
JH		 4702 */
4703 if (!b->buf && m->bbuf)
4704 b->buf = m->bbuf;
4705 if (!b->buf) {
f62ce20a 4706 PerlIOBuf_get_base(aTHX_ f);
14a5cf38
JH		 4707 m->bbuf = b->buf;
4708 }
06da4f11 4709 }
f62ce20a 4710 return PerlIOBuf_write(aTHX_ f, vbuf, count);
06da4f11
NIS		 4711}
4712
4713IV
f62ce20a 4714PerlIOMmap_flush(pTHX_ PerlIO *f)
06da4f11 4715{
81ec6716
AL		 4716 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4717 PerlIOBuf * const b = &m->base;
f62ce20a 4718 IV code = PerlIOBuf_flush(aTHX_ f);
14a5cf38 4719 /*
71200d45 4720 * Now we are "synced" at PerlIOBuf level
14a5cf38
JH		 4721 */
4722 if (b->buf) {
4723 if (m->len) {
4724 /*
71200d45 4725 * Unmap the buffer
14a5cf38 4726 */
e87a358a 4727 if (PerlIOMmap_unmap(aTHX_ f) != 0)
14a5cf38
JH		 4728 code = -1;
4729 }
4730 else {
4731 /*
4732 * We seem to have a PerlIOBuf buffer which was not mapped
71200d45 4733 * remember it in case we need one later
14a5cf38
JH		 4734 */
4735 m->bbuf = b->buf;
4736 }
4737 }
4738 return code;
06da4f11
NIS		 4739}
4740
4741IV
f62ce20a 4742PerlIOMmap_fill(pTHX_ PerlIO *f)
06da4f11 4743{
81ec6716 4744 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
14a5cf38
JH		 4745 IV code = PerlIO_flush(f);
4746 if (code == 0 && !b->buf) {
f62ce20a 4747 code = PerlIOMmap_map(aTHX_ f);
14a5cf38
JH		 4748 }
4749 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
f62ce20a 4750 code = PerlIOBuf_fill(aTHX_ f);
14a5cf38
JH		 4751 }
4752 return code;
06da4f11
NIS		 4753}
4754
4755IV
f62ce20a 4756PerlIOMmap_close(pTHX_ PerlIO *f)
06da4f11 4757{
81ec6716
AL		 4758 PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
4759 PerlIOBuf * const b = &m->base;
14a5cf38
JH		 4760 IV code = PerlIO_flush(f);
4761 if (m->bbuf) {
4762 b->buf = m->bbuf;
4763 m->bbuf = NULL;
4764 b->ptr = b->end = b->buf;
4765 }
f62ce20a 4766 if (PerlIOBuf_close(aTHX_ f) != 0)
14a5cf38
JH		 4767 code = -1;
4768 return code;
06da4f11
NIS		 4769}
4770
71200d45 4771PerlIO *
ecdeb87c 4772PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 4773{
ecdeb87c 4774 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 4775}
4776
06da4f11 4777
cf7b4f3b 4778PERLIO_FUNCS_DECL(PerlIO_mmap) = {
2dc2558e 4779 sizeof(PerlIO_funcs),
14a5cf38
JH		 4780 "mmap",
4781 sizeof(PerlIOMmap),
86e05cf2 4782 PERLIO_K_BUFFERED|PERLIO_K_RAW,
14a5cf38 4783 PerlIOBuf_pushed,
44798d05 4784 PerlIOBuf_popped,
14a5cf38 4785 PerlIOBuf_open,
86e05cf2 4786 PerlIOBase_binmode, /* binmode */
14a5cf38
JH		 4787 NULL,
4788 PerlIOBase_fileno,
71200d45 4789 PerlIOMmap_dup,
14a5cf38
JH		 4790 PerlIOBuf_read,
4791 PerlIOMmap_unread,
4792 PerlIOMmap_write,
4793 PerlIOBuf_seek,
4794 PerlIOBuf_tell,
4795 PerlIOBuf_close,
4796 PerlIOMmap_flush,
4797 PerlIOMmap_fill,
4798 PerlIOBase_eof,
4799 PerlIOBase_error,
4800 PerlIOBase_clearerr,
4801 PerlIOBase_setlinebuf,
4802 PerlIOMmap_get_base,
4803 PerlIOBuf_bufsiz,
4804 PerlIOBuf_get_ptr,
4805 PerlIOBuf_get_cnt,
4806 PerlIOBuf_set_ptrcnt,
06da4f11
NIS		 4807};
4808
22569500 4809#endif /* HAS_MMAP */
06da4f11 4810
9e353e3b 4811PerlIO *
e87a358a 4812Perl_PerlIO_stdin(pTHX)
9e353e3b 4813{
a1ea730d 4814 if (!PL_perlio) {
14a5cf38
JH		 4815 PerlIO_stdstreams(aTHX);
4816 }
a1ea730d 4817 return &PL_perlio[1];
9e353e3b
NIS		 4818}
4819
9e353e3b 4820PerlIO *
e87a358a 4821Perl_PerlIO_stdout(pTHX)
9e353e3b 4822{
a1ea730d 4823 if (!PL_perlio) {
14a5cf38
JH		 4824 PerlIO_stdstreams(aTHX);
4825 }
a1ea730d 4826 return &PL_perlio[2];
9e353e3b
NIS		 4827}
4828
9e353e3b 4829PerlIO *
e87a358a 4830Perl_PerlIO_stderr(pTHX)
9e353e3b 4831{
a1ea730d 4832 if (!PL_perlio) {
14a5cf38
JH		 4833 PerlIO_stdstreams(aTHX);
4834 }
a1ea730d 4835 return &PL_perlio[3];
9e353e3b
NIS		 4836}
4837
4838/*--------------------------------------------------------------------------------------*/
4839
9e353e3b
NIS		 4840char *
4841PerlIO_getname(PerlIO *f, char *buf)
4842{
14a5cf38 4843 dTHX;
a15cef0c 4844#ifdef VMS
e2b56717 4845 char *name = NULL;
2e7fc6b0 4846 bool exported = FALSE;
14a5cf38 4847 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2e7fc6b0
NC		 4848 if (!stdio) {
4849 stdio = PerlIO_exportFILE(f,0);
4850 exported = TRUE;
4851 }
4852 if (stdio) {
14a5cf38 4853 name = fgetname(stdio, buf);
2e7fc6b0
NC		 4854 if (exported) PerlIO_releaseFILE(f,stdio);
4855 }
e2b56717 4856 return name;
a15cef0c 4857#else
4f1e9d25
AL		 4858 PERL_UNUSED_ARG(f);
4859 PERL_UNUSED_ARG(buf);
14a5cf38 4860 Perl_croak(aTHX_ "Don't know how to get file name");
0e2d6244 4861 return NULL;
a15cef0c 4862#endif
9e353e3b
NIS		 4863}
4864
4865
4866/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4867/*
4868 * Functions which can be called on any kind of PerlIO implemented in
71200d45 4869 * terms of above
14a5cf38 4870 */
9e353e3b 4871
e87a358a
NIS		 4872#undef PerlIO_fdopen
4873PerlIO *
4874PerlIO_fdopen(int fd, const char *mode)
4875{
4876 dTHX;
0e2d6244 4877 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
e87a358a
NIS		 4878}
4879
4880#undef PerlIO_open
4881PerlIO *
4882PerlIO_open(const char *path, const char *mode)
4883{
4884 dTHX;
aae6d3c0 4885 SV *name = sv_2mortal(newSVpv(path, 0));
0e2d6244 4886 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
e87a358a
NIS		 4887}
4888
4889#undef Perlio_reopen
4890PerlIO *
4891PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4892{
4893 dTHX;
aae6d3c0 4894 SV *name = sv_2mortal(newSVpv(path,0));
0e2d6244 4895 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
e87a358a
NIS		 4896}
4897
9e353e3b 4898#undef PerlIO_getc
6f9d8c32 4899int
9e353e3b 4900PerlIO_getc(PerlIO *f)
760ac839 4901{
e87a358a 4902 dTHX;
14a5cf38 4903 STDCHAR buf[1];
f1c3982b 4904 if ( 1 == PerlIO_read(f, buf, 1) ) {
14a5cf38
JH		 4905 return (unsigned char) buf[0];
4906 }
4907 return EOF;
313ca112
NIS		 4908}
4909
4910#undef PerlIO_ungetc
4911int
4912PerlIO_ungetc(PerlIO *f, int ch)
4913{
e87a358a 4914 dTHX;
14a5cf38
JH		 4915 if (ch != EOF) {
4916 STDCHAR buf = ch;
4917 if (PerlIO_unread(f, &buf, 1) == 1)
4918 return ch;
4919 }
4920 return EOF;
760ac839
LW		 4921}
4922
9e353e3b
NIS		 4923#undef PerlIO_putc
4924int
4925PerlIO_putc(PerlIO *f, int ch)
760ac839 4926{
e87a358a 4927 dTHX;
14a5cf38
JH		 4928 STDCHAR buf = ch;
4929 return PerlIO_write(f, &buf, 1);
760ac839
LW		 4930}
4931
9e353e3b 4932#undef PerlIO_puts
760ac839 4933int
9e353e3b 4934PerlIO_puts(PerlIO *f, const char *s)
760ac839 4935{
e87a358a 4936 dTHX;
81ec6716 4937 return PerlIO_write(f, s, strlen(s));
760ac839
LW		 4938}
4939
4940#undef PerlIO_rewind
4941void
c78749f2 4942PerlIO_rewind(PerlIO *f)
760ac839 4943{
e87a358a 4944 dTHX;
14a5cf38
JH		 4945 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4946 PerlIO_clearerr(f);
6f9d8c32
NIS		 4947}
4948
4949#undef PerlIO_vprintf
4950int
4951PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4952{
14a5cf38 4953 dTHX;
d7559646 4954 SV * const sv = newSVpvs("");
23c2bb70 4955 const char *s;
14a5cf38
JH		 4956 STRLEN len;
4957 SSize_t wrote;
2cc61e15 4958#ifdef NEED_VA_COPY
14a5cf38
JH		 4959 va_list apc;
4960 Perl_va_copy(ap, apc);
4961 sv_vcatpvf(sv, fmt, &apc);
2cc61e15 4962#else
14a5cf38 4963 sv_vcatpvf(sv, fmt, &ap);
2cc61e15 4964#endif
23c2bb70 4965 s = SvPV_const(sv, len);
14a5cf38
JH		 4966 wrote = PerlIO_write(f, s, len);
4967 SvREFCNT_dec(sv);
4968 return wrote;
760ac839
LW		 4969}
4970
4971#undef PerlIO_printf
6f9d8c32 4972int
14a5cf38 4973PerlIO_printf(PerlIO *f, const char *fmt, ...)
760ac839 4974{
14a5cf38
JH		 4975 va_list ap;
4976 int result;
4977 va_start(ap, fmt);
4978 result = PerlIO_vprintf(f, fmt, ap);
4979 va_end(ap);
4980 return result;
760ac839
LW		 4981}
4982
4983#undef PerlIO_stdoutf
6f9d8c32 4984int
14a5cf38 4985PerlIO_stdoutf(const char *fmt, ...)
760ac839 4986{
e87a358a 4987 dTHX;
14a5cf38
JH		 4988 va_list ap;
4989 int result;
4990 va_start(ap, fmt);
4991 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4992 va_end(ap);
4993 return result;
760ac839
LW		 4994}
4995
4996#undef PerlIO_tmpfile
4997PerlIO *
c78749f2 4998PerlIO_tmpfile(void)
760ac839 4999{
f3479639
JH		 5000 dTHX;
5001 PerlIO *f = NULL;
6d061c82 5002#ifdef WIN32
f1c3982b 5003 const int fd = win32_tmpfd();
6d061c82
JH		 5004 if (fd >= 0)
5005 f = PerlIO_fdopen(fd, "w+b");
5006#else /* WIN32 */
5a560d3a 5007# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2)
d7559646 5008 SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX");
6d061c82
JH		 5009 /*
5010 * I have no idea how portable mkstemp() is ... NI-S
5011 */
f1c3982b 5012 const int fd = mkstemp(SvPVX(sv));
f3479639
JH		 5013 if (fd >= 0) {
5014 f = PerlIO_fdopen(fd, "w+");
6d061c82
JH		 5015 if (f)
5016 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5e7e76a3 5017 PerlLIO_unlink(SvPVX_const(sv));
6d061c82 5018 SvREFCNT_dec(sv);
f3479639 5019 }
6d061c82 5020# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
81ec6716 5021 FILE * const stdio = PerlSIO_tmpfile();
f3479639 5022
095ea9f7
TS		 5023 if (stdio)
5024 f = PerlIO_fdopen(fileno(stdio), "w+");
6d061c82 5025
6d061c82
JH		 5026# endif /* else HAS_MKSTEMP */
5027#endif /* else WIN32 */
f3479639 5028 return f;
760ac839
LW		 5029}
5030
6f9d8c32
NIS		 5031#undef HAS_FSETPOS
5032#undef HAS_FGETPOS
5033
22569500
NIS		 5034#endif /* USE_SFIO */
5035#endif /* PERLIO_IS_STDIO */
760ac839 5036
9e353e3b 5037/*======================================================================================*/
14a5cf38 5038/*
71200d45
NIS		 5039 * Now some functions in terms of above which may be needed even if we are
5040 * not in true PerlIO mode
9e353e3b
NIS		 5041 */
5042
760ac839
LW		 5043#ifndef HAS_FSETPOS
5044#undef PerlIO_setpos
5045int
766a733e 5046PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 5047{
14a5cf38
JH		 5048 dTHX;
5049 if (SvOK(pos)) {
5050 STRLEN len;
81ec6716 5051 const Off_t * const posn = (Off_t *) SvPV(pos, len);
14a5cf38
JH		 5052 if (f && len == sizeof(Off_t))
5053 return PerlIO_seek(f, *posn, SEEK_SET);
5054 }
93189314 5055 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5056 return -1;
760ac839 5057}
c411622e 5058#else
c411622e 5059#undef PerlIO_setpos
5060int
766a733e 5061PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 5062{
14a5cf38
JH		 5063 dTHX;
5064 if (SvOK(pos)) {
5065 STRLEN len;
81ec6716 5066 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
14a5cf38 5067 if (f && len == sizeof(Fpos_t)) {
2d4389e4 5068#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 5069 return fsetpos64(f, fpos);
d9b3e12d 5070#else
14a5cf38 5071 return fsetpos(f, fpos);
d9b3e12d 5072#endif
14a5cf38 5073 }
766a733e 5074 }
93189314 5075 SETERRNO(EINVAL, SS_IVCHAN);
14a5cf38 5076 return -1;
c411622e 5077}
5078#endif
760ac839
LW		 5079
5080#ifndef HAS_FGETPOS
5081#undef PerlIO_getpos
5082int
766a733e 5083PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 5084{
14a5cf38
JH		 5085 dTHX;
5086 Off_t posn = PerlIO_tell(f);
5087 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5088 return (posn == (Off_t) - 1) ? -1 : 0;
760ac839 5089}
c411622e 5090#else
c411622e 5091#undef PerlIO_getpos
5092int
766a733e 5093PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 5094{
14a5cf38
JH		 5095 dTHX;
5096 Fpos_t fpos;
5097 int code;
2d4389e4 5098#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 5099 code = fgetpos64(f, &fpos);
d9b3e12d 5100#else
14a5cf38 5101 code = fgetpos(f, &fpos);
d9b3e12d 5102#endif
14a5cf38
JH		 5103 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5104 return code;
c411622e 5105}
5106#endif
760ac839
LW		 5107
5108#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
5109
5110int
c78749f2 5111vprintf(char *pat, char *args)
662a7e3f
CS		 5112{
5113 _doprnt(pat, args, stdout);
22569500 5114 return 0; /* wrong, but perl doesn't use the return
14a5cf38 5115 * value */
662a7e3f
CS		 5116}
5117
5118int
c78749f2 5119vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW		 5120{
5121 _doprnt(pat, args, fd);
22569500 5122 return 0; /* wrong, but perl doesn't use the return
14a5cf38 5123 * value */
760ac839
LW		 5124}
5125
5126#endif
5127
5128#ifndef PerlIO_vsprintf
6f9d8c32 5129int
8ac85365 5130PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839 5131{
b25a8111
NC		 5132 dTHX;
5133 const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap);
8e7b0921
AL		 5134 PERL_UNUSED_CONTEXT;
5135
b25a8111
NC		 5136#ifndef PERL_MY_VSNPRINTF_GUARDED
5137 if (val < 0 || (n > 0 ? val >= n : 0)) {
5138 Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n");
760ac839 5139 }
b25a8111 5140#endif
14a5cf38 5141 return val;
760ac839
LW		 5142}
5143#endif
5144
5145#ifndef PerlIO_sprintf
6f9d8c32 5146int
14a5cf38 5147PerlIO_sprintf(char *s, int n, const char *fmt, ...)
760ac839 5148{
14a5cf38
JH		 5149 va_list ap;
5150 int result;
5151 va_start(ap, fmt);
5152 result = PerlIO_vsprintf(s, n, fmt, ap);
5153 va_end(ap);
5154 return result;
760ac839
LW		 5155}
5156#endif
2098fb77
NC		 5157
5158/*
5159 * Local variables:
5160 * c-indentation-style: bsd
5161 * c-basic-offset: 4
5162 * indent-tabs-mode: t
5163 * End:
5164 *
d8294a4d
NC		 5165 * ex: set ts=8 sts=4 sw=4 noet:
5166 */
Unnamed repository; edit this file 'description' to name the repository.