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