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