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