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