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