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