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