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