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