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