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