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