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