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