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