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