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