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
Add a script for being 8.3-polite.
[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{
779e1c5b 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
acfe0abc 429PerlIO_cleanup_layers(pTHX_ void *data)
9a6404c5 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));
e940ddbb
NC		 1971 /* XXX could (or should) we retrieve the oflags from the open file handle
1972 rather than believing the "mode" we are passed in?
1973 XXX Should the value on NULL mode be 0 or -1? */
1974 s->oflags = mode ? PerlIOUnix_oflags(mode) : -1;
4b803d04
NIS		 1975 }
1976 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1977 return code;
1978}
1979
9e353e3b 1980PerlIO *
fcf2db38 1981PerlIOUnix_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 1982{
ee518936 1983 if (f)
9e353e3b 1984 {
ee518936
NIS		 1985 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1986 (*PerlIOBase(f)->tab->Close)(f);
1987 }
1988 if (narg > 0)
1989 {
1990 char *path = SvPV_nolen(*args);
1991 if (*mode == '#')
1992 mode++;
1993 else
9e353e3b 1994 {
ee518936
NIS		 1995 imode = PerlIOUnix_oflags(mode);
1996 perm = 0666;
1997 }
1998 if (imode != -1)
1999 {
2000 fd = PerlLIO_open3(path,imode,perm);
9e353e3b
NIS		 2001 }
2002 }
ee518936 2003 if (fd >= 0)
9e353e3b 2004 {
ee518936
NIS		 2005 PerlIOUnix *s;
2006 if (*mode == 'I')
2007 mode++;
2008 if (!f)
9e353e3b 2009 {
ee518936 2010 f = PerlIO_allocate(aTHX);
f6c77cf1 2011 s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix);
ee518936
NIS		 2012 }
2013 else
2014 s = PerlIOSelf(f,PerlIOUnix);
2015 s->fd = fd;
2016 s->oflags = imode;
2017 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2018 return f;
2019 }
2020 else
2021 {
2022 if (f)
2023 {
2024 /* FIXME: pop layers ??? */
9e353e3b 2025 }
ee518936 2026 return NULL;
9e353e3b 2027 }
9e353e3b
NIS		 2028}
2029
2030SSize_t
2031PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
2032{
adb71456 2033 dTHX;
9e353e3b 2034 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
8f24bd79
NIS		 2035 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2036 return 0;
9e353e3b
NIS		 2037 while (1)
2038 {
00b02797 2039 SSize_t len = PerlLIO_read(fd,vbuf,count);
9e353e3b 2040 if (len >= 0 || errno != EINTR)
06da4f11
NIS		 2041 {
2042 if (len < 0)
2043 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2044 else if (len == 0 && count != 0)
2045 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2046 return len;
2047 }
0a8e0eff 2048 PERL_ASYNC_CHECK();
9e353e3b
NIS		 2049 }
2050}
2051
2052SSize_t
2053PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
2054{
adb71456 2055 dTHX;
9e353e3b
NIS		 2056 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2057 while (1)
2058 {
00b02797 2059 SSize_t len = PerlLIO_write(fd,vbuf,count);
9e353e3b 2060 if (len >= 0 || errno != EINTR)
06da4f11
NIS		 2061 {
2062 if (len < 0)
2063 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2064 return len;
2065 }
0a8e0eff 2066 PERL_ASYNC_CHECK();
9e353e3b
NIS		 2067 }
2068}
2069
2070IV
2071PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
2072{
92bff44d 2073 dSYS;
00b02797 2074 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
06da4f11 2075 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
9e353e3b
NIS		 2076 return (new == (Off_t) -1) ? -1 : 0;
2077}
2078
2079Off_t
2080PerlIOUnix_tell(PerlIO *f)
2081{
7bcba3d4 2082 dSYS;
00b02797 2083 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
9e353e3b
NIS		 2084}
2085
2086IV
2087PerlIOUnix_close(PerlIO *f)
2088{
adb71456 2089 dTHX;
9e353e3b
NIS		 2090 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
2091 int code = 0;
00b02797 2092 while (PerlLIO_close(fd) != 0)
9e353e3b
NIS		 2093 {
2094 if (errno != EINTR)
2095 {
2096 code = -1;
2097 break;
2098 }
0a8e0eff 2099 PERL_ASYNC_CHECK();
9e353e3b
NIS		 2100 }
2101 if (code == 0)
2102 {
2103 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2104 }
2105 return code;
2106}
2107
2108PerlIO_funcs PerlIO_unix = {
2109 "unix",
2110 sizeof(PerlIOUnix),
f5b9d040 2111 PERLIO_K_RAW,
4b803d04 2112 PerlIOUnix_pushed,
06da4f11 2113 PerlIOBase_noop_ok,
e3f3bf95
NIS		 2114 PerlIOUnix_open,
2115 NULL,
2116 PerlIOUnix_fileno,
9e353e3b
NIS		 2117 PerlIOUnix_read,
2118 PerlIOBase_unread,
2119 PerlIOUnix_write,
2120 PerlIOUnix_seek,
2121 PerlIOUnix_tell,
2122 PerlIOUnix_close,
76ced9ad
NIS		 2123 PerlIOBase_noop_ok, /* flush */
2124 PerlIOBase_noop_fail, /* fill */
9e353e3b
NIS		 2125 PerlIOBase_eof,
2126 PerlIOBase_error,
2127 PerlIOBase_clearerr,
2128 PerlIOBase_setlinebuf,
2129 NULL, /* get_base */
2130 NULL, /* get_bufsiz */
2131 NULL, /* get_ptr */
2132 NULL, /* get_cnt */
2133 NULL, /* set_ptrcnt */
2134};
2135
2136/*--------------------------------------------------------------------------------------*/
2137/* stdio as a layer */
2138
2139typedef struct
2140{
2141 struct _PerlIO base;
2142 FILE * stdio; /* The stream */
2143} PerlIOStdio;
2144
2145IV
2146PerlIOStdio_fileno(PerlIO *f)
2147{
7bcba3d4 2148 dSYS;
eaf8b698 2149 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
9e353e3b
NIS		 2150}
2151
766a733e 2152char *
f5b9d040
NIS		 2153PerlIOStdio_mode(const char *mode,char *tmode)
2154{
766a733e
NIS		 2155 char *ret = tmode;
2156 while (*mode)
2157 {
2158 *tmode++ = *mode++;
2159 }
f5b9d040
NIS		 2160 if (O_BINARY != O_TEXT)
2161 {
f5b9d040 2162 *tmode++ = 'b';
f5b9d040 2163 }
766a733e 2164 *tmode = '\0';
f5b9d040
NIS		 2165 return ret;
2166}
9e353e3b 2167
4b803d04
NIS		 2168/* This isn't used yet ... */
2169IV
e3f3bf95 2170PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg)
4b803d04
NIS		 2171{
2172 if (*PerlIONext(f))
2173 {
7bcba3d4 2174 dSYS;
4b803d04
NIS		 2175 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2176 char tmode[8];
2177 FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
2178 if (stdio)
2179 s->stdio = stdio;
2180 else
2181 return -1;
2182 }
e3f3bf95 2183 return PerlIOBase_pushed(f,mode,arg);
4b803d04
NIS		 2184}
2185
9e353e3b
NIS		 2186#undef PerlIO_importFILE
2187PerlIO *
2188PerlIO_importFILE(FILE *stdio, int fl)
2189{
5f1a76d0 2190 dTHX;
9e353e3b
NIS		 2191 PerlIO *f = NULL;
2192 if (stdio)
2193 {
e3f3bf95 2194 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
9e353e3b
NIS		 2195 s->stdio = stdio;
2196 }
2197 return f;
2198}
2199
2200PerlIO *
fcf2db38 2201PerlIOStdio_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 2202{
ee518936
NIS		 2203 char tmode[8];
2204 if (f)
9e353e3b 2205 {
ee518936
NIS		 2206 char *path = SvPV_nolen(*args);
2207 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
2208 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
2209 if (!s->stdio)
2210 return NULL;
2211 s->stdio = stdio;
2212 return f;
9e353e3b 2213 }
ee518936
NIS		 2214 else
2215 {
2216 if (narg > 0)
2217 {
2218 char *path = SvPV_nolen(*args);
2219 if (*mode == '#')
2220 {
2221 mode++;
2222 fd = PerlLIO_open3(path,imode,perm);
2223 }
2224 else
2225 {
2226 FILE *stdio = PerlSIO_fopen(path,mode);
2227 if (stdio)
2228 {
a999f61b 2229 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self,
f6c77cf1 2230 (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg),
ee518936
NIS		 2231 PerlIOStdio);
2232 s->stdio = stdio;
2233 }
2234 return f;
2235 }
2236 }
2237 if (fd >= 0)
2238 {
2239 FILE *stdio = NULL;
2240 int init = 0;
2241 if (*mode == 'I')
2242 {
2243 init = 1;
2244 mode++;
2245 }
2246 if (init)
2247 {
2248 switch(fd)
2249 {
2250 case 0:
2251 stdio = PerlSIO_stdin;
2252 break;
2253 case 1:
2254 stdio = PerlSIO_stdout;
2255 break;
2256 case 2:
2257 stdio = PerlSIO_stderr;
2258 break;
2259 }
2260 }
2261 else
2262 {
2263 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
2264 }
2265 if (stdio)
2266 {
f6c77cf1 2267 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio);
ee518936
NIS		 2268 s->stdio = stdio;
2269 return f;
2270 }
2271 }
2272 }
2273 return NULL;
9e353e3b
NIS		 2274}
2275
2276SSize_t
2277PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
2278{
7bcba3d4 2279 dSYS;
9e353e3b 2280 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 2281 SSize_t got = 0;
9e353e3b
NIS		 2282 if (count == 1)
2283 {
2284 STDCHAR *buf = (STDCHAR *) vbuf;
2285 /* Perl is expecting PerlIO_getc() to fill the buffer
2286 * Linux's stdio does not do that for fread()
2287 */
eaf8b698 2288 int ch = PerlSIO_fgetc(s);
9e353e3b
NIS		 2289 if (ch != EOF)
2290 {
2291 *buf = ch;
c7fc522f 2292 got = 1;
9e353e3b 2293 }
9e353e3b 2294 }
c7fc522f 2295 else
eaf8b698 2296 got = PerlSIO_fread(vbuf,1,count,s);
c7fc522f 2297 return got;
9e353e3b
NIS		 2298}
2299
2300SSize_t
2301PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
2302{
7bcba3d4 2303 dSYS;
9e353e3b
NIS		 2304 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
2305 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
2306 SSize_t unread = 0;
2307 while (count > 0)
2308 {
2309 int ch = *buf-- & 0xff;
eaf8b698 2310 if (PerlSIO_ungetc(ch,s) != ch)
9e353e3b
NIS		 2311 break;
2312 unread++;
2313 count--;
2314 }
2315 return unread;
2316}
2317
2318SSize_t
2319PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
2320{
7bcba3d4 2321 dSYS;
eaf8b698 2322 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
9e353e3b
NIS		 2323}
2324
2325IV
2326PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
2327{
7bcba3d4 2328 dSYS;
c7fc522f 2329 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
eaf8b698 2330 return PerlSIO_fseek(stdio,offset,whence);
9e353e3b
NIS		 2331}
2332
2333Off_t
2334PerlIOStdio_tell(PerlIO *f)
2335{
7bcba3d4 2336 dSYS;
c7fc522f 2337 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
eaf8b698 2338 return PerlSIO_ftell(stdio);
9e353e3b
NIS		 2339}
2340
2341IV
2342PerlIOStdio_close(PerlIO *f)
2343{
7bcba3d4 2344 dSYS;
af130d45 2345#ifdef SOCKS5_VERSION_NAME
af489807
JH		 2346 int optval;
2347 Sock_size_t optlen = sizeof(int);
8e4bc33b 2348#endif
3789aae2 2349 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
cf829ab0 2350 return(
af130d45 2351#ifdef SOCKS5_VERSION_NAME
af489807 2352 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ?
eaf8b698 2353 PerlSIO_fclose(stdio) :
8e4bc33b
YST		 2354 close(PerlIO_fileno(f))
2355#else
2356 PerlSIO_fclose(stdio)
2357#endif
2358 );
2359
9e353e3b
NIS		 2360}
2361
2362IV
2363PerlIOStdio_flush(PerlIO *f)
2364{
7bcba3d4 2365 dSYS;
9e353e3b 2366 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
88b61e10
NIS		 2367 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
2368 {
eaf8b698 2369 return PerlSIO_fflush(stdio);
88b61e10
NIS		 2370 }
2371 else
2372 {
2373#if 0
2374 /* FIXME: This discards ungetc() and pre-read stuff which is
2375 not right if this is just a "sync" from a layer above
2376 Suspect right design is to do _this_ but not have layer above
2377 flush this layer read-to-read
2378 */
2379 /* Not writeable - sync by attempting a seek */
2380 int err = errno;
eaf8b698 2381 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
88b61e10
NIS		 2382 errno = err;
2383#endif
2384 }
2385 return 0;
9e353e3b
NIS		 2386}
2387
2388IV
06da4f11
NIS		 2389PerlIOStdio_fill(PerlIO *f)
2390{
7bcba3d4 2391 dSYS;
06da4f11
NIS		 2392 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
2393 int c;
3789aae2
NIS		 2394 /* fflush()ing read-only streams can cause trouble on some stdio-s */
2395 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2396 {
eaf8b698 2397 if (PerlSIO_fflush(stdio) != 0)
3789aae2
NIS		 2398 return EOF;
2399 }
eaf8b698
NIS		 2400 c = PerlSIO_fgetc(stdio);
2401 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
06da4f11
NIS		 2402 return EOF;
2403 return 0;
2404}
2405
2406IV
9e353e3b
NIS		 2407PerlIOStdio_eof(PerlIO *f)
2408{
7bcba3d4 2409 dSYS;
eaf8b698 2410 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
9e353e3b
NIS		 2411}
2412
2413IV
2414PerlIOStdio_error(PerlIO *f)
2415{
7bcba3d4 2416 dSYS;
eaf8b698 2417 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
9e353e3b
NIS		 2418}
2419
2420void
2421PerlIOStdio_clearerr(PerlIO *f)
2422{
7bcba3d4 2423 dSYS;
eaf8b698 2424 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
9e353e3b
NIS		 2425}
2426
2427void
2428PerlIOStdio_setlinebuf(PerlIO *f)
2429{
7bcba3d4 2430 dSYS;
9e353e3b 2431#ifdef HAS_SETLINEBUF
eaf8b698 2432 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
9e353e3b 2433#else
eaf8b698 2434 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
9e353e3b
NIS		 2435#endif
2436}
2437
2438#ifdef FILE_base
2439STDCHAR *
2440PerlIOStdio_get_base(PerlIO *f)
2441{
7bcba3d4 2442 dSYS;
9e353e3b 2443 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
eaf8b698 2444 return PerlSIO_get_base(stdio);
9e353e3b
NIS		 2445}
2446
2447Size_t
2448PerlIOStdio_get_bufsiz(PerlIO *f)
2449{
7bcba3d4 2450 dSYS;
9e353e3b 2451 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
eaf8b698 2452 return PerlSIO_get_bufsiz(stdio);
9e353e3b
NIS		 2453}
2454#endif
2455
2456#ifdef USE_STDIO_PTR
2457STDCHAR *
2458PerlIOStdio_get_ptr(PerlIO *f)
2459{
7bcba3d4 2460 dSYS;
9e353e3b 2461 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
eaf8b698 2462 return PerlSIO_get_ptr(stdio);
9e353e3b
NIS		 2463}
2464
2465SSize_t
2466PerlIOStdio_get_cnt(PerlIO *f)
2467{
7bcba3d4 2468 dSYS;
9e353e3b 2469 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
eaf8b698 2470 return PerlSIO_get_cnt(stdio);
9e353e3b
NIS		 2471}
2472
2473void
2474PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
2475{
2476 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
7bcba3d4 2477 dSYS;
9e353e3b
NIS		 2478 if (ptr != NULL)
2479 {
2480#ifdef STDIO_PTR_LVALUE
eaf8b698 2481 PerlSIO_set_ptr(stdio,ptr);
9e353e3b 2482#ifdef STDIO_PTR_LVAL_SETS_CNT
eaf8b698 2483 if (PerlSIO_get_cnt(stdio) != (cnt))
9e353e3b
NIS		 2484 {
2485 dTHX;
eaf8b698 2486 assert(PerlSIO_get_cnt(stdio) == (cnt));
9e353e3b
NIS		 2487 }
2488#endif
2489#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
2490 /* Setting ptr _does_ change cnt - we are done */
2491 return;
2492#endif
2493#else /* STDIO_PTR_LVALUE */
eaf8b698 2494 PerlProc_abort();
9e353e3b
NIS		 2495#endif /* STDIO_PTR_LVALUE */
2496 }
2497/* Now (or only) set cnt */
2498#ifdef STDIO_CNT_LVALUE
eaf8b698 2499 PerlSIO_set_cnt(stdio,cnt);
9e353e3b
NIS		 2500#else /* STDIO_CNT_LVALUE */
2501#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
eaf8b698 2502 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
9e353e3b 2503#else /* STDIO_PTR_LVAL_SETS_CNT */
eaf8b698 2504 PerlProc_abort();
9e353e3b
NIS		 2505#endif /* STDIO_PTR_LVAL_SETS_CNT */
2506#endif /* STDIO_CNT_LVALUE */
2507}
2508
2509#endif
2510
2511PerlIO_funcs PerlIO_stdio = {
2512 "stdio",
2513 sizeof(PerlIOStdio),
f5b9d040 2514 PERLIO_K_BUFFERED,
06da4f11
NIS		 2515 PerlIOBase_pushed,
2516 PerlIOBase_noop_ok,
e3f3bf95
NIS		 2517 PerlIOStdio_open,
2518 NULL,
2519 PerlIOStdio_fileno,
9e353e3b
NIS		 2520 PerlIOStdio_read,
2521 PerlIOStdio_unread,
2522 PerlIOStdio_write,
2523 PerlIOStdio_seek,
2524 PerlIOStdio_tell,
2525 PerlIOStdio_close,
2526 PerlIOStdio_flush,
06da4f11 2527 PerlIOStdio_fill,
9e353e3b
NIS		 2528 PerlIOStdio_eof,
2529 PerlIOStdio_error,
2530 PerlIOStdio_clearerr,
2531 PerlIOStdio_setlinebuf,
2532#ifdef FILE_base
2533 PerlIOStdio_get_base,
2534 PerlIOStdio_get_bufsiz,
2535#else
2536 NULL,
2537 NULL,
2538#endif
2539#ifdef USE_STDIO_PTR
2540 PerlIOStdio_get_ptr,
2541 PerlIOStdio_get_cnt,
0eb1d8a4 2542#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
9e353e3b
NIS		 2543 PerlIOStdio_set_ptrcnt
2544#else /* STDIO_PTR_LVALUE */
2545 NULL
2546#endif /* STDIO_PTR_LVALUE */
2547#else /* USE_STDIO_PTR */
2548 NULL,
2549 NULL,
2550 NULL
2551#endif /* USE_STDIO_PTR */
2552};
2553
2554#undef PerlIO_exportFILE
2555FILE *
2556PerlIO_exportFILE(PerlIO *f, int fl)
2557{
f7e7eb72 2558 FILE *stdio;
9e353e3b 2559 PerlIO_flush(f);
f7e7eb72
NIS		 2560 stdio = fdopen(PerlIO_fileno(f),"r+");
2561 if (stdio)
2562 {
a999f61b 2563 dTHX;
e3f3bf95 2564 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio);
f7e7eb72
NIS		 2565 s->stdio = stdio;
2566 }
2567 return stdio;
9e353e3b
NIS		 2568}
2569
2570#undef PerlIO_findFILE
2571FILE *
2572PerlIO_findFILE(PerlIO *f)
2573{
f7e7eb72
NIS		 2574 PerlIOl *l = *f;
2575 while (l)
2576 {
2577 if (l->tab == &PerlIO_stdio)
2578 {
2579 PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio);
2580 return s->stdio;
2581 }
2582 l = *PerlIONext(&l);
2583 }
9e353e3b
NIS		 2584 return PerlIO_exportFILE(f,0);
2585}
2586
2587#undef PerlIO_releaseFILE
2588void
2589PerlIO_releaseFILE(PerlIO *p, FILE *f)
2590{
2591}
2592
2593/*--------------------------------------------------------------------------------------*/
2594/* perlio buffer layer */
2595
5e2ab84b 2596IV
e3f3bf95 2597PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg)
5e2ab84b 2598{
7bcba3d4 2599 dSYS;
5e2ab84b 2600 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1f474064
NIS		 2601 int fd = PerlIO_fileno(f);
2602 Off_t posn;
2603 if (fd >= 0 && PerlLIO_isatty(fd))
2604 {
a9c883f6 2605 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY;
1f474064
NIS		 2606 }
2607 posn = PerlIO_tell(PerlIONext(f));
2608 if (posn != (Off_t) -1)
2609 {
2610 b->posn = posn;
2611 }
e3f3bf95 2612 return PerlIOBase_pushed(f,mode,arg);
5e2ab84b
NIS		 2613}
2614
9e353e3b 2615PerlIO *
fcf2db38 2616PerlIOBuf_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 2617{
6f9d8c32
NIS		 2618 if (f)
2619 {
ee518936 2620 PerlIO *next = PerlIONext(f);
fcf2db38
NIS		 2621 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIOBase(next)->tab);
2622 next = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,next,narg,args);
f6c77cf1 2623 if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0)
c7fc522f 2624 {
ee518936 2625 return NULL;
a4d3c1d3 2626 }
6f9d8c32 2627 }
ee518936 2628 else
9e353e3b 2629 {
fcf2db38 2630 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-1, PerlIO_default_btm());
ee518936
NIS		 2631 int init = 0;
2632 if (*mode == 'I')
2633 {
2634 init = 1;
0c4128ad 2635 /* mode++; */
ee518936 2636 }
fcf2db38 2637 f = (*tab->Open)(aTHX_ tab, layers, n-1, mode,fd,imode,perm,NULL,narg,args);
ee518936
NIS		 2638 if (f)
2639 {
b7953727 2640 PerlIO_push(aTHX_ f,self,mode,PerlIOArg);
ee518936
NIS		 2641 fd = PerlIO_fileno(f);
2642#if O_BINARY != O_TEXT
2643 /* do something about failing setmode()? --jhi */
2644 PerlLIO_setmode(fd , O_BINARY);
2645#endif
2646 if (init && fd == 2)
2647 {
2648 /* Initial stderr is unbuffered */
2649 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
2650 }
2651 }
9e353e3b
NIS		 2652 }
2653 return f;
2654}
2655
9e353e3b
NIS		 2656/* This "flush" is akin to sfio's sync in that it handles files in either
2657 read or write state
2658*/
2659IV
2660PerlIOBuf_flush(PerlIO *f)
6f9d8c32 2661{
9e353e3b
NIS		 2662 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2663 int code = 0;
2664 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2665 {
2666 /* write() the buffer */
a5262162 2667 STDCHAR *buf = b->buf;
33af2bc7 2668 STDCHAR *p = buf;
3789aae2 2669 PerlIO *n = PerlIONext(f);
9e353e3b
NIS		 2670 while (p < b->ptr)
2671 {
4b803d04 2672 SSize_t count = PerlIO_write(n,p,b->ptr - p);
9e353e3b
NIS		 2673 if (count > 0)
2674 {
2675 p += count;
2676 }
3789aae2 2677 else if (count < 0 || PerlIO_error(n))
9e353e3b
NIS		 2678 {
2679 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2680 code = -1;
2681 break;
2682 }
2683 }
33af2bc7 2684 b->posn += (p - buf);
9e353e3b
NIS		 2685 }
2686 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 2687 {
33af2bc7 2688 STDCHAR *buf = PerlIO_get_base(f);
9e353e3b 2689 /* Note position change */
33af2bc7 2690 b->posn += (b->ptr - buf);
9e353e3b
NIS		 2691 if (b->ptr < b->end)
2692 {
2693 /* We did not consume all of it */
2694 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
2695 {
2696 b->posn = PerlIO_tell(PerlIONext(f));
2697 }
2698 }
6f9d8c32 2699 }
9e353e3b
NIS		 2700 b->ptr = b->end = b->buf;
2701 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
88b61e10 2702 /* FIXME: Is this right for read case ? */
9e353e3b
NIS		 2703 if (PerlIO_flush(PerlIONext(f)) != 0)
2704 code = -1;
2705 return code;
6f9d8c32
NIS		 2706}
2707
06da4f11
NIS		 2708IV
2709PerlIOBuf_fill(PerlIO *f)
2710{
2711 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
88b61e10 2712 PerlIO *n = PerlIONext(f);
06da4f11 2713 SSize_t avail;
88b61e10
NIS		 2714 /* FIXME: doing the down-stream flush is a bad idea if it causes
2715 pre-read data in stdio buffer to be discarded
2716 but this is too simplistic - as it skips _our_ hosekeeping
2717 and breaks tell tests.
2718 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2719 {
2720 }
2721 */
06da4f11
NIS		 2722 if (PerlIO_flush(f) != 0)
2723 return -1;
a9c883f6
NIS		 2724 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
2725 PerlIOBase_flush_linebuf();
88b61e10 2726
a5262162
NIS		 2727 if (!b->buf)
2728 PerlIO_get_base(f); /* allocate via vtable */
2729
2730 b->ptr = b->end = b->buf;
88b61e10
NIS		 2731 if (PerlIO_fast_gets(n))
2732 {
2733 /* Layer below is also buffered
2734 * We do _NOT_ want to call its ->Read() because that will loop
2735 * till it gets what we asked for which may hang on a pipe etc.
2736 * Instead take anything it has to hand, or ask it to fill _once_.
2737 */
2738 avail = PerlIO_get_cnt(n);
2739 if (avail <= 0)
2740 {
2741 avail = PerlIO_fill(n);
2742 if (avail == 0)
2743 avail = PerlIO_get_cnt(n);
2744 else
2745 {
2746 if (!PerlIO_error(n) && PerlIO_eof(n))
2747 avail = 0;
2748 }
2749 }
2750 if (avail > 0)
2751 {
2752 STDCHAR *ptr = PerlIO_get_ptr(n);
2753 SSize_t cnt = avail;
2754 if (avail > b->bufsiz)
2755 avail = b->bufsiz;
2756 Copy(ptr,b->buf,avail,STDCHAR);
2757 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
2758 }
2759 }
2760 else
2761 {
2762 avail = PerlIO_read(n,b->ptr,b->bufsiz);
2763 }
06da4f11
NIS		 2764 if (avail <= 0)
2765 {
2766 if (avail == 0)
2767 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2768 else
2769 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2770 return -1;
2771 }
a5262162 2772 b->end = b->buf+avail;
06da4f11
NIS		 2773 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2774 return 0;
2775}
2776
6f9d8c32 2777SSize_t
9e353e3b 2778PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 2779{
99efab12 2780 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
6f9d8c32
NIS		 2781 if (f)
2782 {
9e353e3b 2783 if (!b->ptr)
06da4f11 2784 PerlIO_get_base(f);
f6c77cf1 2785 return PerlIOBase_read(f,vbuf,count);
6f9d8c32
NIS		 2786 }
2787 return 0;
2788}
2789
9e353e3b
NIS		 2790SSize_t
2791PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 2792{
9e353e3b
NIS		 2793 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2794 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2795 SSize_t unread = 0;
2796 SSize_t avail;
9e353e3b
NIS		 2797 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2798 PerlIO_flush(f);
06da4f11
NIS		 2799 if (!b->buf)
2800 PerlIO_get_base(f);
9e353e3b
NIS		 2801 if (b->buf)
2802 {
2803 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2804 {
0c20e1bf
NIS		 2805 /* Buffer is already a read buffer, we can overwrite any chars
2806 which have been read back to buffer start
2807 */
9e353e3b 2808 avail = (b->ptr - b->buf);
9e353e3b
NIS		 2809 }
2810 else
2811 {
0c20e1bf
NIS		 2812 /* Buffer is idle, set it up so whole buffer is available for unread */
2813 avail = b->bufsiz;
5e2ab84b
NIS		 2814 b->end = b->buf + avail;
2815 b->ptr = b->end;
2816 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
0c20e1bf
NIS		 2817 /* Buffer extends _back_ from where we are now */
2818 b->posn -= b->bufsiz;
2819 }
2820 if (avail > (SSize_t) count)
2821 {
2822 /* If we have space for more than count, just move count */
2823 avail = count;
9e353e3b
NIS		 2824 }
2825 if (avail > 0)
2826 {
5e2ab84b 2827 b->ptr -= avail;
9e353e3b 2828 buf -= avail;
0c20e1bf 2829 /* In simple stdio-like ungetc() case chars will be already there */
9e353e3b
NIS		 2830 if (buf != b->ptr)
2831 {
88b61e10 2832 Copy(buf,b->ptr,avail,STDCHAR);
9e353e3b
NIS		 2833 }
2834 count -= avail;
2835 unread += avail;
2836 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2837 }
2838 }
2839 return unread;
760ac839
LW		 2840}
2841
9e353e3b
NIS		 2842SSize_t
2843PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 2844{
9e353e3b
NIS		 2845 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2846 const STDCHAR *buf = (const STDCHAR *) vbuf;
2847 Size_t written = 0;
2848 if (!b->buf)
06da4f11 2849 PerlIO_get_base(f);
9e353e3b
NIS		 2850 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2851 return 0;
2852 while (count > 0)
2853 {
2854 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
2855 if ((SSize_t) count < avail)
2856 avail = count;
2857 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2858 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2859 {
2860 while (avail > 0)
2861 {
2862 int ch = *buf++;
2863 *(b->ptr)++ = ch;
2864 count--;
2865 avail--;
2866 written++;
2867 if (ch == '\n')
2868 {
2869 PerlIO_flush(f);
2870 break;
2871 }
2872 }
2873 }
2874 else
2875 {
2876 if (avail)
2877 {
88b61e10 2878 Copy(buf,b->ptr,avail,STDCHAR);
9e353e3b
NIS		 2879 count -= avail;
2880 buf += avail;
2881 written += avail;
2882 b->ptr += avail;
2883 }
2884 }
2885 if (b->ptr >= (b->buf + b->bufsiz))
2886 PerlIO_flush(f);
2887 }
f5b9d040
NIS		 2888 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2889 PerlIO_flush(f);
9e353e3b
NIS		 2890 return written;
2891}
2892
2893IV
2894PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2895{
5e2ab84b
NIS		 2896 IV code;
2897 if ((code = PerlIO_flush(f)) == 0)
9e353e3b 2898 {
5e2ab84b 2899 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
9e353e3b
NIS		 2900 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2901 code = PerlIO_seek(PerlIONext(f),offset,whence);
2902 if (code == 0)
2903 {
2904 b->posn = PerlIO_tell(PerlIONext(f));
2905 }
2906 }
2907 return code;
2908}
2909
2910Off_t
2911PerlIOBuf_tell(PerlIO *f)
2912{
2913 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
0c20e1bf 2914 /* b->posn is file position where b->buf was read, or will be written */
9e353e3b
NIS		 2915 Off_t posn = b->posn;
2916 if (b->buf)
0c20e1bf
NIS		 2917 {
2918 /* If buffer is valid adjust position by amount in buffer */
2919 posn += (b->ptr - b->buf);
2920 }
9e353e3b
NIS		 2921 return posn;
2922}
2923
2924IV
2925PerlIOBuf_close(PerlIO *f)
2926{
2927 IV code = PerlIOBase_close(f);
2928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2929 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 2930 {
5f1a76d0 2931 PerlMemShared_free(b->buf);
6f9d8c32 2932 }
9e353e3b
NIS		 2933 b->buf = NULL;
2934 b->ptr = b->end = b->buf;
2935 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2936 return code;
760ac839
LW		 2937}
2938
9e353e3b
NIS		 2939STDCHAR *
2940PerlIOBuf_get_ptr(PerlIO *f)
2941{
2942 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2943 if (!b->buf)
06da4f11 2944 PerlIO_get_base(f);
9e353e3b
NIS		 2945 return b->ptr;
2946}
2947
05d1247b 2948SSize_t
9e353e3b
NIS		 2949PerlIOBuf_get_cnt(PerlIO *f)
2950{
2951 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2952 if (!b->buf)
06da4f11 2953 PerlIO_get_base(f);
9e353e3b
NIS		 2954 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2955 return (b->end - b->ptr);
2956 return 0;
2957}
2958
2959STDCHAR *
2960PerlIOBuf_get_base(PerlIO *f)
2961{
2962 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2963 if (!b->buf)
06da4f11
NIS		 2964 {
2965 if (!b->bufsiz)
2966 b->bufsiz = 4096;
5f1a76d0 2967 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
06da4f11
NIS		 2968 if (!b->buf)
2969 {
2970 b->buf = (STDCHAR *)&b->oneword;
2971 b->bufsiz = sizeof(b->oneword);
2972 }
2973 b->ptr = b->buf;
2974 b->end = b->ptr;
2975 }
9e353e3b
NIS		 2976 return b->buf;
2977}
2978
2979Size_t
2980PerlIOBuf_bufsiz(PerlIO *f)
2981{
2982 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2983 if (!b->buf)
06da4f11 2984 PerlIO_get_base(f);
9e353e3b
NIS		 2985 return (b->end - b->buf);
2986}
2987
2988void
05d1247b 2989PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS		 2990{
2991 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2992 if (!b->buf)
06da4f11 2993 PerlIO_get_base(f);
9e353e3b
NIS		 2994 b->ptr = ptr;
2995 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 2996 {
9e353e3b
NIS		 2997 dTHX;
2998 assert(PerlIO_get_cnt(f) == cnt);
2999 assert(b->ptr >= b->buf);
6f9d8c32 3000 }
9e353e3b 3001 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW		 3002}
3003
9e353e3b
NIS		 3004PerlIO_funcs PerlIO_perlio = {
3005 "perlio",
3006 sizeof(PerlIOBuf),
f5b9d040 3007 PERLIO_K_BUFFERED,
5e2ab84b 3008 PerlIOBuf_pushed,
06da4f11 3009 PerlIOBase_noop_ok,
e3f3bf95
NIS		 3010 PerlIOBuf_open,
3011 NULL,
3012 PerlIOBase_fileno,
9e353e3b
NIS		 3013 PerlIOBuf_read,
3014 PerlIOBuf_unread,
3015 PerlIOBuf_write,
3016 PerlIOBuf_seek,
3017 PerlIOBuf_tell,
3018 PerlIOBuf_close,
3019 PerlIOBuf_flush,
06da4f11 3020 PerlIOBuf_fill,
9e353e3b
NIS		 3021 PerlIOBase_eof,
3022 PerlIOBase_error,
3023 PerlIOBase_clearerr,
f6c77cf1 3024 PerlIOBase_setlinebuf,
9e353e3b
NIS		 3025 PerlIOBuf_get_base,
3026 PerlIOBuf_bufsiz,
3027 PerlIOBuf_get_ptr,
3028 PerlIOBuf_get_cnt,
3029 PerlIOBuf_set_ptrcnt,
3030};
3031
66ecd56b 3032/*--------------------------------------------------------------------------------------*/
5e2ab84b
NIS		 3033/* Temp layer to hold unread chars when cannot do it any other way */
3034
3035IV
3036PerlIOPending_fill(PerlIO *f)
3037{
3038 /* Should never happen */
3039 PerlIO_flush(f);
3040 return 0;
3041}
3042
3043IV
3044PerlIOPending_close(PerlIO *f)
3045{
3046 /* A tad tricky - flush pops us, then we close new top */
3047 PerlIO_flush(f);
3048 return PerlIO_close(f);
3049}
3050
3051IV
3052PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
3053{
3054 /* A tad tricky - flush pops us, then we seek new top */
3055 PerlIO_flush(f);
3056 return PerlIO_seek(f,offset,whence);
3057}
3058
3059
3060IV
3061PerlIOPending_flush(PerlIO *f)
3062{
a999f61b 3063 dTHX;
5e2ab84b
NIS		 3064 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3065 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
3066 {
5f1a76d0 3067 PerlMemShared_free(b->buf);
5e2ab84b
NIS		 3068 b->buf = NULL;
3069 }
a999f61b 3070 PerlIO_pop(aTHX_ f);
5e2ab84b
NIS		 3071 return 0;
3072}
3073
3074void
3075PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3076{
3077 if (cnt <= 0)
3078 {
3079 PerlIO_flush(f);
3080 }
3081 else
3082 {
3083 PerlIOBuf_set_ptrcnt(f,ptr,cnt);
3084 }
3085}
3086
3087IV
e3f3bf95 3088PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg)
5e2ab84b 3089{
e3f3bf95 3090 IV code = PerlIOBase_pushed(f,mode,arg);
5e2ab84b
NIS		 3091 PerlIOl *l = PerlIOBase(f);
3092 /* Our PerlIO_fast_gets must match what we are pushed on,
3093 or sv_gets() etc. get muddled when it changes mid-string
3094 when we auto-pop.
3095 */
72e44f29
NIS		 3096 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
3097 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
5e2ab84b
NIS		 3098 return code;
3099}
3100
3101SSize_t
3102PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
3103{
3104 SSize_t avail = PerlIO_get_cnt(f);
3105 SSize_t got = 0;
3106 if (count < avail)
3107 avail = count;
3108 if (avail > 0)
3109 got = PerlIOBuf_read(f,vbuf,avail);
1f474064
NIS		 3110 if (got >= 0 && got < count)
3111 {
3112 SSize_t more = PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
3113 if (more >= 0 || got == 0)
3114 got += more;
3115 }
5e2ab84b
NIS		 3116 return got;
3117}
3118
5e2ab84b
NIS		 3119PerlIO_funcs PerlIO_pending = {
3120 "pending",
3121 sizeof(PerlIOBuf),
3122 PERLIO_K_BUFFERED,
5e2ab84b
NIS		 3123 PerlIOPending_pushed,
3124 PerlIOBase_noop_ok,
e3f3bf95
NIS		 3125 NULL,
3126 NULL,
3127 PerlIOBase_fileno,
5e2ab84b
NIS		 3128 PerlIOPending_read,
3129 PerlIOBuf_unread,
3130 PerlIOBuf_write,
3131 PerlIOPending_seek,
3132 PerlIOBuf_tell,
3133 PerlIOPending_close,
3134 PerlIOPending_flush,
3135 PerlIOPending_fill,
3136 PerlIOBase_eof,
3137 PerlIOBase_error,
3138 PerlIOBase_clearerr,
f6c77cf1 3139 PerlIOBase_setlinebuf,
5e2ab84b
NIS		 3140 PerlIOBuf_get_base,
3141 PerlIOBuf_bufsiz,
3142 PerlIOBuf_get_ptr,
3143 PerlIOBuf_get_cnt,
3144 PerlIOPending_set_ptrcnt,
3145};
3146
3147
3148
3149/*--------------------------------------------------------------------------------------*/
99efab12
NIS		 3150/* crlf - translation
3151 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
60382766 3152 to hand back a line at a time and keeping a record of which nl we "lied" about.
99efab12 3153 On write translate "\n" to CR,LF
66ecd56b
NIS		 3154 */
3155
99efab12
NIS		 3156typedef struct
3157{
3158 PerlIOBuf base; /* PerlIOBuf stuff */
60382766 3159 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
99efab12
NIS		 3160} PerlIOCrlf;
3161
f5b9d040 3162IV
e3f3bf95 3163PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg)
f5b9d040
NIS		 3164{
3165 IV code;
3166 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
e3f3bf95 3167 code = PerlIOBuf_pushed(f,mode,arg);
5e2ab84b 3168#if 0
4659c93f 3169 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
f5b9d040 3170 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
a4d3c1d3 3171 PerlIOBase(f)->flags);
5e2ab84b 3172#endif
f5b9d040
NIS		 3173 return code;
3174}
3175
3176
99efab12
NIS		 3177SSize_t
3178PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
3179{
60382766 3180 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
60382766
NIS		 3181 if (c->nl)
3182 {
3183 *(c->nl) = 0xd;
3184 c->nl = NULL;
3185 }
f5b9d040
NIS		 3186 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3187 return PerlIOBuf_unread(f,vbuf,count);
3188 else
99efab12 3189 {
a4d3c1d3 3190 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
f5b9d040
NIS		 3191 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3192 SSize_t unread = 0;
3193 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3194 PerlIO_flush(f);
3195 if (!b->buf)
3196 PerlIO_get_base(f);
3197 if (b->buf)
99efab12 3198 {
f5b9d040 3199 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
99efab12 3200 {
f5b9d040
NIS		 3201 b->end = b->ptr = b->buf + b->bufsiz;
3202 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
5e2ab84b 3203 b->posn -= b->bufsiz;
f5b9d040
NIS		 3204 }
3205 while (count > 0 && b->ptr > b->buf)
3206 {
3207 int ch = *--buf;
3208 if (ch == '\n')
99efab12 3209 {
f5b9d040
NIS		 3210 if (b->ptr - 2 >= b->buf)
3211 {
3212 *--(b->ptr) = 0xa;
3213 *--(b->ptr) = 0xd;
3214 unread++;
3215 count--;
3216 }
3217 else
3218 {
3219 buf++;
3220 break;
3221 }
99efab12
NIS		 3222 }
3223 else
3224 {
f5b9d040
NIS		 3225 *--(b->ptr) = ch;
3226 unread++;
3227 count--;
99efab12
NIS		 3228 }
3229 }
99efab12 3230 }
f5b9d040 3231 return unread;
99efab12 3232 }
99efab12
NIS		 3233}
3234
3235SSize_t
3236PerlIOCrlf_get_cnt(PerlIO *f)
3237{
3238 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3239 if (!b->buf)
3240 PerlIO_get_base(f);
3241 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
3242 {
3243 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
f5b9d040 3244 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
99efab12
NIS		 3245 {
3246 STDCHAR *nl = b->ptr;
60382766 3247 scan:
99efab12
NIS		 3248 while (nl < b->end && *nl != 0xd)
3249 nl++;
3250 if (nl < b->end && *nl == 0xd)
3251 {
60382766 3252 test:
99efab12
NIS		 3253 if (nl+1 < b->end)
3254 {
3255 if (nl[1] == 0xa)
3256 {
3257 *nl = '\n';
60382766 3258 c->nl = nl;
99efab12 3259 }
60382766 3260 else
99efab12
NIS		 3261 {
3262 /* Not CR,LF but just CR */
3263 nl++;
60382766 3264 goto scan;
99efab12
NIS		 3265 }
3266 }
3267 else
3268 {
60382766 3269 /* Blast - found CR as last char in buffer */
99efab12
NIS		 3270 if (b->ptr < nl)
3271 {
3272 /* They may not care, defer work as long as possible */
60382766 3273 return (nl - b->ptr);
99efab12
NIS		 3274 }
3275 else
3276 {
3277 int code;
99efab12
NIS		 3278 b->ptr++; /* say we have read it as far as flush() is concerned */
3279 b->buf++; /* Leave space an front of buffer */
3280 b->bufsiz--; /* Buffer is thus smaller */
3281 code = PerlIO_fill(f); /* Fetch some more */
3282 b->bufsiz++; /* Restore size for next time */
3283 b->buf--; /* Point at space */
3284 b->ptr = nl = b->buf; /* Which is what we hand off */
3285 b->posn--; /* Buffer starts here */
3286 *nl = 0xd; /* Fill in the CR */
60382766 3287 if (code == 0)
99efab12
NIS		 3288 goto test; /* fill() call worked */
3289 /* CR at EOF - just fall through */
3290 }
3291 }
60382766
NIS		 3292 }
3293 }
99efab12
NIS		 3294 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
3295 }
3296 return 0;
3297}
3298
3299void
3300PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
3301{
3302 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3303 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
f5b9d040 3304 IV flags = PerlIOBase(f)->flags;
99efab12
NIS		 3305 if (!b->buf)
3306 PerlIO_get_base(f);
3307 if (!ptr)
60382766 3308 {
63dbdb06
NIS		 3309 if (c->nl)
3310 ptr = c->nl+1;
3311 else
3312 {
3313 ptr = b->end;
f5b9d040 3314 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
63dbdb06
NIS		 3315 ptr--;
3316 }
3317 ptr -= cnt;
60382766
NIS		 3318 }
3319 else
3320 {
63dbdb06
NIS		 3321 /* Test code - delete when it works ... */
3322 STDCHAR *chk;
3323 if (c->nl)
3324 chk = c->nl+1;
3325 else
3326 {
3327 chk = b->end;
f5b9d040 3328 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
63dbdb06
NIS		 3329 chk--;
3330 }
3331 chk -= cnt;
a4d3c1d3 3332
63dbdb06
NIS		 3333 if (ptr != chk)
3334 {
3335 dTHX;
4659c93f 3336 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
a4d3c1d3 3337 ptr, chk, flags, c->nl, b->end, cnt);
63dbdb06 3338 }
60382766 3339 }
99efab12
NIS		 3340 if (c->nl)
3341 {
3342 if (ptr > c->nl)
3343 {
3344 /* They have taken what we lied about */
3345 *(c->nl) = 0xd;
3346 c->nl = NULL;
3347 ptr++;
60382766 3348 }
99efab12
NIS		 3349 }
3350 b->ptr = ptr;
3351 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
3352}
3353
3354SSize_t
3355PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
3356{
f5b9d040
NIS		 3357 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
3358 return PerlIOBuf_write(f,vbuf,count);
3359 else
99efab12 3360 {
a4d3c1d3 3361 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
f5b9d040
NIS		 3362 const STDCHAR *buf = (const STDCHAR *) vbuf;
3363 const STDCHAR *ebuf = buf+count;
3364 if (!b->buf)
3365 PerlIO_get_base(f);
3366 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
3367 return 0;
3368 while (buf < ebuf)
99efab12 3369 {
f5b9d040
NIS		 3370 STDCHAR *eptr = b->buf+b->bufsiz;
3371 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
3372 while (buf < ebuf && b->ptr < eptr)
99efab12 3373 {
f5b9d040 3374 if (*buf == '\n')
60382766 3375 {
f5b9d040 3376 if ((b->ptr + 2) > eptr)
60382766 3377 {
f5b9d040 3378 /* Not room for both */
60382766
NIS		 3379 PerlIO_flush(f);
3380 break;
3381 }
f5b9d040
NIS		 3382 else
3383 {
3384 *(b->ptr)++ = 0xd; /* CR */
3385 *(b->ptr)++ = 0xa; /* LF */
3386 buf++;
3387 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
3388 {
3389 PerlIO_flush(f);
3390 break;
3391 }
3392 }
3393 }
3394 else
3395 {
3396 int ch = *buf++;
3397 *(b->ptr)++ = ch;
3398 }
3399 if (b->ptr >= eptr)
3400 {
3401 PerlIO_flush(f);
3402 break;
99efab12 3403 }
99efab12
NIS		 3404 }
3405 }
f5b9d040
NIS		 3406 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
3407 PerlIO_flush(f);
3408 return (buf - (STDCHAR *) vbuf);
99efab12 3409 }
99efab12
NIS		 3410}
3411
3412IV
3413PerlIOCrlf_flush(PerlIO *f)
3414{
3415 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
3416 if (c->nl)
3417 {
99efab12 3418 *(c->nl) = 0xd;
60382766 3419 c->nl = NULL;
99efab12
NIS		 3420 }
3421 return PerlIOBuf_flush(f);
3422}
3423
66ecd56b
NIS		 3424PerlIO_funcs PerlIO_crlf = {
3425 "crlf",
99efab12 3426 sizeof(PerlIOCrlf),
f5b9d040 3427 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
f5b9d040 3428 PerlIOCrlf_pushed,
99efab12 3429 PerlIOBase_noop_ok, /* popped */
e3f3bf95
NIS		 3430 PerlIOBuf_open,
3431 NULL,
3432 PerlIOBase_fileno,
99efab12
NIS		 3433 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
3434 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
3435 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
66ecd56b
NIS		 3436 PerlIOBuf_seek,
3437 PerlIOBuf_tell,
3438 PerlIOBuf_close,
99efab12 3439 PerlIOCrlf_flush,
66ecd56b
NIS		 3440 PerlIOBuf_fill,
3441 PerlIOBase_eof,
3442 PerlIOBase_error,
3443 PerlIOBase_clearerr,
f6c77cf1 3444 PerlIOBase_setlinebuf,
66ecd56b
NIS		 3445 PerlIOBuf_get_base,
3446 PerlIOBuf_bufsiz,
3447 PerlIOBuf_get_ptr,
99efab12
NIS		 3448 PerlIOCrlf_get_cnt,
3449 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS		 3450};
3451
06da4f11
NIS		 3452#ifdef HAS_MMAP
3453/*--------------------------------------------------------------------------------------*/
3454/* mmap as "buffer" layer */
3455
3456typedef struct
3457{
3458 PerlIOBuf base; /* PerlIOBuf stuff */
c3d7c7c9 3459 Mmap_t mptr; /* Mapped address */
06da4f11
NIS		 3460 Size_t len; /* mapped length */
3461 STDCHAR *bbuf; /* malloced buffer if map fails */
3462} PerlIOMmap;
3463
c3d7c7c9
NIS		 3464static size_t page_size = 0;
3465
06da4f11
NIS		 3466IV
3467PerlIOMmap_map(PerlIO *f)
3468{
68d873c6 3469 dTHX;
06da4f11 3470 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
06da4f11
NIS		 3471 IV flags = PerlIOBase(f)->flags;
3472 IV code = 0;
3473 if (m->len)
3474 abort();
3475 if (flags & PERLIO_F_CANREAD)
3476 {
3477 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3478 int fd = PerlIO_fileno(f);
3479 struct stat st;
3480 code = fstat(fd,&st);
3481 if (code == 0 && S_ISREG(st.st_mode))
3482 {
3483 SSize_t len = st.st_size - b->posn;
3484 if (len > 0)
3485 {
c3d7c7c9 3486 Off_t posn;
68d873c6
JH		 3487 if (!page_size) {
3488#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
3489 {
3490 SETERRNO(0,SS$_NORMAL);
3491# ifdef _SC_PAGESIZE
3492 page_size = sysconf(_SC_PAGESIZE);
3493# else
3494 page_size = sysconf(_SC_PAGE_SIZE);
14aaf8e8 3495# endif
68d873c6
JH		 3496 if ((long)page_size < 0) {
3497 if (errno) {
3498 SV *error = ERRSV;
3499 char *msg;
3500 STRLEN n_a;
3501 (void)SvUPGRADE(error, SVt_PV);
3502 msg = SvPVx(error, n_a);
14aaf8e8 3503 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
68d873c6
JH		 3504 }
3505 else
14aaf8e8 3506 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
68d873c6
JH		 3507 }
3508 }
3509#else
3510# ifdef HAS_GETPAGESIZE
c3d7c7c9 3511 page_size = getpagesize();
68d873c6
JH		 3512# else
3513# if defined(I_SYS_PARAM) && defined(PAGESIZE)
3514 page_size = PAGESIZE; /* compiletime, bad */
3515# endif
3516# endif
3517#endif
3518 if ((IV)page_size <= 0)
14aaf8e8 3519 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
68d873c6 3520 }
c3d7c7c9
NIS		 3521 if (b->posn < 0)
3522 {
3523 /* This is a hack - should never happen - open should have set it ! */
3524 b->posn = PerlIO_tell(PerlIONext(f));
3525 }
3526 posn = (b->posn / page_size) * page_size;
3527 len = st.st_size - posn;
a5262162 3528 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
c3d7c7c9 3529 if (m->mptr && m->mptr != (Mmap_t) -1)
06da4f11 3530 {
a5262162 3531#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
c3d7c7c9 3532 madvise(m->mptr, len, MADV_SEQUENTIAL);
06da4f11 3533#endif
a5262162
NIS		 3534#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
3535 madvise(m->mptr, len, MADV_WILLNEED);
3536#endif
c3d7c7c9
NIS		 3537 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
3538 b->end = ((STDCHAR *)m->mptr) + len;
3539 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
3540 b->ptr = b->buf;
3541 m->len = len;
06da4f11
NIS		 3542 }
3543 else
3544 {
3545 b->buf = NULL;
3546 }
3547 }
3548 else
3549 {
3550 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
3551 b->buf = NULL;
3552 b->ptr = b->end = b->ptr;
3553 code = -1;
3554 }
3555 }
3556 }
3557 return code;
3558}
3559
3560IV
3561PerlIOMmap_unmap(PerlIO *f)
3562{
3563 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3564 PerlIOBuf *b = &m->base;
3565 IV code = 0;
3566 if (m->len)
3567 {
3568 if (b->buf)
3569 {
c3d7c7c9
NIS		 3570 code = munmap(m->mptr, m->len);
3571 b->buf = NULL;
3572 m->len = 0;
3573 m->mptr = NULL;
06da4f11
NIS		 3574 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
3575 code = -1;
06da4f11
NIS		 3576 }
3577 b->ptr = b->end = b->buf;
3578 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
3579 }
3580 return code;
3581}
3582
3583STDCHAR *
3584PerlIOMmap_get_base(PerlIO *f)
3585{
3586 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3587 PerlIOBuf *b = &m->base;
3588 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3589 {
3590 /* Already have a readbuffer in progress */
3591 return b->buf;
3592 }
3593 if (b->buf)
3594 {
3595 /* We have a write buffer or flushed PerlIOBuf read buffer */
3596 m->bbuf = b->buf; /* save it in case we need it again */
3597 b->buf = NULL; /* Clear to trigger below */
3598 }
3599 if (!b->buf)
3600 {
3601 PerlIOMmap_map(f); /* Try and map it */
3602 if (!b->buf)
3603 {
3604 /* Map did not work - recover PerlIOBuf buffer if we have one */
3605 b->buf = m->bbuf;
3606 }
3607 }
3608 b->ptr = b->end = b->buf;
3609 if (b->buf)
3610 return b->buf;
3611 return PerlIOBuf_get_base(f);
3612}
3613
3614SSize_t
3615PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
3616{
3617 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3618 PerlIOBuf *b = &m->base;
3619 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
3620 PerlIO_flush(f);
3621 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
3622 {
3623 b->ptr -= count;
3624 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
3625 return count;
3626 }
3627 if (m->len)
3628 {
4a4a6116 3629 /* Loose the unwritable mapped buffer */
06da4f11 3630 PerlIO_flush(f);
c3d7c7c9
NIS		 3631 /* If flush took the "buffer" see if we have one from before */
3632 if (!b->buf && m->bbuf)
3633 b->buf = m->bbuf;
3634 if (!b->buf)
3635 {
3636 PerlIOBuf_get_base(f);
3637 m->bbuf = b->buf;
3638 }
06da4f11 3639 }
5e2ab84b 3640return PerlIOBuf_unread(f,vbuf,count);
06da4f11
NIS		 3641}
3642
3643SSize_t
3644PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
3645{
3646 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3647 PerlIOBuf *b = &m->base;
3648 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
3649 {
3650 /* No, or wrong sort of, buffer */
3651 if (m->len)
3652 {
3653 if (PerlIOMmap_unmap(f) != 0)
3654 return 0;
3655 }
3656 /* If unmap took the "buffer" see if we have one from before */
3657 if (!b->buf && m->bbuf)
3658 b->buf = m->bbuf;
3659 if (!b->buf)
3660 {
3661 PerlIOBuf_get_base(f);
3662 m->bbuf = b->buf;
3663 }
3664 }
3665 return PerlIOBuf_write(f,vbuf,count);
3666}
3667
3668IV
3669PerlIOMmap_flush(PerlIO *f)
3670{
3671 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3672 PerlIOBuf *b = &m->base;
3673 IV code = PerlIOBuf_flush(f);
3674 /* Now we are "synced" at PerlIOBuf level */
3675 if (b->buf)
3676 {
3677 if (m->len)
3678 {
3679 /* Unmap the buffer */
3680 if (PerlIOMmap_unmap(f) != 0)
3681 code = -1;
3682 }
3683 else
3684 {
3685 /* We seem to have a PerlIOBuf buffer which was not mapped
3686 * remember it in case we need one later
3687 */
3688 m->bbuf = b->buf;
3689 }
3690 }
06da4f11
NIS		 3691 return code;
3692}
3693
3694IV
3695PerlIOMmap_fill(PerlIO *f)
3696{
3697 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3698 IV code = PerlIO_flush(f);
06da4f11
NIS		 3699 if (code == 0 && !b->buf)
3700 {
3701 code = PerlIOMmap_map(f);
06da4f11
NIS		 3702 }
3703 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3704 {
3705 code = PerlIOBuf_fill(f);
06da4f11
NIS		 3706 }
3707 return code;
3708}
3709
3710IV
3711PerlIOMmap_close(PerlIO *f)
3712{
3713 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
3714 PerlIOBuf *b = &m->base;
3715 IV code = PerlIO_flush(f);
3716 if (m->bbuf)
3717 {
3718 b->buf = m->bbuf;
3719 m->bbuf = NULL;
3720 b->ptr = b->end = b->buf;
3721 }
3722 if (PerlIOBuf_close(f) != 0)
3723 code = -1;
06da4f11
NIS		 3724 return code;
3725}
3726
3727
3728PerlIO_funcs PerlIO_mmap = {
3729 "mmap",
3730 sizeof(PerlIOMmap),
f5b9d040 3731 PERLIO_K_BUFFERED,
5e2ab84b 3732 PerlIOBuf_pushed,
06da4f11 3733 PerlIOBase_noop_ok,
e3f3bf95
NIS		 3734 PerlIOBuf_open,
3735 NULL,
3736 PerlIOBase_fileno,
06da4f11
NIS		 3737 PerlIOBuf_read,
3738 PerlIOMmap_unread,
3739 PerlIOMmap_write,
3740 PerlIOBuf_seek,
3741 PerlIOBuf_tell,
3742 PerlIOBuf_close,
3743 PerlIOMmap_flush,
3744 PerlIOMmap_fill,
3745 PerlIOBase_eof,
3746 PerlIOBase_error,
3747 PerlIOBase_clearerr,
f6c77cf1 3748 PerlIOBase_setlinebuf,
06da4f11
NIS		 3749 PerlIOMmap_get_base,
3750 PerlIOBuf_bufsiz,
3751 PerlIOBuf_get_ptr,
3752 PerlIOBuf_get_cnt,
3753 PerlIOBuf_set_ptrcnt,
3754};
3755
3756#endif /* HAS_MMAP */
3757
9e353e3b
NIS		 3758void
3759PerlIO_init(void)
760ac839 3760{
9a6404c5 3761 dTHX;
43c11ae3 3762#ifndef WIN32
9a6404c5 3763 call_atexit(PerlIO_cleanup_layers, NULL);
43c11ae3 3764#endif
9e353e3b 3765 if (!_perlio)
6f9d8c32 3766 {
be696b0a 3767#ifndef WIN32
9e353e3b 3768 atexit(&PerlIO_cleanup);
be696b0a 3769#endif
6f9d8c32 3770 }
760ac839
LW		 3771}
3772
9e353e3b
NIS		 3773#undef PerlIO_stdin
3774PerlIO *
3775PerlIO_stdin(void)
3776{
3777 if (!_perlio)
1141d9f8
NIS		 3778 {
3779 dTHX;
3780 PerlIO_stdstreams(aTHX);
3781 }
05d1247b 3782 return &_perlio[1];
9e353e3b
NIS		 3783}
3784
3785#undef PerlIO_stdout
3786PerlIO *
3787PerlIO_stdout(void)
3788{
3789 if (!_perlio)
1141d9f8
NIS		 3790 {
3791 dTHX;
3792 PerlIO_stdstreams(aTHX);
3793 }
05d1247b 3794 return &_perlio[2];
9e353e3b
NIS		 3795}
3796
3797#undef PerlIO_stderr
3798PerlIO *
3799PerlIO_stderr(void)
3800{
3801 if (!_perlio)
1141d9f8
NIS		 3802 {
3803 dTHX;
3804 PerlIO_stdstreams(aTHX);
3805 }
05d1247b 3806 return &_perlio[3];
9e353e3b
NIS		 3807}
3808
3809/*--------------------------------------------------------------------------------------*/
3810
3811#undef PerlIO_getname
3812char *
3813PerlIO_getname(PerlIO *f, char *buf)
3814{
3815 dTHX;
a15cef0c
CB		 3816 char *name = NULL;
3817#ifdef VMS
3818 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
3819 if (stdio) name = fgetname(stdio, buf);
3820#else
9e353e3b 3821 Perl_croak(aTHX_ "Don't know how to get file name");
a15cef0c
CB		 3822#endif
3823 return name;
9e353e3b
NIS		 3824}
3825
3826
3827/*--------------------------------------------------------------------------------------*/
3828/* Functions which can be called on any kind of PerlIO implemented
3829 in terms of above
3830*/
3831
3832#undef PerlIO_getc
6f9d8c32 3833int
9e353e3b 3834PerlIO_getc(PerlIO *f)
760ac839 3835{
313ca112
NIS		 3836 STDCHAR buf[1];
3837 SSize_t count = PerlIO_read(f,buf,1);
9e353e3b 3838 if (count == 1)
313ca112
NIS		 3839 {
3840 return (unsigned char) buf[0];
3841 }
3842 return EOF;
3843}
3844
3845#undef PerlIO_ungetc
3846int
3847PerlIO_ungetc(PerlIO *f, int ch)
3848{
3849 if (ch != EOF)
3850 {
3851 STDCHAR buf = ch;
3852 if (PerlIO_unread(f,&buf,1) == 1)
3853 return ch;
3854 }
3855 return EOF;
760ac839
LW		 3856}
3857
9e353e3b
NIS		 3858#undef PerlIO_putc
3859int
3860PerlIO_putc(PerlIO *f, int ch)
760ac839 3861{
9e353e3b
NIS		 3862 STDCHAR buf = ch;
3863 return PerlIO_write(f,&buf,1);
760ac839
LW		 3864}
3865
9e353e3b 3866#undef PerlIO_puts
760ac839 3867int
9e353e3b 3868PerlIO_puts(PerlIO *f, const char *s)
760ac839 3869{
9e353e3b
NIS		 3870 STRLEN len = strlen(s);
3871 return PerlIO_write(f,s,len);
760ac839
LW		 3872}
3873
3874#undef PerlIO_rewind
3875void
c78749f2 3876PerlIO_rewind(PerlIO *f)
760ac839 3877{
6f9d8c32 3878 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 3879 PerlIO_clearerr(f);
6f9d8c32
NIS		 3880}
3881
3882#undef PerlIO_vprintf
3883int
3884PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
3885{
3886 dTHX;
bb9950b7 3887 SV *sv = newSVpvn("",0);
6f9d8c32
NIS		 3888 char *s;
3889 STRLEN len;
933fb4e4 3890 SSize_t wrote;
2cc61e15
DD		 3891#ifdef NEED_VA_COPY
3892 va_list apc;
3893 Perl_va_copy(ap, apc);
3894 sv_vcatpvf(sv, fmt, &apc);
3895#else
6f9d8c32 3896 sv_vcatpvf(sv, fmt, &ap);
2cc61e15 3897#endif
6f9d8c32 3898 s = SvPV(sv,len);
933fb4e4
BS		 3899 wrote = PerlIO_write(f,s,len);
3900 SvREFCNT_dec(sv);
3901 return wrote;
760ac839
LW		 3902}
3903
3904#undef PerlIO_printf
6f9d8c32 3905int
760ac839 3906PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW		 3907{
3908 va_list ap;
3909 int result;
760ac839 3910 va_start(ap,fmt);
6f9d8c32 3911 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW		 3912 va_end(ap);
3913 return result;
3914}
3915
3916#undef PerlIO_stdoutf
6f9d8c32 3917int
760ac839 3918PerlIO_stdoutf(const char *fmt,...)
760ac839
LW		 3919{
3920 va_list ap;
3921 int result;
760ac839 3922 va_start(ap,fmt);
760ac839
LW		 3923 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
3924 va_end(ap);
3925 return result;
3926}
3927
3928#undef PerlIO_tmpfile
3929PerlIO *
c78749f2 3930PerlIO_tmpfile(void)
760ac839 3931{
b1ef6e3b 3932 /* I have no idea how portable mkstemp() is ... */
83b075c3 3933#if defined(WIN32) || !defined(HAVE_MKSTEMP)
adb71456 3934 dTHX;
83b075c3 3935 PerlIO *f = NULL;
eaf8b698 3936 FILE *stdio = PerlSIO_tmpfile();
83b075c3
NIS		 3937 if (stdio)
3938 {
e3f3bf95 3939 PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio);
83b075c3
NIS		 3940 s->stdio = stdio;
3941 }
3942 return f;
3943#else
3944 dTHX;
6f9d8c32
NIS		 3945 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3946 int fd = mkstemp(SvPVX(sv));
3947 PerlIO *f = NULL;
3948 if (fd >= 0)
3949 {
b1ef6e3b 3950 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS		 3951 if (f)
3952 {
9e353e3b 3953 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32 3954 }
00b02797 3955 PerlLIO_unlink(SvPVX(sv));
6f9d8c32
NIS		 3956 SvREFCNT_dec(sv);
3957 }
3958 return f;
83b075c3 3959#endif
760ac839
LW		 3960}
3961
6f9d8c32
NIS		 3962#undef HAS_FSETPOS
3963#undef HAS_FGETPOS
3964
760ac839
LW		 3965#endif /* USE_SFIO */
3966#endif /* PERLIO_IS_STDIO */
3967
9e353e3b
NIS		 3968/*======================================================================================*/
3969/* Now some functions in terms of above which may be needed even if
3970 we are not in true PerlIO mode
3971 */
3972
760ac839
LW		 3973#ifndef HAS_FSETPOS
3974#undef PerlIO_setpos
3975int
766a733e 3976PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 3977{
766a733e
NIS		 3978 dTHX;
3979 if (SvOK(pos))
3980 {
3981 STRLEN len;
3982 Off_t *posn = (Off_t *) SvPV(pos,len);
3983 if (f && len == sizeof(Off_t))
3984 return PerlIO_seek(f,*posn,SEEK_SET);
3985 }
ba412a5d 3986 SETERRNO(EINVAL,SS$_IVCHAN);
766a733e 3987 return -1;
760ac839 3988}
c411622e 3989#else
c411622e 3990#undef PerlIO_setpos
3991int
766a733e 3992PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 3993{
766a733e
NIS		 3994 dTHX;
3995 if (SvOK(pos))
3996 {
3997 STRLEN len;
3998 Fpos_t *fpos = (Fpos_t *) SvPV(pos,len);
3999 if (f && len == sizeof(Fpos_t))
4000 {
2d4389e4 4001#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
766a733e 4002 return fsetpos64(f, fpos);
d9b3e12d 4003#else
766a733e 4004 return fsetpos(f, fpos);
d9b3e12d 4005#endif
766a733e
NIS		 4006 }
4007 }
ba412a5d 4008 SETERRNO(EINVAL,SS$_IVCHAN);
766a733e 4009 return -1;
c411622e 4010}
4011#endif
760ac839
LW		 4012
4013#ifndef HAS_FGETPOS
4014#undef PerlIO_getpos
4015int
766a733e 4016PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 4017{
766a733e
NIS		 4018 dTHX;
4019 Off_t posn = PerlIO_tell(f);
4020 sv_setpvn(pos,(char *)&posn,sizeof(posn));
4021 return (posn == (Off_t)-1) ? -1 : 0;
760ac839 4022}
c411622e 4023#else
c411622e 4024#undef PerlIO_getpos
4025int
766a733e 4026PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 4027{
766a733e
NIS		 4028 dTHX;
4029 Fpos_t fpos;
4030 int code;
2d4389e4 4031#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
766a733e 4032 code = fgetpos64(f, &fpos);
d9b3e12d 4033#else
766a733e 4034 code = fgetpos(f, &fpos);
d9b3e12d 4035#endif
766a733e
NIS		 4036 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
4037 return code;
c411622e 4038}
4039#endif
760ac839
LW		 4040
4041#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
4042
4043int
c78749f2 4044vprintf(char *pat, char *args)
662a7e3f
CS		 4045{
4046 _doprnt(pat, args, stdout);
4047 return 0; /* wrong, but perl doesn't use the return value */
4048}
4049
4050int
c78749f2 4051vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW		 4052{
4053 _doprnt(pat, args, fd);
4054 return 0; /* wrong, but perl doesn't use the return value */
4055}
4056
4057#endif
4058
4059#ifndef PerlIO_vsprintf
6f9d8c32 4060int
8ac85365 4061PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW		 4062{
4063 int val = vsprintf(s, fmt, ap);
4064 if (n >= 0)
4065 {
8c86a920 4066 if (strlen(s) >= (STRLEN)n)
760ac839 4067 {
bf49b057 4068 dTHX;
fb4a9925
JH		 4069 (void)PerlIO_puts(Perl_error_log,
4070 "panic: sprintf overflow - memory corrupted!\n");
bf49b057 4071 my_exit(1);
760ac839
LW		 4072 }
4073 }
4074 return val;
4075}
4076#endif
4077
4078#ifndef PerlIO_sprintf
6f9d8c32 4079int
760ac839 4080PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW		 4081{
4082 va_list ap;
4083 int result;
760ac839 4084 va_start(ap,fmt);
760ac839
LW		 4085 result = PerlIO_vsprintf(s, n, fmt, ap);
4086 va_end(ap);
4087 return result;
4088}
4089#endif
4090
c5be433b 4091
7bcba3d4
NIS		 4092
4093
4094
e06a3afb 4095
Unnamed repository; edit this file 'description' to name the repository.