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