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