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