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