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