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