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