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
Documentation added.
[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
NIS		 108#ifndef O_ACCMODE
109#define O_ACCMODE 3 /* Assume traditional implementation */
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
193 return PerlSIO_fdupopen(f);
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
14a5cf38 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
14a5cf38 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));
406 len = strlen(buffer);
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);
ecdeb87c 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,
713 NULL, /* len */
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
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
PM		 804 if (ckWARN(WARN_LAYER))
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--;
99ef548b
PM		 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 {
99ef548b
PM		 864 if (warn_layer)
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
JH		 884 if (PerlIO_stdio.Set_ptrcnt)
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,
1692 NULL, /* flush */
1693 NULL, /* fill */
1694 NULL,
1695 NULL,
1696 NULL,
1697 NULL,
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,
1720 NULL, /* flush */
1721 NULL, /* fill */
1722 NULL,
1723 NULL,
1724 NULL,
1725 NULL,
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,
1758 NULL, /* flush */
1759 NULL, /* fill */
1760 NULL,
1761 NULL,
1762 NULL,
1763 NULL,
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
JH		 2109typedef struct {
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;
93a8090d 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;
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,
2364 PerlIOBase_noop_ok, /* flush */
2365 PerlIOBase_noop_fail, /* fill */
2366 PerlIOBase_eof,
2367 PerlIOBase_error,
2368 PerlIOBase_clearerr,
2369 PerlIOBase_setlinebuf,
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;
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
9e353e3b
NIS		 2430PerlIO *
2431PerlIO_importFILE(FILE *stdio, int fl)
2432{
14a5cf38
JH		 2433 dTHX;
2434 PerlIO *f = NULL;
2435 if (stdio) {
2436 PerlIOStdio *s =
2437 PerlIOSelf(PerlIO_push
2438 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
2439 "r+", Nullsv), PerlIOStdio);
2440 s->stdio = stdio;
2441 }
2442 return f;
9e353e3b
NIS		 2443}
2444
2445PerlIO *
14a5cf38
JH		 2446PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2447 IV n, const char *mode, int fd, int imode,
2448 int perm, PerlIO *f, int narg, SV **args)
2449{
2450 char tmode[8];
d9dac8cd 2451 if (PerlIOValid(f)) {
14a5cf38
JH		 2452 char *path = SvPV_nolen(*args);
2453 PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
1751d015
NIS		 2454 FILE *stdio;
2455 PerlIOUnix_refcnt_dec(fileno(s->stdio));
2456 stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
14a5cf38
JH		 2457 s->stdio);
2458 if (!s->stdio)
2459 return NULL;
2460 s->stdio = stdio;
1751d015 2461 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH		 2462 return f;
2463 }
2464 else {
2465 if (narg > 0) {
2466 char *path = SvPV_nolen(*args);
2467 if (*mode == '#') {
2468 mode++;
2469 fd = PerlLIO_open3(path, imode, perm);
2470 }
2471 else {
2472 FILE *stdio = PerlSIO_fopen(path, mode);
2473 if (stdio) {
d9dac8cd
NIS		 2474 PerlIOStdio *s;
2475 if (!f) {
2476 f = PerlIO_allocate(aTHX);
2477 }
2478 s = PerlIOSelf(PerlIO_push(aTHX_ f, self,
14a5cf38
JH		 2479 (mode = PerlIOStdio_mode(mode, tmode)),
2480 PerlIOArg),
2481 PerlIOStdio);
2482 s->stdio = stdio;
1751d015 2483 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH		 2484 }
2485 return f;
2486 }
2487 }
2488 if (fd >= 0) {
2489 FILE *stdio = NULL;
2490 int init = 0;
2491 if (*mode == 'I') {
2492 init = 1;
2493 mode++;
2494 }
2495 if (init) {
2496 switch (fd) {
2497 case 0:
2498 stdio = PerlSIO_stdin;
2499 break;
2500 case 1:
2501 stdio = PerlSIO_stdout;
2502 break;
2503 case 2:
2504 stdio = PerlSIO_stderr;
2505 break;
2506 }
2507 }
2508 else {
2509 stdio = PerlSIO_fdopen(fd, mode =
2510 PerlIOStdio_mode(mode, tmode));
2511 }
2512 if (stdio) {
d9dac8cd
NIS		 2513 PerlIOStdio *s;
2514 if (!f) {
2515 f = PerlIO_allocate(aTHX);
2516 }
2517 s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio);
14a5cf38 2518 s->stdio = stdio;
1751d015 2519 PerlIOUnix_refcnt_inc(fileno(s->stdio));
14a5cf38
JH		 2520 return f;
2521 }
2522 }
2523 }
ee518936 2524 return NULL;
9e353e3b
NIS		 2525}
2526
1751d015 2527PerlIO *
ecdeb87c 2528PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
1751d015
NIS		 2529{
2530 /* This assumes no layers underneath - which is what
2531 happens, but is not how I remember it. NI-S 2001/10/16
2532 */
ecdeb87c 2533 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
694c95cf 2534 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
ecdeb87c
NIS		 2535 if (flags & PERLIO_DUP_FD) {
2536 int fd = PerlLIO_dup(fileno(stdio));
2537 if (fd >= 0) {
2538 char mode[8];
293ed4d2 2539 stdio = fdopen(fd, PerlIO_modestr(o,mode));
ecdeb87c
NIS		 2540 }
2541 else {
2542 /* FIXME: To avoid messy error recovery if dup fails
2543 re-use the existing stdio as though flag was not set
2544 */
2545 }
2546 }
694c95cf
JH		 2547 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2548 PerlIOUnix_refcnt_inc(fileno(stdio));
1751d015
NIS		 2549 }
2550 return f;
2551}
2552
2553IV
f62ce20a 2554PerlIOStdio_close(pTHX_ PerlIO *f)
1751d015 2555{
1751d015
NIS		 2556#ifdef SOCKS5_VERSION_NAME
2557 int optval;
2558 Sock_size_t optlen = sizeof(int);
2559#endif
2560 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2561 if (PerlIOUnix_refcnt_dec(fileno(stdio)) > 0) {
694c95cf 2562 /* Do not close it but do flush any buffers */
0b8d6043 2563 return PerlIO_flush(f);
1751d015
NIS		 2564 }
2565 return (
2566#ifdef SOCKS5_VERSION_NAME
2567 (getsockopt
2568 (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
2569 &optlen) <
2570 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
2571#else
2572 PerlSIO_fclose(stdio)
2573#endif
2574 );
2575
2576}
2577
2578
2579
9e353e3b 2580SSize_t
f62ce20a 2581PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
9e353e3b 2582{
14a5cf38
JH		 2583 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2584 SSize_t got = 0;
2585 if (count == 1) {
2586 STDCHAR *buf = (STDCHAR *) vbuf;
2587 /*
2588 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
71200d45 2589 * stdio does not do that for fread()
14a5cf38
JH		 2590 */
2591 int ch = PerlSIO_fgetc(s);
2592 if (ch != EOF) {
2593 *buf = ch;
2594 got = 1;
2595 }
2596 }
2597 else
2598 got = PerlSIO_fread(vbuf, 1, count, s);
2599 return got;
9e353e3b
NIS		 2600}
2601
2602SSize_t
f62ce20a 2603PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2604{
14a5cf38
JH		 2605 FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
2606 STDCHAR *buf = ((STDCHAR *) vbuf) + count - 1;
2607 SSize_t unread = 0;
2608 while (count > 0) {
2609 int ch = *buf-- & 0xff;
2610 if (PerlSIO_ungetc(ch, s) != ch)
2611 break;
2612 unread++;
2613 count--;
2614 }
2615 return unread;
9e353e3b
NIS		 2616}
2617
2618SSize_t
f62ce20a 2619PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
9e353e3b 2620{
14a5cf38
JH		 2621 return PerlSIO_fwrite(vbuf, 1, count,
2622 PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 2623}
2624
2625IV
f62ce20a 2626PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 2627{
14a5cf38
JH		 2628 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2629 return PerlSIO_fseek(stdio, offset, whence);
9e353e3b
NIS		 2630}
2631
2632Off_t
f62ce20a 2633PerlIOStdio_tell(pTHX_ PerlIO *f)
9e353e3b 2634{
14a5cf38
JH		 2635 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2636 return PerlSIO_ftell(stdio);
9e353e3b
NIS		 2637}
2638
2639IV
f62ce20a 2640PerlIOStdio_flush(pTHX_ PerlIO *f)
9e353e3b 2641{
14a5cf38
JH		 2642 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2643 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
2644 return PerlSIO_fflush(stdio);
2645 }
2646 else {
88b61e10 2647#if 0
14a5cf38
JH		 2648 /*
2649 * FIXME: This discards ungetc() and pre-read stuff which is not
71200d45 2650 * right if this is just a "sync" from a layer above Suspect right
14a5cf38 2651 * design is to do _this_ but not have layer above flush this
71200d45 2652 * layer read-to-read
14a5cf38
JH		 2653 */
2654 /*
71200d45 2655 * Not writeable - sync by attempting a seek
14a5cf38
JH		 2656 */
2657 int err = errno;
2658 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
2659 errno = err;
88b61e10 2660#endif
14a5cf38
JH		 2661 }
2662 return 0;
9e353e3b
NIS		 2663}
2664
2665IV
f62ce20a 2666PerlIOStdio_fill(pTHX_ PerlIO *f)
06da4f11 2667{
14a5cf38
JH		 2668 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2669 int c;
2670 /*
71200d45 2671 * fflush()ing read-only streams can cause trouble on some stdio-s
14a5cf38
JH		 2672 */
2673 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
2674 if (PerlSIO_fflush(stdio) != 0)
2675 return EOF;
2676 }
2677 c = PerlSIO_fgetc(stdio);
2678 if (c == EOF || PerlSIO_ungetc(c, stdio) != c)
2679 return EOF;
2680 return 0;
06da4f11
NIS		 2681}
2682
2683IV
f62ce20a 2684PerlIOStdio_eof(pTHX_ PerlIO *f)
9e353e3b 2685{
14a5cf38 2686 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 2687}
2688
2689IV
f62ce20a 2690PerlIOStdio_error(pTHX_ PerlIO *f)
9e353e3b 2691{
14a5cf38 2692 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 2693}
2694
2695void
f62ce20a 2696PerlIOStdio_clearerr(pTHX_ PerlIO *f)
9e353e3b 2697{
14a5cf38 2698 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b
NIS		 2699}
2700
2701void
f62ce20a 2702PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
9e353e3b
NIS		 2703{
2704#ifdef HAS_SETLINEBUF
14a5cf38 2705 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
9e353e3b 2706#else
14a5cf38 2707 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
9e353e3b
NIS		 2708#endif
2709}
2710
2711#ifdef FILE_base
2712STDCHAR *
f62ce20a 2713PerlIOStdio_get_base(pTHX_ PerlIO *f)
9e353e3b 2714{
14a5cf38 2715 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 2716 return (STDCHAR*)PerlSIO_get_base(stdio);
9e353e3b
NIS		 2717}
2718
2719Size_t
f62ce20a 2720PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
9e353e3b 2721{
14a5cf38
JH		 2722 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2723 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS		 2724}
2725#endif
2726
2727#ifdef USE_STDIO_PTR
2728STDCHAR *
f62ce20a 2729PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
9e353e3b 2730{
14a5cf38 2731 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
cc00df79 2732 return (STDCHAR*)PerlSIO_get_ptr(stdio);
9e353e3b
NIS		 2733}
2734
2735SSize_t
f62ce20a 2736PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
9e353e3b 2737{
14a5cf38
JH		 2738 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
2739 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS		 2740}
2741
2742void
f62ce20a 2743PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 2744{
14a5cf38 2745 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
14a5cf38 2746 if (ptr != NULL) {
9e353e3b 2747#ifdef STDIO_PTR_LVALUE
f62ce20a 2748 PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */
9e353e3b 2749#ifdef STDIO_PTR_LVAL_SETS_CNT
14a5cf38 2750 if (PerlSIO_get_cnt(stdio) != (cnt)) {
14a5cf38
JH		 2751 assert(PerlSIO_get_cnt(stdio) == (cnt));
2752 }
9e353e3b
NIS		 2753#endif
2754#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
14a5cf38 2755 /*
71200d45 2756 * Setting ptr _does_ change cnt - we are done
14a5cf38
JH		 2757 */
2758 return;
9e353e3b 2759#endif
14a5cf38
JH		 2760#else /* STDIO_PTR_LVALUE */
2761 PerlProc_abort();
2762#endif /* STDIO_PTR_LVALUE */
2763 }
2764 /*
71200d45 2765 * Now (or only) set cnt
14a5cf38 2766 */
9e353e3b 2767#ifdef STDIO_CNT_LVALUE
14a5cf38
JH		 2768 PerlSIO_set_cnt(stdio, cnt);
2769#else /* STDIO_CNT_LVALUE */
9e353e3b 2770#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
14a5cf38
JH		 2771 PerlSIO_set_ptr(stdio,
2772 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
2773 cnt));
2774#else /* STDIO_PTR_LVAL_SETS_CNT */
2775 PerlProc_abort();
2776#endif /* STDIO_PTR_LVAL_SETS_CNT */
2777#endif /* STDIO_CNT_LVALUE */
9e353e3b
NIS		 2778}
2779
2780#endif
2781
2782PerlIO_funcs PerlIO_stdio = {
14a5cf38
JH		 2783 "stdio",
2784 sizeof(PerlIOStdio),
2785 PERLIO_K_BUFFERED,
2786 PerlIOBase_pushed,
2787 PerlIOBase_noop_ok,
2788 PerlIOStdio_open,
2789 NULL,
2790 PerlIOStdio_fileno,
71200d45 2791 PerlIOStdio_dup,
14a5cf38
JH		 2792 PerlIOStdio_read,
2793 PerlIOStdio_unread,
2794 PerlIOStdio_write,
2795 PerlIOStdio_seek,
2796 PerlIOStdio_tell,
2797 PerlIOStdio_close,
2798 PerlIOStdio_flush,
2799 PerlIOStdio_fill,
2800 PerlIOStdio_eof,
2801 PerlIOStdio_error,
2802 PerlIOStdio_clearerr,
2803 PerlIOStdio_setlinebuf,
9e353e3b 2804#ifdef FILE_base
14a5cf38
JH		 2805 PerlIOStdio_get_base,
2806 PerlIOStdio_get_bufsiz,
9e353e3b 2807#else
14a5cf38
JH		 2808 NULL,
2809 NULL,
9e353e3b
NIS		 2810#endif
2811#ifdef USE_STDIO_PTR
14a5cf38
JH		 2812 PerlIOStdio_get_ptr,
2813 PerlIOStdio_get_cnt,
0eb1d8a4 2814#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
14a5cf38
JH		 2815 PerlIOStdio_set_ptrcnt
2816#else /* STDIO_PTR_LVALUE */
2817 NULL
2818#endif /* STDIO_PTR_LVALUE */
2819#else /* USE_STDIO_PTR */
2820 NULL,
2821 NULL,
2822 NULL
2823#endif /* USE_STDIO_PTR */
9e353e3b
NIS		 2824};
2825
9e353e3b
NIS		 2826FILE *
2827PerlIO_exportFILE(PerlIO *f, int fl)
2828{
e87a358a 2829 dTHX;
14a5cf38
JH		 2830 FILE *stdio;
2831 PerlIO_flush(f);
2832 stdio = fdopen(PerlIO_fileno(f), "r+");
2833 if (stdio) {
14a5cf38
JH		 2834 PerlIOStdio *s =
2835 PerlIOSelf(PerlIO_push(aTHX_ f, &PerlIO_stdio, "r+", Nullsv),
2836 PerlIOStdio);
2837 s->stdio = stdio;
2838 }
2839 return stdio;
9e353e3b
NIS		 2840}
2841
9e353e3b
NIS		 2842FILE *
2843PerlIO_findFILE(PerlIO *f)
2844{
14a5cf38
JH		 2845 PerlIOl *l = *f;
2846 while (l) {
2847 if (l->tab == &PerlIO_stdio) {
2848 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
2849 return s->stdio;
2850 }
2851 l = *PerlIONext(&l);
f7e7eb72 2852 }
14a5cf38 2853 return PerlIO_exportFILE(f, 0);
9e353e3b
NIS		 2854}
2855
9e353e3b
NIS		 2856void
2857PerlIO_releaseFILE(PerlIO *p, FILE *f)
2858{
2859}
2860
2861/*--------------------------------------------------------------------------------------*/
14a5cf38 2862/*
71200d45 2863 * perlio buffer layer
14a5cf38 2864 */
9e353e3b 2865
5e2ab84b 2866IV
f62ce20a 2867PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
5e2ab84b 2868{
14a5cf38
JH		 2869 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2870 int fd = PerlIO_fileno(f);
2871 Off_t posn;
2872 if (fd >= 0 && PerlLIO_isatty(fd)) {
2873 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
2874 }
2875 posn = PerlIO_tell(PerlIONext(f));
2876 if (posn != (Off_t) - 1) {
2877 b->posn = posn;
2878 }
f62ce20a 2879 return PerlIOBase_pushed(aTHX_ f, mode, arg);
5e2ab84b
NIS		 2880}
2881
9e353e3b 2882PerlIO *
14a5cf38
JH		 2883PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2884 IV n, const char *mode, int fd, int imode, int perm,
2885 PerlIO *f, int narg, SV **args)
2886{
04892f78 2887 if (PerlIOValid(f)) {
14a5cf38 2888 PerlIO *next = PerlIONext(f);
04892f78
NIS		 2889 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
2890 next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
14a5cf38 2891 next, narg, args);
04892f78 2892 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
14a5cf38
JH		 2893 return NULL;
2894 }
2895 }
2896 else {
04892f78 2897 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
14a5cf38
JH		 2898 int init = 0;
2899 if (*mode == 'I') {
2900 init = 1;
2901 /*
71200d45 2902 * mode++;
14a5cf38
JH		 2903 */
2904 }
2905 f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
d9dac8cd 2906 f, narg, args);
14a5cf38 2907 if (f) {
b26b1ab5
NC		 2908 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
2909 /*
2910 * if push fails during open, open fails. close will pop us.
2911 */
2912 PerlIO_close (f);
2913 return NULL;
2914 } else {
2915 fd = PerlIO_fileno(f);
b26b1ab5
NC		 2916 if (init && fd == 2) {
2917 /*
2918 * Initial stderr is unbuffered
2919 */
2920 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2921 }
23b84778
IZ		 2922#ifdef PERLIO_USING_CRLF
2923# ifdef PERLIO_IS_BINMODE_FD
2924 if (PERLIO_IS_BINMODE_FD(fd))
2925 PerlIO_binmode(f, '<'/*not used*/, O_BINARY, Nullch);
2926 else
2927# endif
2928 /*
2929 * do something about failing setmode()? --jhi
2930 */
2931 PerlLIO_setmode(fd, O_BINARY);
2932#endif
14a5cf38
JH		 2933 }
2934 }
ee518936 2935 }
14a5cf38 2936 return f;
9e353e3b
NIS		 2937}
2938
14a5cf38
JH		 2939/*
2940 * This "flush" is akin to sfio's sync in that it handles files in either
71200d45 2941 * read or write state
14a5cf38 2942 */
9e353e3b 2943IV
f62ce20a 2944PerlIOBuf_flush(pTHX_ PerlIO *f)
6f9d8c32 2945{
14a5cf38
JH		 2946 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2947 int code = 0;
04892f78 2948 PerlIO *n = PerlIONext(f);
14a5cf38
JH		 2949 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
2950 /*
71200d45 2951 * write() the buffer
14a5cf38
JH		 2952 */
2953 STDCHAR *buf = b->buf;
2954 STDCHAR *p = buf;
14a5cf38
JH		 2955 while (p < b->ptr) {
2956 SSize_t count = PerlIO_write(n, p, b->ptr - p);
2957 if (count > 0) {
2958 p += count;
2959 }
2960 else if (count < 0 || PerlIO_error(n)) {
2961 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2962 code = -1;
2963 break;
2964 }
2965 }
2966 b->posn += (p - buf);
2967 }
2968 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
2969 STDCHAR *buf = PerlIO_get_base(f);
2970 /*
71200d45 2971 * Note position change
14a5cf38
JH		 2972 */
2973 b->posn += (b->ptr - buf);
2974 if (b->ptr < b->end) {
2975 /*
71200d45 2976 * We did not consume all of it
14a5cf38 2977 */
04892f78
NIS		 2978 if (PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
2979 /* Reload n as some layers may pop themselves on seek */
2980 b->posn = PerlIO_tell(n = PerlIONext(f));
14a5cf38
JH		 2981 }
2982 }
2983 }
2984 b->ptr = b->end = b->buf;
2985 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
04892f78
NIS		 2986 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
2987 /* FIXME: Doing downstream flush may be sub-optimal see PerlIOBuf_fill() below */
2988 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
14a5cf38
JH		 2989 code = -1;
2990 return code;
6f9d8c32
NIS		 2991}
2992
06da4f11 2993IV
f62ce20a 2994PerlIOBuf_fill(pTHX_ PerlIO *f)
06da4f11 2995{
14a5cf38
JH		 2996 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
2997 PerlIO *n = PerlIONext(f);
2998 SSize_t avail;
2999 /*
04892f78
NIS		 3000 * FIXME: doing the down-stream flush maybe sub-optimal if it causes
3001 * pre-read data in stdio buffer to be discarded.
3002 * However, skipping the flush also skips _our_ hosekeeping
3003 * and breaks tell tests. So we do the flush.
14a5cf38
JH		 3004 */
3005 if (PerlIO_flush(f) != 0)
3006 return -1;
3007 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
f62ce20a 3008 PerlIOBase_flush_linebuf(aTHX);
14a5cf38
JH		 3009
3010 if (!b->buf)
3011 PerlIO_get_base(f); /* allocate via vtable */
3012
3013 b->ptr = b->end = b->buf;
3014 if (PerlIO_fast_gets(n)) {
3015 /*
04892f78 3016 * Layer below is also buffered. We do _NOT_ want to call its
14a5cf38
JH		 3017 * ->Read() because that will loop till it gets what we asked for
3018 * which may hang on a pipe etc. Instead take anything it has to
71200d45 3019 * hand, or ask it to fill _once_.
14a5cf38
JH		 3020 */
3021 avail = PerlIO_get_cnt(n);
3022 if (avail <= 0) {
3023 avail = PerlIO_fill(n);
3024 if (avail == 0)
3025 avail = PerlIO_get_cnt(n);
3026 else {
3027 if (!PerlIO_error(n) && PerlIO_eof(n))
3028 avail = 0;
3029 }
3030 }
3031 if (avail > 0) {
3032 STDCHAR *ptr = PerlIO_get_ptr(n);
3033 SSize_t cnt = avail;
eb160463 3034 if (avail > (SSize_t)b->bufsiz)
14a5cf38
JH		 3035 avail = b->bufsiz;
3036 Copy(ptr, b->buf, avail, STDCHAR);
3037 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
3038 }
3039 }
3040 else {
3041 avail = PerlIO_read(n, b->ptr, b->bufsiz);
3042 }
3043 if (avail <= 0) {
3044 if (avail == 0)
3045 PerlIOBase(f)->flags |= PERLIO_F_EOF;
3046 else
3047 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3048 return -1;
3049 }
3050 b->end = b->buf + avail;
3051 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3052 return 0;
06da4f11
NIS		 3053}
3054
6f9d8c32 3055SSize_t
f62ce20a 3056PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 3057{
14a5cf38 3058 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
04892f78 3059 if (PerlIOValid(f)) {
14a5cf38
JH		 3060 if (!b->ptr)
3061 PerlIO_get_base(f);
f62ce20a 3062 return PerlIOBase_read(aTHX_ f, vbuf, count);
14a5cf38
JH		 3063 }
3064 return 0;
6f9d8c32
NIS		 3065}
3066
9e353e3b 3067SSize_t
f62ce20a 3068PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 3069{
14a5cf38
JH		 3070 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3071 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3072 SSize_t unread = 0;
3073 SSize_t avail;
3074 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3075 PerlIO_flush(f);
3076 if (!b->buf)
3077 PerlIO_get_base(f);
3078 if (b->buf) {
3079 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3080 /*
3081 * Buffer is already a read buffer, we can overwrite any chars
71200d45 3082 * which have been read back to buffer start
14a5cf38
JH		 3083 */
3084 avail = (b->ptr - b->buf);
3085 }
3086 else {
3087 /*
3088 * Buffer is idle, set it up so whole buffer is available for
71200d45 3089 * unread
14a5cf38
JH		 3090 */
3091 avail = b->bufsiz;
3092 b->end = b->buf + avail;
3093 b->ptr = b->end;
3094 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3095 /*
71200d45 3096 * Buffer extends _back_ from where we are now
14a5cf38
JH		 3097 */
3098 b->posn -= b->bufsiz;
3099 }
3100 if (avail > (SSize_t) count) {
3101 /*
71200d45 3102 * If we have space for more than count, just move count
14a5cf38
JH		 3103 */
3104 avail = count;
3105 }
3106 if (avail > 0) {
3107 b->ptr -= avail;
3108 buf -= avail;
3109 /*
3110 * In simple stdio-like ungetc() case chars will be already
71200d45 3111 * there
14a5cf38
JH		 3112 */
3113 if (buf != b->ptr) {
3114 Copy(buf, b->ptr, avail, STDCHAR);
3115 }
3116 count -= avail;
3117 unread += avail;
3118 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3119 }
3120 }
3121 return unread;
760ac839
LW		 3122}
3123
9e353e3b 3124SSize_t
f62ce20a 3125PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
760ac839 3126{
14a5cf38
JH		 3127 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3128 const STDCHAR *buf = (const STDCHAR *) vbuf;
3129 Size_t written = 0;
3130 if (!b->buf)
3131 PerlIO_get_base(f);
3132 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3133 return 0;
3134 while (count > 0) {
3135 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
3136 if ((SSize_t) count < avail)
3137 avail = count;
3138 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3139 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3140 while (avail > 0) {
3141 int ch = *buf++;
3142 *(b->ptr)++ = ch;
3143 count--;
3144 avail--;
3145 written++;
3146 if (ch == '\n') {
3147 PerlIO_flush(f);
3148 break;
3149 }
3150 }
3151 }
3152 else {
3153 if (avail) {
3154 Copy(buf, b->ptr, avail, STDCHAR);
3155 count -= avail;
3156 buf += avail;
3157 written += avail;
3158 b->ptr += avail;
3159 }
3160 }
3161 if (b->ptr >= (b->buf + b->bufsiz))
3162 PerlIO_flush(f);
3163 }
3164 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3165 PerlIO_flush(f);
3166 return written;
9e353e3b
NIS		 3167}
3168
3169IV
f62ce20a 3170PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
9e353e3b 3171{
14a5cf38
JH		 3172 IV code;
3173 if ((code = PerlIO_flush(f)) == 0) {
3174 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3175 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3176 code = PerlIO_seek(PerlIONext(f), offset, whence);
3177 if (code == 0) {
3178 b->posn = PerlIO_tell(PerlIONext(f));
3179 }
9e353e3b 3180 }
14a5cf38 3181 return code;
9e353e3b
NIS		 3182}
3183
3184Off_t
f62ce20a 3185PerlIOBuf_tell(pTHX_ PerlIO *f)
9e353e3b 3186{
14a5cf38
JH		 3187 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3188 /*
71200d45 3189 * b->posn is file position where b->buf was read, or will be written
14a5cf38
JH		 3190 */
3191 Off_t posn = b->posn;
3192 if (b->buf) {
3193 /*
71200d45 3194 * If buffer is valid adjust position by amount in buffer
14a5cf38
JH		 3195 */
3196 posn += (b->ptr - b->buf);
3197 }
3198 return posn;
9e353e3b
NIS		 3199}
3200
3201IV
f62ce20a 3202PerlIOBuf_close(pTHX_ PerlIO *f)
9e353e3b 3203{
f62ce20a 3204 IV code = PerlIOBase_close(aTHX_ f);
14a5cf38
JH		 3205 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3206 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 3207 Safefree(b->buf);
14a5cf38
JH		 3208 }
3209 b->buf = NULL;
3210 b->ptr = b->end = b->buf;
3211 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3212 return code;
760ac839
LW		 3213}
3214
9e353e3b 3215STDCHAR *
f62ce20a 3216PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
9e353e3b 3217{
14a5cf38
JH		 3218 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3219 if (!b->buf)
3220 PerlIO_get_base(f);
3221 return b->ptr;
9e353e3b
NIS		 3222}
3223
05d1247b 3224SSize_t
f62ce20a 3225PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
9e353e3b 3226{
14a5cf38
JH		 3227 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3228 if (!b->buf)
3229 PerlIO_get_base(f);
3230 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3231 return (b->end - b->ptr);
3232 return 0;
9e353e3b
NIS		 3233}
3234
3235STDCHAR *
f62ce20a 3236PerlIOBuf_get_base(pTHX_ PerlIO *f)
9e353e3b 3237{
14a5cf38
JH		 3238 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3239 if (!b->buf) {
3240 if (!b->bufsiz)
3241 b->bufsiz = 4096;
a1ea730d 3242 b->buf =
7fcdafbd 3243 Newz('B',b->buf,b->bufsiz, STDCHAR);
14a5cf38
JH		 3244 if (!b->buf) {
3245 b->buf = (STDCHAR *) & b->oneword;
3246 b->bufsiz = sizeof(b->oneword);
3247 }
3248 b->ptr = b->buf;
3249 b->end = b->ptr;
06da4f11 3250 }
14a5cf38 3251 return b->buf;
9e353e3b
NIS		 3252}
3253
3254Size_t
f62ce20a 3255PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
9e353e3b 3256{
14a5cf38
JH		 3257 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3258 if (!b->buf)
3259 PerlIO_get_base(f);
3260 return (b->end - b->buf);
9e353e3b
NIS		 3261}
3262
3263void
f62ce20a 3264PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
9e353e3b 3265{
14a5cf38
JH		 3266 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3267 if (!b->buf)
3268 PerlIO_get_base(f);
3269 b->ptr = ptr;
3270 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) {
14a5cf38
JH		 3271 assert(PerlIO_get_cnt(f) == cnt);
3272 assert(b->ptr >= b->buf);
3273 }
3274 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW		 3275}
3276
71200d45 3277PerlIO *
ecdeb87c 3278PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 3279{
ecdeb87c 3280 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 3281}
3282
3283
3284
9e353e3b 3285PerlIO_funcs PerlIO_perlio = {
14a5cf38
JH		 3286 "perlio",
3287 sizeof(PerlIOBuf),
3288 PERLIO_K_BUFFERED,
3289 PerlIOBuf_pushed,
3290 PerlIOBase_noop_ok,
3291 PerlIOBuf_open,
3292 NULL,
3293 PerlIOBase_fileno,
71200d45 3294 PerlIOBuf_dup,
14a5cf38
JH		 3295 PerlIOBuf_read,
3296 PerlIOBuf_unread,
3297 PerlIOBuf_write,
3298 PerlIOBuf_seek,
3299 PerlIOBuf_tell,
3300 PerlIOBuf_close,
3301 PerlIOBuf_flush,
3302 PerlIOBuf_fill,
3303 PerlIOBase_eof,
3304 PerlIOBase_error,
3305 PerlIOBase_clearerr,
3306 PerlIOBase_setlinebuf,
3307 PerlIOBuf_get_base,
3308 PerlIOBuf_bufsiz,
3309 PerlIOBuf_get_ptr,
3310 PerlIOBuf_get_cnt,
3311 PerlIOBuf_set_ptrcnt,
9e353e3b
NIS		 3312};
3313
66ecd56b 3314/*--------------------------------------------------------------------------------------*/
14a5cf38 3315/*
71200d45 3316 * Temp layer to hold unread chars when cannot do it any other way
14a5cf38 3317 */
5e2ab84b
NIS		 3318
3319IV
f62ce20a 3320PerlIOPending_fill(pTHX_ PerlIO *f)
5e2ab84b 3321{
14a5cf38 3322 /*
71200d45 3323 * Should never happen
14a5cf38
JH		 3324 */
3325 PerlIO_flush(f);
3326 return 0;
5e2ab84b
NIS		 3327}
3328
3329IV
f62ce20a 3330PerlIOPending_close(pTHX_ PerlIO *f)
5e2ab84b 3331{
14a5cf38 3332 /*
71200d45 3333 * A tad tricky - flush pops us, then we close new top
14a5cf38
JH		 3334 */
3335 PerlIO_flush(f);
3336 return PerlIO_close(f);
5e2ab84b
NIS		 3337}
3338
3339IV
f62ce20a 3340PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
5e2ab84b 3341{
14a5cf38 3342 /*
71200d45 3343 * A tad tricky - flush pops us, then we seek new top
14a5cf38
JH		 3344 */
3345 PerlIO_flush(f);
3346 return PerlIO_seek(f, offset, whence);
5e2ab84b
NIS		 3347}
3348
3349
3350IV
f62ce20a 3351PerlIOPending_flush(pTHX_ PerlIO *f)
5e2ab84b 3352{
14a5cf38
JH		 3353 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3354 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
3a1ee7e8 3355 Safefree(b->buf);
14a5cf38
JH		 3356 b->buf = NULL;
3357 }
3358 PerlIO_pop(aTHX_ f);
3359 return 0;
5e2ab84b
NIS		 3360}
3361
3362void
f62ce20a 3363PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
5e2ab84b 3364{
14a5cf38
JH		 3365 if (cnt <= 0) {
3366 PerlIO_flush(f);
3367 }
3368 else {
f62ce20a 3369 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
14a5cf38 3370 }
5e2ab84b
NIS		 3371}
3372
3373IV
f62ce20a 3374PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
5e2ab84b 3375{
f62ce20a 3376 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
14a5cf38
JH		 3377 PerlIOl *l = PerlIOBase(f);
3378 /*
71200d45
NIS		 3379 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
3380 * etc. get muddled when it changes mid-string when we auto-pop.
14a5cf38
JH		 3381 */
3382 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
3383 (PerlIOBase(PerlIONext(f))->
3384 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
3385 return code;
5e2ab84b
NIS		 3386}
3387
3388SSize_t
f62ce20a 3389PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
5e2ab84b 3390{
14a5cf38
JH		 3391 SSize_t avail = PerlIO_get_cnt(f);
3392 SSize_t got = 0;
eb160463 3393 if ((SSize_t)count < avail)
14a5cf38
JH		 3394 avail = count;
3395 if (avail > 0)
f62ce20a 3396 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
eb160463 3397 if (got >= 0 && got < (SSize_t)count) {
14a5cf38
JH		 3398 SSize_t more =
3399 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
3400 if (more >= 0 || got == 0)
3401 got += more;
3402 }
3403 return got;
5e2ab84b
NIS		 3404}
3405
5e2ab84b 3406PerlIO_funcs PerlIO_pending = {
14a5cf38
JH		 3407 "pending",
3408 sizeof(PerlIOBuf),
3409 PERLIO_K_BUFFERED,
3410 PerlIOPending_pushed,
3411 PerlIOBase_noop_ok,
3412 NULL,
3413 NULL,
3414 PerlIOBase_fileno,
71200d45 3415 PerlIOBuf_dup,
14a5cf38
JH		 3416 PerlIOPending_read,
3417 PerlIOBuf_unread,
3418 PerlIOBuf_write,
3419 PerlIOPending_seek,
3420 PerlIOBuf_tell,
3421 PerlIOPending_close,
3422 PerlIOPending_flush,
3423 PerlIOPending_fill,
3424 PerlIOBase_eof,
3425 PerlIOBase_error,
3426 PerlIOBase_clearerr,
3427 PerlIOBase_setlinebuf,
3428 PerlIOBuf_get_base,
3429 PerlIOBuf_bufsiz,
3430 PerlIOBuf_get_ptr,
3431 PerlIOBuf_get_cnt,
3432 PerlIOPending_set_ptrcnt,
5e2ab84b
NIS		 3433};
3434
3435
3436
3437/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 3438/*
3439 * crlf - translation On read translate CR,LF to "\n" we do this by
3440 * overriding ptr/cnt entries to hand back a line at a time and keeping a
71200d45 3441 * record of which nl we "lied" about. On write translate "\n" to CR,LF
66ecd56b
NIS		 3442 */
3443
14a5cf38
JH		 3444typedef struct {
3445 PerlIOBuf base; /* PerlIOBuf stuff */
71200d45 3446 STDCHAR *nl; /* Position of crlf we "lied" about in the
14a5cf38 3447 * buffer */
99efab12
NIS		 3448} PerlIOCrlf;
3449
f5b9d040 3450IV
f62ce20a 3451PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
f5b9d040 3452{
14a5cf38
JH		 3453 IV code;
3454 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
f62ce20a 3455 code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
5e2ab84b 3456#if 0
14a5cf38
JH		 3457 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
3458 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
3459 PerlIOBase(f)->flags);
5e2ab84b 3460#endif
14a5cf38 3461 return code;
f5b9d040
NIS		 3462}
3463
3464
99efab12 3465SSize_t
f62ce20a 3466PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 3467{
14a5cf38
JH		 3468 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3469 if (c->nl) {
3470 *(c->nl) = 0xd;
3471 c->nl = NULL;
3472 }
3473 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 3474 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
14a5cf38
JH		 3475 else {
3476 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
3477 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3478 SSize_t unread = 0;
3479 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3480 PerlIO_flush(f);
3481 if (!b->buf)
3482 PerlIO_get_base(f);
3483 if (b->buf) {
3484 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3485 b->end = b->ptr = b->buf + b->bufsiz;
3486 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3487 b->posn -= b->bufsiz;
3488 }
3489 while (count > 0 && b->ptr > b->buf) {
3490 int ch = *--buf;
3491 if (ch == '\n') {
3492 if (b->ptr - 2 >= b->buf) {
3493 *--(b->ptr) = 0xa;
3494 *--(b->ptr) = 0xd;
3495 unread++;
3496 count--;
3497 }
3498 else {
3499 buf++;
3500 break;
3501 }
3502 }
3503 else {
3504 *--(b->ptr) = ch;
3505 unread++;
3506 count--;
3507 }
3508 }
3509 }
3510 return unread;
3511 }
99efab12
NIS		 3512}
3513
3514SSize_t
f62ce20a 3515PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
99efab12 3516{
14a5cf38
JH		 3517 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3518 if (!b->buf)
3519 PerlIO_get_base(f);
3520 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3521 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
23b3c6af
NIS		 3522 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) {
3523 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
14a5cf38
JH		 3524 scan:
3525 while (nl < b->end && *nl != 0xd)
3526 nl++;
3527 if (nl < b->end && *nl == 0xd) {
3528 test:
3529 if (nl + 1 < b->end) {
3530 if (nl[1] == 0xa) {
3531 *nl = '\n';
3532 c->nl = nl;
3533 }
3534 else {
3535 /*
71200d45 3536 * Not CR,LF but just CR
14a5cf38
JH		 3537 */
3538 nl++;
3539 goto scan;
3540 }
3541 }
3542 else {
3543 /*
71200d45 3544 * Blast - found CR as last char in buffer
14a5cf38 3545 */
e87a358a 3546
14a5cf38
JH		 3547 if (b->ptr < nl) {
3548 /*
3549 * They may not care, defer work as long as
71200d45 3550 * possible
14a5cf38 3551 */
a0d1d361 3552 c->nl = nl;
14a5cf38
JH		 3553 return (nl - b->ptr);
3554 }
3555 else {
3556 int code;
3557 b->ptr++; /* say we have read it as far as
3558 * flush() is concerned */
d1be9408 3559 b->buf++; /* Leave space in front of buffer */
14a5cf38
JH		 3560 b->bufsiz--; /* Buffer is thus smaller */
3561 code = PerlIO_fill(f); /* Fetch some more */
3562 b->bufsiz++; /* Restore size for next time */
3563 b->buf--; /* Point at space */
3564 b->ptr = nl = b->buf; /* Which is what we hand
3565 * off */
3566 b->posn--; /* Buffer starts here */
3567 *nl = 0xd; /* Fill in the CR */
3568 if (code == 0)
3569 goto test; /* fill() call worked */
3570 /*
71200d45 3571 * CR at EOF - just fall through
14a5cf38 3572 */
a0d1d361 3573 /* Should we clear EOF though ??? */
14a5cf38
JH		 3574 }
3575 }
3576 }
3577 }
3578 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
3579 }
3580 return 0;
99efab12
NIS		 3581}
3582
3583void
f62ce20a 3584PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
14a5cf38
JH		 3585{
3586 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3587 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
14a5cf38
JH		 3588 if (!b->buf)
3589 PerlIO_get_base(f);
3590 if (!ptr) {
a0d1d361 3591 if (c->nl) {
14a5cf38 3592 ptr = c->nl + 1;
a0d1d361
NIS		 3593 if (ptr == b->end && *c->nl == 0xd) {
3594 /* Defered CR at end of buffer case - we lied about count */
3595 ptr--;
3596 }
3597 }
14a5cf38
JH		 3598 else {
3599 ptr = b->end;
14a5cf38
JH		 3600 }
3601 ptr -= cnt;
3602 }
3603 else {
3b4bd3fd 3604#if 0
14a5cf38 3605 /*
71200d45 3606 * Test code - delete when it works ...
14a5cf38 3607 */
3b4bd3fd 3608 IV flags = PerlIOBase(f)->flags;
ba7abf9d 3609 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
a0d1d361
NIS		 3610 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) {
3611 /* Defered CR at end of buffer case - we lied about count */
3612 chk--;
e87a358a 3613 }
14a5cf38
JH		 3614 chk -= cnt;
3615
a0d1d361 3616 if (ptr != chk ) {
99ef548b 3617 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
14a5cf38
JH		 3618 " nl=%p e=%p for %d", ptr, chk, flags, c->nl,
3619 b->end, cnt);
3620 }
99ef548b 3621#endif
14a5cf38
JH		 3622 }
3623 if (c->nl) {
3624 if (ptr > c->nl) {
3625 /*
71200d45 3626 * They have taken what we lied about
14a5cf38
JH		 3627 */
3628 *(c->nl) = 0xd;
3629 c->nl = NULL;
3630 ptr++;
3631 }
3632 }
3633 b->ptr = ptr;
3634 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
99efab12
NIS		 3635}
3636
3637SSize_t
f62ce20a 3638PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
99efab12 3639{
14a5cf38 3640 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
f62ce20a 3641 return PerlIOBuf_write(aTHX_ f, vbuf, count);
14a5cf38
JH		 3642 else {
3643 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3644 const STDCHAR *buf = (const STDCHAR *) vbuf;
3645 const STDCHAR *ebuf = buf + count;
3646 if (!b->buf)
3647 PerlIO_get_base(f);
3648 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3649 return 0;
3650 while (buf < ebuf) {
3651 STDCHAR *eptr = b->buf + b->bufsiz;
3652 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3653 while (buf < ebuf && b->ptr < eptr) {
3654 if (*buf == '\n') {
3655 if ((b->ptr + 2) > eptr) {
3656 /*
71200d45 3657 * Not room for both
14a5cf38
JH		 3658 */
3659 PerlIO_flush(f);
3660 break;
3661 }
3662 else {
3663 *(b->ptr)++ = 0xd; /* CR */
3664 *(b->ptr)++ = 0xa; /* LF */
3665 buf++;
3666 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
3667 PerlIO_flush(f);
3668 break;
3669 }
3670 }
3671 }
3672 else {
3673 int ch = *buf++;
3674 *(b->ptr)++ = ch;
3675 }
3676 if (b->ptr >= eptr) {
3677 PerlIO_flush(f);
3678 break;
3679 }
3680 }
3681 }
3682 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3683 PerlIO_flush(f);
3684 return (buf - (STDCHAR *) vbuf);
3685 }
99efab12
NIS		 3686}
3687
3688IV
f62ce20a 3689PerlIOCrlf_flush(pTHX_ PerlIO *f)
99efab12 3690{
14a5cf38
JH		 3691 PerlIOCrlf *c = PerlIOSelf(f, PerlIOCrlf);
3692 if (c->nl) {
3693 *(c->nl) = 0xd;
3694 c->nl = NULL;
3695 }
f62ce20a 3696 return PerlIOBuf_flush(aTHX_ f);
99efab12
NIS		 3697}
3698
66ecd56b 3699PerlIO_funcs PerlIO_crlf = {
14a5cf38
JH		 3700 "crlf",
3701 sizeof(PerlIOCrlf),
3702 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
3703 PerlIOCrlf_pushed,
3704 PerlIOBase_noop_ok, /* popped */
3705 PerlIOBuf_open,
3706 NULL,
3707 PerlIOBase_fileno,
71200d45 3708 PerlIOBuf_dup,
14a5cf38
JH		 3709 PerlIOBuf_read, /* generic read works with ptr/cnt lies
3710 * ... */
3711 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3712 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
3713 PerlIOBuf_seek,
3714 PerlIOBuf_tell,
3715 PerlIOBuf_close,
3716 PerlIOCrlf_flush,
3717 PerlIOBuf_fill,
3718 PerlIOBase_eof,
3719 PerlIOBase_error,
3720 PerlIOBase_clearerr,
3721 PerlIOBase_setlinebuf,
3722 PerlIOBuf_get_base,
3723 PerlIOBuf_bufsiz,
3724 PerlIOBuf_get_ptr,
3725 PerlIOCrlf_get_cnt,
3726 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS		 3727};
3728
06da4f11
NIS		 3729#ifdef HAS_MMAP
3730/*--------------------------------------------------------------------------------------*/
14a5cf38 3731/*
71200d45 3732 * mmap as "buffer" layer
14a5cf38 3733 */
06da4f11 3734
14a5cf38
JH		 3735typedef struct {
3736 PerlIOBuf base; /* PerlIOBuf stuff */
3737 Mmap_t mptr; /* Mapped address */
3738 Size_t len; /* mapped length */
3739 STDCHAR *bbuf; /* malloced buffer if map fails */
06da4f11
NIS		 3740} PerlIOMmap;
3741
c3d7c7c9
NIS		 3742static size_t page_size = 0;
3743
06da4f11 3744IV
f62ce20a 3745PerlIOMmap_map(pTHX_ PerlIO *f)
06da4f11 3746{
14a5cf38
JH		 3747 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3748 IV flags = PerlIOBase(f)->flags;
3749 IV code = 0;
3750 if (m->len)
3751 abort();
3752 if (flags & PERLIO_F_CANREAD) {
3753 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3754 int fd = PerlIO_fileno(f);
10eefe7f
CB		 3755 Stat_t st;
3756 code = Fstat(fd, &st);
14a5cf38
JH		 3757 if (code == 0 && S_ISREG(st.st_mode)) {
3758 SSize_t len = st.st_size - b->posn;
3759 if (len > 0) {
3760 Off_t posn;
3761 if (!page_size) {
68d873c6 3762#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
14a5cf38
JH		 3763 {
3764 SETERRNO(0, SS$_NORMAL);
68d873c6 3765# ifdef _SC_PAGESIZE
14a5cf38 3766 page_size = sysconf(_SC_PAGESIZE);
68d873c6 3767# else
14a5cf38 3768 page_size = sysconf(_SC_PAGE_SIZE);
14aaf8e8 3769# endif
14a5cf38
JH		 3770 if ((long) page_size < 0) {
3771 if (errno) {
3772 SV *error = ERRSV;
3773 char *msg;
3774 STRLEN n_a;
3775 (void) SvUPGRADE(error, SVt_PV);
3776 msg = SvPVx(error, n_a);
3777 Perl_croak(aTHX_ "panic: sysconf: %s",
3778 msg);
3779 }
3780 else
3781 Perl_croak(aTHX_
3782 "panic: sysconf: pagesize unknown");
3783 }
3784 }
68d873c6
JH		 3785#else
3786# ifdef HAS_GETPAGESIZE
14a5cf38 3787 page_size = getpagesize();
68d873c6
JH		 3788# else
3789# if defined(I_SYS_PARAM) && defined(PAGESIZE)
14a5cf38 3790 page_size = PAGESIZE; /* compiletime, bad */
68d873c6
JH		 3791# endif
3792# endif
3793#endif
14a5cf38
JH		 3794 if ((IV) page_size <= 0)
3795 Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
3796 (IV) page_size);
3797 }
3798 if (b->posn < 0) {
3799 /*
3800 * This is a hack - should never happen - open should
71200d45 3801 * have set it !
14a5cf38
JH		 3802 */
3803 b->posn = PerlIO_tell(PerlIONext(f));
3804 }
3805 posn = (b->posn / page_size) * page_size;
3806 len = st.st_size - posn;
3807 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
3808 if (m->mptr && m->mptr != (Mmap_t) - 1) {
a5262162 3809#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
14a5cf38 3810 madvise(m->mptr, len, MADV_SEQUENTIAL);
06da4f11 3811#endif
a5262162 3812#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
14a5cf38 3813 madvise(m->mptr, len, MADV_WILLNEED);
a5262162 3814#endif
14a5cf38
JH		 3815 PerlIOBase(f)->flags =
3816 (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3817 b->end = ((STDCHAR *) m->mptr) + len;
3818 b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
3819 b->ptr = b->buf;
3820 m->len = len;
3821 }
3822 else {
3823 b->buf = NULL;
3824 }
3825 }
3826 else {
3827 PerlIOBase(f)->flags =
3828 flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3829 b->buf = NULL;
3830 b->ptr = b->end = b->ptr;
3831 code = -1;
3832 }
3833 }
3834 }
3835 return code;
06da4f11
NIS		 3836}
3837
3838IV
e87a358a 3839PerlIOMmap_unmap(pTHX_ PerlIO *f)
06da4f11 3840{
14a5cf38
JH		 3841 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3842 PerlIOBuf *b = &m->base;
3843 IV code = 0;
3844 if (m->len) {
3845 if (b->buf) {
3846 code = munmap(m->mptr, m->len);
3847 b->buf = NULL;
3848 m->len = 0;
3849 m->mptr = NULL;
3850 if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
3851 code = -1;
3852 }
3853 b->ptr = b->end = b->buf;
3854 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3855 }
3856 return code;
06da4f11
NIS		 3857}
3858
3859STDCHAR *
f62ce20a 3860PerlIOMmap_get_base(pTHX_ PerlIO *f)
06da4f11 3861{
14a5cf38
JH		 3862 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3863 PerlIOBuf *b = &m->base;
3864 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
3865 /*
71200d45 3866 * Already have a readbuffer in progress
14a5cf38
JH		 3867 */
3868 return b->buf;
3869 }
3870 if (b->buf) {
3871 /*
71200d45 3872 * We have a write buffer or flushed PerlIOBuf read buffer
14a5cf38
JH		 3873 */
3874 m->bbuf = b->buf; /* save it in case we need it again */
3875 b->buf = NULL; /* Clear to trigger below */
3876 }
3877 if (!b->buf) {
f62ce20a 3878 PerlIOMmap_map(aTHX_ f); /* Try and map it */
14a5cf38
JH		 3879 if (!b->buf) {
3880 /*
71200d45 3881 * Map did not work - recover PerlIOBuf buffer if we have one
14a5cf38
JH		 3882 */
3883 b->buf = m->bbuf;
3884 }
3885 }
3886 b->ptr = b->end = b->buf;
3887 if (b->buf)
3888 return b->buf;
f62ce20a 3889 return PerlIOBuf_get_base(aTHX_ f);
06da4f11
NIS		 3890}
3891
3892SSize_t
f62ce20a 3893PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
06da4f11 3894{
14a5cf38
JH		 3895 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3896 PerlIOBuf *b = &m->base;
3897 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3898 PerlIO_flush(f);
3899 if (b->ptr && (b->ptr - count) >= b->buf
3900 && memEQ(b->ptr - count, vbuf, count)) {
3901 b->ptr -= count;
3902 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
3903 return count;
3904 }
3905 if (m->len) {
3906 /*
71200d45 3907 * Loose the unwritable mapped buffer
14a5cf38
JH		 3908 */
3909 PerlIO_flush(f);
3910 /*
71200d45 3911 * If flush took the "buffer" see if we have one from before
14a5cf38
JH		 3912 */
3913 if (!b->buf && m->bbuf)
3914 b->buf = m->bbuf;
3915 if (!b->buf) {
f62ce20a 3916 PerlIOBuf_get_base(aTHX_ f);
14a5cf38
JH		 3917 m->bbuf = b->buf;
3918 }
3919 }
f62ce20a 3920 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
06da4f11
NIS		 3921}
3922
3923SSize_t
f62ce20a 3924PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
06da4f11 3925{
14a5cf38
JH		 3926 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3927 PerlIOBuf *b = &m->base;
3928 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
3929 /*
71200d45 3930 * No, or wrong sort of, buffer
14a5cf38
JH		 3931 */
3932 if (m->len) {
e87a358a 3933 if (PerlIOMmap_unmap(aTHX_ f) != 0)
14a5cf38
JH		 3934 return 0;
3935 }
3936 /*
71200d45 3937 * If unmap took the "buffer" see if we have one from before
14a5cf38
JH		 3938 */
3939 if (!b->buf && m->bbuf)
3940 b->buf = m->bbuf;
3941 if (!b->buf) {
f62ce20a 3942 PerlIOBuf_get_base(aTHX_ f);
14a5cf38
JH		 3943 m->bbuf = b->buf;
3944 }
06da4f11 3945 }
f62ce20a 3946 return PerlIOBuf_write(aTHX_ f, vbuf, count);
06da4f11
NIS		 3947}
3948
3949IV
f62ce20a 3950PerlIOMmap_flush(pTHX_ PerlIO *f)
06da4f11 3951{
14a5cf38
JH		 3952 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3953 PerlIOBuf *b = &m->base;
f62ce20a 3954 IV code = PerlIOBuf_flush(aTHX_ f);
14a5cf38 3955 /*
71200d45 3956 * Now we are "synced" at PerlIOBuf level
14a5cf38
JH		 3957 */
3958 if (b->buf) {
3959 if (m->len) {
3960 /*
71200d45 3961 * Unmap the buffer
14a5cf38 3962 */
e87a358a 3963 if (PerlIOMmap_unmap(aTHX_ f) != 0)
14a5cf38
JH		 3964 code = -1;
3965 }
3966 else {
3967 /*
3968 * We seem to have a PerlIOBuf buffer which was not mapped
71200d45 3969 * remember it in case we need one later
14a5cf38
JH		 3970 */
3971 m->bbuf = b->buf;
3972 }
3973 }
3974 return code;
06da4f11
NIS		 3975}
3976
3977IV
f62ce20a 3978PerlIOMmap_fill(pTHX_ PerlIO *f)
06da4f11 3979{
14a5cf38
JH		 3980 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3981 IV code = PerlIO_flush(f);
3982 if (code == 0 && !b->buf) {
f62ce20a 3983 code = PerlIOMmap_map(aTHX_ f);
14a5cf38
JH		 3984 }
3985 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
f62ce20a 3986 code = PerlIOBuf_fill(aTHX_ f);
14a5cf38
JH		 3987 }
3988 return code;
06da4f11
NIS		 3989}
3990
3991IV
f62ce20a 3992PerlIOMmap_close(pTHX_ PerlIO *f)
06da4f11 3993{
14a5cf38
JH		 3994 PerlIOMmap *m = PerlIOSelf(f, PerlIOMmap);
3995 PerlIOBuf *b = &m->base;
3996 IV code = PerlIO_flush(f);
3997 if (m->bbuf) {
3998 b->buf = m->bbuf;
3999 m->bbuf = NULL;
4000 b->ptr = b->end = b->buf;
4001 }
f62ce20a 4002 if (PerlIOBuf_close(aTHX_ f) != 0)
14a5cf38
JH		 4003 code = -1;
4004 return code;
06da4f11
NIS		 4005}
4006
71200d45 4007PerlIO *
ecdeb87c 4008PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
71200d45 4009{
ecdeb87c 4010 return PerlIOBase_dup(aTHX_ f, o, param, flags);
71200d45
NIS		 4011}
4012
06da4f11
NIS		 4013
4014PerlIO_funcs PerlIO_mmap = {
14a5cf38
JH		 4015 "mmap",
4016 sizeof(PerlIOMmap),
4017 PERLIO_K_BUFFERED,
4018 PerlIOBuf_pushed,
4019 PerlIOBase_noop_ok,
4020 PerlIOBuf_open,
4021 NULL,
4022 PerlIOBase_fileno,
71200d45 4023 PerlIOMmap_dup,
14a5cf38
JH		 4024 PerlIOBuf_read,
4025 PerlIOMmap_unread,
4026 PerlIOMmap_write,
4027 PerlIOBuf_seek,
4028 PerlIOBuf_tell,
4029 PerlIOBuf_close,
4030 PerlIOMmap_flush,
4031 PerlIOMmap_fill,
4032 PerlIOBase_eof,
4033 PerlIOBase_error,
4034 PerlIOBase_clearerr,
4035 PerlIOBase_setlinebuf,
4036 PerlIOMmap_get_base,
4037 PerlIOBuf_bufsiz,
4038 PerlIOBuf_get_ptr,
4039 PerlIOBuf_get_cnt,
4040 PerlIOBuf_set_ptrcnt,
06da4f11
NIS		 4041};
4042
14a5cf38 4043#endif /* HAS_MMAP */
06da4f11 4044
9e353e3b 4045PerlIO *
e87a358a 4046Perl_PerlIO_stdin(pTHX)
9e353e3b 4047{
a1ea730d 4048 if (!PL_perlio) {
14a5cf38
JH		 4049 PerlIO_stdstreams(aTHX);
4050 }
a1ea730d 4051 return &PL_perlio[1];
9e353e3b
NIS		 4052}
4053
9e353e3b 4054PerlIO *
e87a358a 4055Perl_PerlIO_stdout(pTHX)
9e353e3b 4056{
a1ea730d 4057 if (!PL_perlio) {
14a5cf38
JH		 4058 PerlIO_stdstreams(aTHX);
4059 }
a1ea730d 4060 return &PL_perlio[2];
9e353e3b
NIS		 4061}
4062
9e353e3b 4063PerlIO *
e87a358a 4064Perl_PerlIO_stderr(pTHX)
9e353e3b 4065{
a1ea730d 4066 if (!PL_perlio) {
14a5cf38
JH		 4067 PerlIO_stdstreams(aTHX);
4068 }
a1ea730d 4069 return &PL_perlio[3];
9e353e3b
NIS		 4070}
4071
4072/*--------------------------------------------------------------------------------------*/
4073
9e353e3b
NIS		 4074char *
4075PerlIO_getname(PerlIO *f, char *buf)
4076{
14a5cf38
JH		 4077 dTHX;
4078 char *name = NULL;
a15cef0c 4079#ifdef VMS
14a5cf38
JH		 4080 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4081 if (stdio)
4082 name = fgetname(stdio, buf);
a15cef0c 4083#else
14a5cf38 4084 Perl_croak(aTHX_ "Don't know how to get file name");
a15cef0c 4085#endif
14a5cf38 4086 return name;
9e353e3b
NIS		 4087}
4088
4089
4090/*--------------------------------------------------------------------------------------*/
14a5cf38
JH		 4091/*
4092 * Functions which can be called on any kind of PerlIO implemented in
71200d45 4093 * terms of above
14a5cf38 4094 */
9e353e3b 4095
e87a358a
NIS		 4096#undef PerlIO_fdopen
4097PerlIO *
4098PerlIO_fdopen(int fd, const char *mode)
4099{
4100 dTHX;
4101 return PerlIO_openn(aTHX_ Nullch, mode, fd, 0, 0, NULL, 0, NULL);
4102}
4103
4104#undef PerlIO_open
4105PerlIO *
4106PerlIO_open(const char *path, const char *mode)
4107{
4108 dTHX;
4109 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4110 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, NULL, 1, &name);
4111}
4112
4113#undef Perlio_reopen
4114PerlIO *
4115PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4116{
4117 dTHX;
4118 SV *name = sv_2mortal(newSVpvn(path, strlen(path)));
4119 return PerlIO_openn(aTHX_ Nullch, mode, -1, 0, 0, f, 1, &name);
4120}
4121
9e353e3b 4122#undef PerlIO_getc
6f9d8c32 4123int
9e353e3b 4124PerlIO_getc(PerlIO *f)
760ac839 4125{
e87a358a 4126 dTHX;
14a5cf38
JH		 4127 STDCHAR buf[1];
4128 SSize_t count = PerlIO_read(f, buf, 1);
4129 if (count == 1) {
4130 return (unsigned char) buf[0];
4131 }
4132 return EOF;
313ca112
NIS		 4133}
4134
4135#undef PerlIO_ungetc
4136int
4137PerlIO_ungetc(PerlIO *f, int ch)
4138{
e87a358a 4139 dTHX;
14a5cf38
JH		 4140 if (ch != EOF) {
4141 STDCHAR buf = ch;
4142 if (PerlIO_unread(f, &buf, 1) == 1)
4143 return ch;
4144 }
4145 return EOF;
760ac839
LW		 4146}
4147
9e353e3b
NIS		 4148#undef PerlIO_putc
4149int
4150PerlIO_putc(PerlIO *f, int ch)
760ac839 4151{
e87a358a 4152 dTHX;
14a5cf38
JH		 4153 STDCHAR buf = ch;
4154 return PerlIO_write(f, &buf, 1);
760ac839
LW		 4155}
4156
9e353e3b 4157#undef PerlIO_puts
760ac839 4158int
9e353e3b 4159PerlIO_puts(PerlIO *f, const char *s)
760ac839 4160{
e87a358a 4161 dTHX;
14a5cf38
JH		 4162 STRLEN len = strlen(s);
4163 return PerlIO_write(f, s, len);
760ac839
LW		 4164}
4165
4166#undef PerlIO_rewind
4167void
c78749f2 4168PerlIO_rewind(PerlIO *f)
760ac839 4169{
e87a358a 4170 dTHX;
14a5cf38
JH		 4171 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4172 PerlIO_clearerr(f);
6f9d8c32
NIS		 4173}
4174
4175#undef PerlIO_vprintf
4176int
4177PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4178{
14a5cf38
JH		 4179 dTHX;
4180 SV *sv = newSVpvn("", 0);
4181 char *s;
4182 STRLEN len;
4183 SSize_t wrote;
2cc61e15 4184#ifdef NEED_VA_COPY
14a5cf38
JH		 4185 va_list apc;
4186 Perl_va_copy(ap, apc);
4187 sv_vcatpvf(sv, fmt, &apc);
2cc61e15 4188#else
14a5cf38 4189 sv_vcatpvf(sv, fmt, &ap);
2cc61e15 4190#endif
14a5cf38
JH		 4191 s = SvPV(sv, len);
4192 wrote = PerlIO_write(f, s, len);
4193 SvREFCNT_dec(sv);
4194 return wrote;
760ac839
LW		 4195}
4196
4197#undef PerlIO_printf
6f9d8c32 4198int
14a5cf38 4199PerlIO_printf(PerlIO *f, const char *fmt, ...)
760ac839 4200{
14a5cf38
JH		 4201 va_list ap;
4202 int result;
4203 va_start(ap, fmt);
4204 result = PerlIO_vprintf(f, fmt, ap);
4205 va_end(ap);
4206 return result;
760ac839
LW		 4207}
4208
4209#undef PerlIO_stdoutf
6f9d8c32 4210int
14a5cf38 4211PerlIO_stdoutf(const char *fmt, ...)
760ac839 4212{
e87a358a 4213 dTHX;
14a5cf38
JH		 4214 va_list ap;
4215 int result;
4216 va_start(ap, fmt);
4217 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
4218 va_end(ap);
4219 return result;
760ac839
LW		 4220}
4221
4222#undef PerlIO_tmpfile
4223PerlIO *
c78749f2 4224PerlIO_tmpfile(void)
760ac839 4225{
14a5cf38 4226 /*
71200d45 4227 * I have no idea how portable mkstemp() is ...
14a5cf38 4228 */
83b075c3 4229#if defined(WIN32) || !defined(HAVE_MKSTEMP)
14a5cf38
JH		 4230 dTHX;
4231 PerlIO *f = NULL;
4232 FILE *stdio = PerlSIO_tmpfile();
4233 if (stdio) {
4234 PerlIOStdio *s =
4235 PerlIOSelf(PerlIO_push
4236 (aTHX_(f = PerlIO_allocate(aTHX)), &PerlIO_stdio,
4237 "w+", Nullsv), PerlIOStdio);
4238 s->stdio = stdio;
4239 }
4240 return f;
83b075c3 4241#else
14a5cf38
JH		 4242 dTHX;
4243 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0);
4244 int fd = mkstemp(SvPVX(sv));
4245 PerlIO *f = NULL;
4246 if (fd >= 0) {
4247 f = PerlIO_fdopen(fd, "w+");
4248 if (f) {
4249 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
4250 }
4251 PerlLIO_unlink(SvPVX(sv));
4252 SvREFCNT_dec(sv);
4253 }
4254 return f;
83b075c3 4255#endif
760ac839
LW		 4256}
4257
6f9d8c32
NIS		 4258#undef HAS_FSETPOS
4259#undef HAS_FGETPOS
4260
14a5cf38
JH		 4261#endif /* USE_SFIO */
4262#endif /* PERLIO_IS_STDIO */
760ac839 4263
9e353e3b 4264/*======================================================================================*/
14a5cf38 4265/*
71200d45
NIS		 4266 * Now some functions in terms of above which may be needed even if we are
4267 * not in true PerlIO mode
9e353e3b
NIS		 4268 */
4269
760ac839
LW		 4270#ifndef HAS_FSETPOS
4271#undef PerlIO_setpos
4272int
766a733e 4273PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 4274{
14a5cf38
JH		 4275 dTHX;
4276 if (SvOK(pos)) {
4277 STRLEN len;
4278 Off_t *posn = (Off_t *) SvPV(pos, len);
4279 if (f && len == sizeof(Off_t))
4280 return PerlIO_seek(f, *posn, SEEK_SET);
4281 }
4282 SETERRNO(EINVAL, SS$_IVCHAN);
4283 return -1;
760ac839 4284}
c411622e 4285#else
c411622e 4286#undef PerlIO_setpos
4287int
766a733e 4288PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 4289{
14a5cf38
JH		 4290 dTHX;
4291 if (SvOK(pos)) {
4292 STRLEN len;
4293 Fpos_t *fpos = (Fpos_t *) SvPV(pos, len);
4294 if (f && len == sizeof(Fpos_t)) {
2d4389e4 4295#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 4296 return fsetpos64(f, fpos);
d9b3e12d 4297#else
14a5cf38 4298 return fsetpos(f, fpos);
d9b3e12d 4299#endif
14a5cf38 4300 }
766a733e 4301 }
14a5cf38
JH		 4302 SETERRNO(EINVAL, SS$_IVCHAN);
4303 return -1;
c411622e 4304}
4305#endif
760ac839
LW		 4306
4307#ifndef HAS_FGETPOS
4308#undef PerlIO_getpos
4309int
766a733e 4310PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 4311{
14a5cf38
JH		 4312 dTHX;
4313 Off_t posn = PerlIO_tell(f);
4314 sv_setpvn(pos, (char *) &posn, sizeof(posn));
4315 return (posn == (Off_t) - 1) ? -1 : 0;
760ac839 4316}
c411622e 4317#else
c411622e 4318#undef PerlIO_getpos
4319int
766a733e 4320PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 4321{
14a5cf38
JH		 4322 dTHX;
4323 Fpos_t fpos;
4324 int code;
2d4389e4 4325#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
14a5cf38 4326 code = fgetpos64(f, &fpos);
d9b3e12d 4327#else
14a5cf38 4328 code = fgetpos(f, &fpos);
d9b3e12d 4329#endif
14a5cf38
JH		 4330 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
4331 return code;
c411622e 4332}
4333#endif
760ac839
LW		 4334
4335#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4336
4337int
c78749f2 4338vprintf(char *pat, char *args)
662a7e3f
CS		 4339{
4340 _doprnt(pat, args, stdout);
14a5cf38
JH		 4341 return 0; /* wrong, but perl doesn't use the return
4342 * value */
662a7e3f
CS		 4343}
4344
4345int
c78749f2 4346vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW		 4347{
4348 _doprnt(pat, args, fd);
14a5cf38
JH		 4349 return 0; /* wrong, but perl doesn't use the return
4350 * value */
760ac839
LW		 4351}
4352
4353#endif
4354
4355#ifndef PerlIO_vsprintf
6f9d8c32 4356int
8ac85365 4357PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839 4358{
14a5cf38
JH		 4359 int val = vsprintf(s, fmt, ap);
4360 if (n >= 0) {
4361 if (strlen(s) >= (STRLEN) n) {
4362 dTHX;
4363 (void) PerlIO_puts(Perl_error_log,
4364 "panic: sprintf overflow - memory corrupted!\n");
4365 my_exit(1);
4366 }
760ac839 4367 }
14a5cf38 4368 return val;
760ac839
LW		 4369}
4370#endif
4371
4372#ifndef PerlIO_sprintf
6f9d8c32 4373int
14a5cf38 4374PerlIO_sprintf(char *s, int n, const char *fmt, ...)
760ac839 4375{
14a5cf38
JH		 4376 va_list ap;
4377 int result;
4378 va_start(ap, fmt);
4379 result = PerlIO_vsprintf(s, n, fmt, ap);
4380 va_end(ap);
4381 return result;
760ac839
LW		 4382}
4383#endif
7fcdafbd 4384
93a8090d
NIS		 4385
4386
4387
4388
Unnamed repository; edit this file 'description' to name the repository.