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