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