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