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