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