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