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