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