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