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