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