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