projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
SYN SYN
[p5sagit/p5-mst-13.2.git] / perlio.c
CommitLineData
760ac839 1/* perlio.c
2 *
cb50131a 3 * Copyright (c) 1996-2000, Nick Ing-Simmons
760ac839 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
4b19af01 11#ifdef PERL_MICRO
12# include "uconfig.h"
13#else
14# include "config.h"
15#endif
760ac839 16
0e06870b 17#define PERLIO_NOT_STDIO 0
760ac839 18#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
0e06870b 19/* #define PerlIO FILE */
760ac839 20#endif
21/*
0e06870b 22 * This file provides those parts of PerlIO abstraction
23 * which are not #defined in perlio.h.
24 * Which these are depends on various Configure #ifdef's
760ac839 25 */
26
27#include "EXTERN.h"
864dbfa3 28#define PERL_IN_PERLIO_C
760ac839 29#include "perl.h"
30
0e06870b 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
36int
37perlsio_binmode(FILE *fp, int iotype, int mode)
38{
39/* This used to be contents of do_binmode in doio.c */
40#ifdef DOSISH
41# if defined(atarist) || defined(__MINT__)
42 if (!fflush(fp)) {
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
51 dTHX;
52 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
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 */
60 fseek(fp,0L,0);
61 if (mode & O_BINARY)
62 fp->flags |= _F_BIN;
63 else
64 fp->flags &= ~ _F_BIN;
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
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
96int
97PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
98{
99 return perlsio_binmode(fp,iotype,mode);
100}
101
102#endif
103
146174a9 104
0e06870b 105#ifdef PERLIO_IS_STDIO
760ac839 106
107void
8ac85365 108PerlIO_init(void)
760ac839 109{
0e06870b 110 /* Does nothing (yet) except force this file to be included
760ac839 111 in perl binary. That allows this file to force inclusion
0e06870b 112 of other functions that may be required by loadable
113 extensions e.g. for FileHandle::tmpfile
760ac839 114 */
115}
116
33dcbb9a 117#undef PerlIO_tmpfile
118PerlIO *
8ac85365 119PerlIO_tmpfile(void)
33dcbb9a 120{
121 return tmpfile();
122}
123
760ac839 124#else /* PERLIO_IS_STDIO */
125
126#ifdef USE_SFIO
127
128#undef HAS_FSETPOS
129#undef HAS_FGETPOS
130
0e06870b 131/* This section is just to make sure these functions
760ac839 132 get pulled in from libsfio.a
133*/
134
135#undef PerlIO_tmpfile
136PerlIO *
c78749f2 137PerlIO_tmpfile(void)
760ac839 138{
139 return sftmp(0);
140}
141
142void
c78749f2 143PerlIO_init(void)
760ac839 144{
0e06870b 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 148 */
149
150 /* Hack
151 * sfio does its own 'autoflush' on stdout in common cases.
0e06870b 152 * Flush results in a lot of lseek()s to regular files and
760ac839 153 * lot of small writes to pipes.
154 */
155 sfset(sfstdout,SF_SHARE,0);
156}
157
17c3b450 158#else /* USE_SFIO */
0e06870b 159/*======================================================================================*/
160/* Implement all the PerlIO interface ourselves.
161 */
760ac839 162
0e06870b 163#include "perliol.h"
760ac839 164
0e06870b 165/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
166#ifdef I_UNISTD
167#include <unistd.h>
168#endif
169#ifdef HAS_MMAP
170#include <sys/mman.h>
171#endif
172
173#include "XSUB.h"
174
175void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
176
177void
178PerlIO_debug(const char *fmt,...)
760ac839 179{
0e06870b 180 dTHX;
181 static int dbg = 0;
182 va_list ap;
183 va_start(ap,fmt);
184 if (!dbg)
185 {
186 char *s = PerlEnv_getenv("PERLIO_DEBUG");
187 if (s && *s)
188 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
189 else
190 dbg = -1;
191 }
192 if (dbg > 0)
193 {
194 dTHX;
195 SV *sv = newSVpvn("",0);
196 char *s;
197 STRLEN len;
198 s = CopFILE(PL_curcop);
199 if (!s)
200 s = "(none)";
201 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
202 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
203
204 s = SvPV(sv,len);
205 PerlLIO_write(dbg,s,len);
206 SvREFCNT_dec(sv);
207 }
208 va_end(ap);
760ac839 209}
210
0e06870b 211/*--------------------------------------------------------------------------------------*/
212
213/* Inner level routines */
214
215/* Table of pointers to the PerlIO structs (malloc'ed) */
216PerlIO *_perlio = NULL;
217#define PERLIO_TABLE_SIZE 64
218
760ac839 219PerlIO *
0e06870b 220PerlIO_allocate(pTHX)
760ac839 221{
0e06870b 222 /* Find a free slot in the table, allocating new table as necessary */
223 PerlIO **last;
224 PerlIO *f;
225 last = &_perlio;
226 while ((f = *last))
227 {
228 int i;
229 last = (PerlIO **)(f);
230 for (i=1; i < PERLIO_TABLE_SIZE; i++)
231 {
232 if (!*++f)
233 {
234 return f;
235 }
236 }
237 }
238 f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO));
239 if (!f)
240 {
241 return NULL;
242 }
243 *last = f;
244 return f+1;
760ac839 245}
246
0e06870b 247void
248PerlIO_cleantable(pTHX_ PerlIO **tablep)
249{
250 PerlIO *table = *tablep;
251 if (table)
252 {
253 int i;
254 PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0]));
255 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
256 {
257 PerlIO *f = table+i;
258 if (*f)
259 {
260 PerlIO_close(f);
261 }
262 }
263 PerlMemShared_free(table);
264 *tablep = NULL;
265 }
266}
267
268HV *PerlIO_layer_hv;
269AV *PerlIO_layer_av;
270
271void
272PerlIO_cleanup()
760ac839 273{
0e06870b 274 dTHX;
275 PerlIO_cleantable(aTHX_ &_perlio);
760ac839 276}
277
0e06870b 278void
279PerlIO_pop(PerlIO *f)
760ac839 280{
0e06870b 281 dTHX;
282 PerlIOl *l = *f;
283 if (l)
284 {
285 PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
286 (*l->tab->Popped)(f);
287 *f = l->next;
288 PerlMemShared_free(l);
289 }
290}
291
292/*--------------------------------------------------------------------------------------*/
293/* XS Interface for perl code */
294
295XS(XS_perlio_import)
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
305XS(XS_perlio_unimport)
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
315SV *
316PerlIO_find_layer(const char *name, STRLEN len)
317{
318 dTHX;
319 SV **svp;
320 SV *sv;
321 if ((SSize_t) len <= 0)
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
329
330static int
331perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
332{
333 if (SvROK(sv))
334 {
335 IO *io = GvIOn((GV *)SvRV(sv));
336 PerlIO *ifp = IoIFP(io);
337 PerlIO *ofp = IoOFP(io);
338 AV *av = (AV *) mg->mg_obj;
339 Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp);
340 }
760ac839 341 return 0;
760ac839 342}
343
0e06870b 344static int
345perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
760ac839 346{
0e06870b 347 if (SvROK(sv))
348 {
349 IO *io = GvIOn((GV *)SvRV(sv));
350 PerlIO *ifp = IoIFP(io);
351 PerlIO *ofp = IoOFP(io);
352 AV *av = (AV *) mg->mg_obj;
353 Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp);
354 }
760ac839 355 return 0;
760ac839 356}
357
0e06870b 358static int
359perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
760ac839 360{
0e06870b 361 Perl_warn(aTHX_ "clear %"SVf,sv);
760ac839 362 return 0;
760ac839 363}
364
0e06870b 365static int
366perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
367{
368 Perl_warn(aTHX_ "free %"SVf,sv);
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);
393 Perl_warn(aTHX_ "attrib %"SVf,sv);
394 for (i=2; i < items; i++)
395 {
396 STRLEN len;
397 const char *name = SvPV(ST(i),len);
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
760ac839 413void
0e06870b 414PerlIO_define_layer(PerlIO_funcs *tab)
760ac839 415{
961e40ee 416 dTHX;
0e06870b 417 HV *stash = gv_stashpv("perlio::Layer", TRUE);
418 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
419 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
847a5fae 420 PerlIO_debug("define %s %p\n",tab->name,tab);
0e06870b 421}
422
847a5fae 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
0e06870b 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 {
454 const char *s = PerlEnv_getenv("PERLIO");
455 newXS("perlio::import",XS_perlio_import,__FILE__);
456 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
457#if 0
458 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
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);
847a5fae 462 PerlIO_define_layer(&PerlIO_raw);
0e06870b 463 PerlIO_define_layer(&PerlIO_unix);
464 PerlIO_define_layer(&PerlIO_perlio);
465 PerlIO_define_layer(&PerlIO_stdio);
466 PerlIO_define_layer(&PerlIO_crlf);
467#ifdef HAS_MMAP
468 PerlIO_define_layer(&PerlIO_mmap);
760ac839 469#endif
847a5fae 470 PerlIO_define_layer(&PerlIO_utf8);
0e06870b 471 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
472 if (s)
473 {
847a5fae 474 IV buffered = 0;
0e06870b 475 while (*s)
476 {
477 while (*s && isSPACE((unsigned char)*s))
478 s++;
479 if (*s)
480 {
481 const char *e = s;
482 SV *layer;
483 while (*e && !isSPACE((unsigned char)*e))
484 e++;
485 if (*s == ':')
486 s++;
487 layer = PerlIO_find_layer(s,e-s);
488 if (layer)
489 {
847a5fae 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 }
0e06870b 496 PerlIO_debug("Pushing %.*s\n",(e-s),s);
497 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
847a5fae 498 buffered |= (tab->kind & PERLIO_K_BUFFERED);
0e06870b 499 }
500 else
501 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
502 s = e;
503 }
504 }
505 }
506 }
507 len = av_len(PerlIO_layer_av);
508 if (len < 1)
509 {
847a5fae 510 PerlIO_default_buffer(aTHX);
0e06870b 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 {
518 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
519 }
520 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
521 return tab;
522}
523
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 {
532 dTHX;
533 PerlIO_allocate(aTHX);
534 PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT);
535 PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT);
536 PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT);
537 }
538}
539
540PerlIO *
541PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
542{
543 dTHX;
544 PerlIOl *l = NULL;
545 l = PerlMemShared_calloc(tab->size,sizeof(char));
546 if (l)
547 {
548 Zero(l,tab->size,char);
549 l->next = *f;
550 l->tab = tab;
551 *f = l;
552 PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
553 if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
554 {
555 PerlIO_pop(f);
556 return NULL;
557 }
558 }
559 return f;
560}
561
847a5fae 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
0e06870b 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;
605 const char *as = Nullch;
606 const char *ae = Nullch;
607 int count = 0;
608 while (*e && *e != ':' && !isSPACE(*e))
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 }
623 if (e > s)
624 {
625 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
626 {
627 /* Pop back to bottom layer */
628 if (PerlIONext(f))
629 {
630 PerlIO_flush(f);
631 while (PerlIONext(f))
632 {
633 PerlIO_pop(f);
634 }
635 }
636 }
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 }
645 else
646 {
647 STRLEN len = ((as) ? as : e)-s;
648 SV *layer = PerlIO_find_layer(s,len);
649 if (layer)
650 {
651 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
652 if (tab)
653 {
b82d478d 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 }
0e06870b 658 len = (as) ? (ae-(as++)-1) : 0;
659 if (!PerlIO_push(f,tab,mode,as,len))
660 return -1;
661 }
662 }
663 else
664 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
665 }
666 }
667 s = e;
668 }
669 }
670 }
671 return 0;
672}
673
674
675
676/*--------------------------------------------------------------------------------------*/
677/* Given the abstraction above the public API functions */
678
679int
680PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
681{
682 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
683 f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
684 if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
685 {
686 PerlIO *top = f;
687 PerlIOl *l;
688 while (l = *top)
689 {
690 if (PerlIOBase(top)->tab == &PerlIO_crlf)
691 {
692 PerlIO_flush(top);
693 PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
694 break;
695 }
696 top = PerlIONext(top);
697 }
698 }
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);
707}
708
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 }
721 return new;
722}
723
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
745#undef PerlIO_fdopen
746PerlIO *
747PerlIO_fdopen(int fd, const char *mode)
748{
749 PerlIO_funcs *tab = PerlIO_default_top();
750 if (!_perlio)
751 PerlIO_stdstreams();
752 return (*tab->Fdopen)(tab,fd,mode);
753}
754
755#undef PerlIO_open
756PerlIO *
757PerlIO_open(const char *path, const char *mode)
758{
759 PerlIO_funcs *tab = PerlIO_default_top();
760 if (!_perlio)
761 PerlIO_stdstreams();
762 return (*tab->Open)(tab,path,mode);
763}
764
765#undef PerlIO_reopen
766PerlIO *
767PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
768{
769 if (f)
770 {
771 PerlIO_flush(f);
772 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
773 {
774 if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
775 return f;
776 }
777 return NULL;
778 }
779 else
780 return PerlIO_open(path,mode);
781}
782
783#undef PerlIO_read
784SSize_t
785PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
786{
787 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
788}
789
790#undef PerlIO_unread
791SSize_t
792PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
793{
794 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
795}
796
797#undef PerlIO_write
798SSize_t
799PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
800{
801 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
760ac839 802}
803
0e06870b 804#undef PerlIO_seek
805int
806PerlIO_seek(PerlIO *f, Off_t offset, int whence)
807{
808 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
809}
810
811#undef PerlIO_tell
812Off_t
813PerlIO_tell(PerlIO *f)
814{
815 return (*PerlIOBase(f)->tab->Tell)(f);
816}
817
818#undef PerlIO_flush
819int
820PerlIO_flush(PerlIO *f)
821{
822 if (f)
823 {
824 return (*PerlIOBase(f)->tab->Flush)(f);
825 }
826 else
827 {
828 PerlIO **table = &_perlio;
829 int code = 0;
830 while ((f = *table))
831 {
832 int i;
833 table = (PerlIO **)(f++);
834 for (i=1; i < PERLIO_TABLE_SIZE; i++)
835 {
836 if (*f && PerlIO_flush(f) != 0)
837 code = -1;
838 f++;
839 }
840 }
841 return code;
842 }
843}
844
845#undef PerlIO_fill
846int
847PerlIO_fill(PerlIO *f)
848{
849 return (*PerlIOBase(f)->tab->Fill)(f);
850}
851
852#undef PerlIO_isutf8
853int
854PerlIO_isutf8(PerlIO *f)
855{
856 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
857}
858
859#undef PerlIO_eof
860int
861PerlIO_eof(PerlIO *f)
862{
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{
877 if (f && *f)
878 (*PerlIOBase(f)->tab->Clearerr)(f);
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)
893 {
894 return (PerlIOBase(f)->tab->Get_base != NULL);
895 }
896 return 0;
897}
898
899#undef PerlIO_fast_gets
900int
901PerlIO_fast_gets(PerlIO *f)
902{
903 if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
904 {
905 PerlIO_funcs *tab = PerlIOBase(f)->tab;
906 return (tab->Set_ptrcnt != NULL);
907 }
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 {
929 PerlIOl *l = PerlIOBase(f);
930 return (l->tab->Set_ptrcnt != NULL);
931 }
932 return 0;
933}
934
935#undef PerlIO_get_base
936STDCHAR *
937PerlIO_get_base(PerlIO *f)
938{
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{
953 PerlIO_funcs *tab = PerlIOBase(f)->tab;
954 if (tab->Get_ptr == NULL)
955 return NULL;
956 return (*tab->Get_ptr)(f);
957}
958
959#undef PerlIO_get_cnt
960int
961PerlIO_get_cnt(PerlIO *f)
962{
963 PerlIO_funcs *tab = PerlIOBase(f)->tab;
964 if (tab->Get_cnt == NULL)
965 return 0;
966 return (*tab->Get_cnt)(f);
967}
968
969#undef PerlIO_set_cnt
970void
971PerlIO_set_cnt(PerlIO *f,int cnt)
972{
973 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
974}
975
976#undef PerlIO_set_ptrcnt
977void
978PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
979{
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 }
986 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
987}
988
989/*--------------------------------------------------------------------------------------*/
847a5fae 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/*--------------------------------------------------------------------------------------*/
0e06870b 1089/* "Methods" of the "base class" */
1090
1091IV
1092PerlIOBase_fileno(PerlIO *f)
1093{
1094 return PerlIO_fileno(PerlIONext(f));
1095}
1096
1097char *
1098PerlIO_modestr(PerlIO *f,char *buf)
1099{
1100 char *s = buf;
1101 IV flags = PerlIOBase(f)->flags;
1102 if (flags & PERLIO_F_APPEND)
1103 {
1104 *s++ = 'a';
1105 if (flags & PERLIO_F_CANREAD)
1106 {
1107 *s++ = '+';
1108 }
1109 }
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))
1126 *s++ = 'b';
1127#endif
1128 *s = '\0';
1129 return buf;
1130}
1131
1132IV
1133PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1134{
1135 PerlIOl *l = PerlIOBase(f);
1136 const char *omode = mode;
1137 char temp[8];
1138 PerlIO_funcs *tab = PerlIOBase(f)->tab;
1139 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
1140 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1141 if (tab->Set_ptrcnt != NULL)
1142 l->flags |= PERLIO_F_FASTGETS;
1143 if (mode)
1144 {
1145 switch (*mode++)
1146 {
1147 case 'r':
1148 l->flags |= PERLIO_F_CANREAD;
1149 break;
1150 case 'a':
1151 l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE;
1152 break;
1153 case 'w':
1154 l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
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':
1168 l->flags &= ~PERLIO_F_CRLF;
1169 break;
1170 case 't':
1171 l->flags |= PERLIO_F_CRLF;
1172 break;
1173 default:
1174 errno = EINVAL;
1175 return -1;
1176 }
1177 }
1178 }
1179 else
1180 {
1181 if (l->next)
1182 {
1183 l->flags |= l->next->flags &
1184 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
1185 }
1186 }
1187#if 0
1188 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n",
1189 f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
1190 l->flags,PerlIO_modestr(f,temp));
1191#endif
1192 return 0;
1193}
1194
1195IV
1196PerlIOBase_popped(PerlIO *f)
1197{
1198 return 0;
1199}
1200
1201SSize_t
1202PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
1203{
1204 Off_t old = PerlIO_tell(f);
1205 SSize_t done;
1206 PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
1207 done = PerlIOBuf_unread(f,vbuf,count);
1208 PerlIOSelf(f,PerlIOBuf)->posn = old - done;
1209 return done;
1210}
1211
1212IV
1213PerlIOBase_noop_ok(PerlIO *f)
1214{
1215 return 0;
1216}
1217
1218IV
1219PerlIOBase_noop_fail(PerlIO *f)
1220{
1221 return -1;
1222}
1223
1224IV
1225PerlIOBase_close(PerlIO *f)
1226{
1227 IV code = 0;
1228 PerlIO *n = PerlIONext(f);
1229 if (PerlIO_flush(f) != 0)
1230 code = -1;
1231 if (n && (*PerlIOBase(n)->tab->Close)(n) != 0)
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 {
1262 PerlIO *n = PerlIONext(f);
1263 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF);
1264 if (n)
1265 PerlIO_clearerr(n);
1266 }
1267}
1268
1269void
1270PerlIOBase_setlinebuf(PerlIO *f)
1271{
1272
1273}
1274
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
1285int
1286PerlIOUnix_oflags(const char *mode)
1287{
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 }
1322 if (*mode == 'b')
1323 {
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;
1332 mode++;
1333 }
1334 /* Always open in binary mode */
1335 oflags |= O_BINARY;
1336 if (*mode || oflags == -1)
1337 {
1338 errno = EINVAL;
1339 oflags = -1;
1340 }
1341 return oflags;
1342}
1343
1344IV
1345PerlIOUnix_fileno(PerlIO *f)
1346{
1347 return PerlIOSelf(f,PerlIOUnix)->fd;
1348}
1349
1350PerlIO *
1351PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1352{
1353 dTHX;
1354 PerlIO *f = NULL;
1355 if (*mode == 'I')
1356 mode++;
1357 if (fd >= 0)
1358 {
1359 int oflags = PerlIOUnix_oflags(mode);
1360 if (oflags != -1)
1361 {
1362 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1363 s->fd = fd;
1364 s->oflags = oflags;
1365 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1366 }
1367 }
1368 return f;
1369}
1370
1371PerlIO *
1372PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
1373{
1374 dTHX;
1375 PerlIO *f = NULL;
1376 int oflags = PerlIOUnix_oflags(mode);
1377 if (oflags != -1)
1378 {
1379 int fd = PerlLIO_open3(path,oflags,0666);
1380 if (fd >= 0)
1381 {
1382 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
1383 s->fd = fd;
1384 s->oflags = oflags;
1385 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1386 }
1387 }
1388 return f;
1389}
1390
1391int
1392PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
1393{
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 {
1400 dTHX;
1401 int fd = PerlLIO_open3(path,oflags,0666);
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{
1416 dTHX;
1417 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1418 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1419 return 0;
1420 while (1)
1421 {
1422 SSize_t len = PerlLIO_read(fd,vbuf,count);
1423 if (len >= 0 || errno != EINTR)
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 }
847a5fae 1431 PERL_ASYNC_CHECK();
0e06870b 1432 }
1433}
1434
1435SSize_t
1436PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1437{
1438 dTHX;
1439 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1440 while (1)
1441 {
1442 SSize_t len = PerlLIO_write(fd,vbuf,count);
1443 if (len >= 0 || errno != EINTR)
1444 {
1445 if (len < 0)
1446 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1447 return len;
1448 }
847a5fae 1449 PERL_ASYNC_CHECK();
0e06870b 1450 }
1451}
1452
1453IV
1454PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1455{
1456 dTHX;
1457 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
1458 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1459 return (new == (Off_t) -1) ? -1 : 0;
1460}
1461
1462Off_t
1463PerlIOUnix_tell(PerlIO *f)
1464{
1465 dTHX;
1466 Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1467 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
1468}
1469
1470IV
1471PerlIOUnix_close(PerlIO *f)
1472{
1473 dTHX;
1474 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1475 int code = 0;
1476 while (PerlLIO_close(fd) != 0)
1477 {
1478 if (errno != EINTR)
1479 {
1480 code = -1;
1481 break;
1482 }
847a5fae 1483 PERL_ASYNC_CHECK();
0e06870b 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),
1495 PERLIO_K_RAW,
1496 PerlIOUnix_fileno,
1497 PerlIOUnix_fdopen,
1498 PerlIOUnix_open,
1499 PerlIOUnix_reopen,
1500 PerlIOBase_pushed,
1501 PerlIOBase_noop_ok,
1502 PerlIOUnix_read,
1503 PerlIOBase_unread,
1504 PerlIOUnix_write,
1505 PerlIOUnix_seek,
1506 PerlIOUnix_tell,
1507 PerlIOUnix_close,
1508 PerlIOBase_noop_ok, /* flush */
1509 PerlIOBase_noop_fail, /* fill */
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{
1533 dTHX;
1534 return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1535}
1536
1537char *
1538PerlIOStdio_mode(const char *mode,char *tmode)
1539{
1540 char *ret = tmode;
1541 while (*mode)
1542 {
1543 *tmode++ = *mode++;
1544 }
1545 if (O_BINARY != O_TEXT)
1546 {
1547 *tmode++ = 'b';
1548 }
1549 *tmode = '\0';
1550 return ret;
1551}
1552
1553PerlIO *
1554PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
1555{
1556 dTHX;
1557 PerlIO *f = NULL;
1558 int init = 0;
1559 char tmode[8];
1560 if (*mode == 'I')
1561 {
1562 init = 1;
1563 mode++;
1564 }
1565 if (fd >= 0)
1566 {
1567 FILE *stdio = NULL;
1568 if (init)
1569 {
1570 switch(fd)
1571 {
1572 case 0:
1573 stdio = PerlSIO_stdin;
1574 break;
1575 case 1:
1576 stdio = PerlSIO_stdout;
1577 break;
1578 case 2:
1579 stdio = PerlSIO_stderr;
1580 break;
1581 }
1582 }
1583 else
1584 {
1585 stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode));
1586 }
1587 if (stdio)
1588 {
1589 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
1590 s->stdio = stdio;
1591 }
1592 }
1593 return f;
1594}
1595
1596#undef PerlIO_importFILE
1597PerlIO *
1598PerlIO_importFILE(FILE *stdio, int fl)
1599{
1600 dTHX;
1601 PerlIO *f = NULL;
1602 if (stdio)
1603 {
1604 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
1605 s->stdio = stdio;
1606 }
1607 return f;
1608}
1609
1610PerlIO *
1611PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
1612{
1613 dTHX;
1614 PerlIO *f = NULL;
1615 FILE *stdio = PerlSIO_fopen(path,mode);
1616 if (stdio)
1617 {
1618 char tmode[8];
1619 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
1620 (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
1621 PerlIOStdio);
1622 s->stdio = stdio;
1623 }
1624 return f;
1625}
1626
1627int
1628PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1629{
1630 dTHX;
1631 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1632 char tmode[8];
1633 FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio);
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{
1643 dTHX;
1644 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1645 SSize_t got = 0;
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 */
1652 int ch = PerlSIO_fgetc(s);
1653 if (ch != EOF)
1654 {
1655 *buf = ch;
1656 got = 1;
1657 }
1658 }
1659 else
1660 got = PerlSIO_fread(vbuf,1,count,s);
1661 return got;
1662}
1663
1664SSize_t
1665PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1666{
1667 dTHX;
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;
1674 if (PerlSIO_ungetc(ch,s) != ch)
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{
1685 dTHX;
1686 return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1687}
1688
1689IV
1690PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1691{
1692 dTHX;
1693 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1694 return PerlSIO_fseek(stdio,offset,whence);
1695}
1696
1697Off_t
1698PerlIOStdio_tell(PerlIO *f)
1699{
1700 dTHX;
1701 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1702 return PerlSIO_ftell(stdio);
1703}
1704
1705IV
1706PerlIOStdio_close(PerlIO *f)
1707{
1708 dTHX;
1709#ifdef HAS_SOCKET
1710 int optval, optlen = sizeof(int);
1711#endif
1712 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1713 return(
1714#ifdef HAS_SOCKET
1715 (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
1716 PerlSIO_fclose(stdio) :
1717 close(PerlIO_fileno(f))
1718#else
1719 PerlSIO_fclose(stdio)
1720#endif
1721 );
1722
1723}
1724
1725IV
1726PerlIOStdio_flush(PerlIO *f)
1727{
1728 dTHX;
1729 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1730 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1731 {
1732 return PerlSIO_fflush(stdio);
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;
1744 if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1745 errno = err;
1746#endif
1747 }
1748 return 0;
1749}
1750
1751IV
1752PerlIOStdio_fill(PerlIO *f)
1753{
1754 dTHX;
1755 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1756 int c;
1757 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1758 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1759 {
1760 if (PerlSIO_fflush(stdio) != 0)
1761 return EOF;
1762 }
1763 c = PerlSIO_fgetc(stdio);
1764 if (c == EOF || PerlSIO_ungetc(c,stdio) != c)
1765 return EOF;
1766 return 0;
1767}
1768
1769IV
1770PerlIOStdio_eof(PerlIO *f)
1771{
1772 dTHX;
1773 return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1774}
1775
1776IV
1777PerlIOStdio_error(PerlIO *f)
1778{
1779 dTHX;
1780 return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1781}
1782
1783void
1784PerlIOStdio_clearerr(PerlIO *f)
1785{
1786 dTHX;
1787 PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1788}
1789
1790void
1791PerlIOStdio_setlinebuf(PerlIO *f)
1792{
1793 dTHX;
1794#ifdef HAS_SETLINEBUF
1795 PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1796#else
1797 PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1798#endif
1799}
1800
1801#ifdef FILE_base
1802STDCHAR *
1803PerlIOStdio_get_base(PerlIO *f)
1804{
1805 dTHX;
1806 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1807 return PerlSIO_get_base(stdio);
1808}
1809
1810Size_t
1811PerlIOStdio_get_bufsiz(PerlIO *f)
1812{
1813 dTHX;
1814 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1815 return PerlSIO_get_bufsiz(stdio);
1816}
1817#endif
1818
1819#ifdef USE_STDIO_PTR
1820STDCHAR *
1821PerlIOStdio_get_ptr(PerlIO *f)
1822{
1823 dTHX;
1824 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1825 return PerlSIO_get_ptr(stdio);
1826}
1827
1828SSize_t
1829PerlIOStdio_get_cnt(PerlIO *f)
1830{
1831 dTHX;
1832 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1833 return PerlSIO_get_cnt(stdio);
1834}
1835
1836void
1837PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1838{
1839 dTHX;
1840 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1841 if (ptr != NULL)
1842 {
1843#ifdef STDIO_PTR_LVALUE
1844 PerlSIO_set_ptr(stdio,ptr);
1845#ifdef STDIO_PTR_LVAL_SETS_CNT
1846 if (PerlSIO_get_cnt(stdio) != (cnt))
1847 {
1848 dTHX;
1849 assert(PerlSIO_get_cnt(stdio) == (cnt));
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 */
1857 PerlProc_abort();
1858#endif /* STDIO_PTR_LVALUE */
1859 }
1860/* Now (or only) set cnt */
1861#ifdef STDIO_CNT_LVALUE
1862 PerlSIO_set_cnt(stdio,cnt);
1863#else /* STDIO_CNT_LVALUE */
1864#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1865 PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt));
1866#else /* STDIO_PTR_LVAL_SETS_CNT */
1867 PerlProc_abort();
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),
1877 PERLIO_K_BUFFERED,
1878 PerlIOStdio_fileno,
1879 PerlIOStdio_fdopen,
1880 PerlIOStdio_open,
1881 PerlIOStdio_reopen,
1882 PerlIOBase_pushed,
1883 PerlIOBase_noop_ok,
1884 PerlIOStdio_read,
1885 PerlIOStdio_unread,
1886 PerlIOStdio_write,
1887 PerlIOStdio_seek,
1888 PerlIOStdio_tell,
1889 PerlIOStdio_close,
1890 PerlIOStdio_flush,
1891 PerlIOStdio_fill,
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,
1906#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
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{
1922 FILE *stdio;
1923 PerlIO_flush(f);
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;
1931}
1932
1933#undef PerlIO_findFILE
1934FILE *
1935PerlIO_findFILE(PerlIO *f)
1936{
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 }
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
1959IV
1960PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
1961{
1962 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1963 b->posn = PerlIO_tell(PerlIONext(f));
1964 return PerlIOBase_pushed(f,mode,arg,len);
1965}
1966
1967PerlIO *
1968PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
1969{
1970 dTHX;
1971 PerlIO_funcs *tab = PerlIO_default_btm();
1972 int init = 0;
1973 PerlIO *f;
1974 if (*mode == 'I')
1975 {
1976 init = 1;
1977 mode++;
1978 }
1979#if O_BINARY != O_TEXT
1980 /* do something about failing setmode()? --jhi */
1981 PerlLIO_setmode(fd, O_BINARY);
1982#endif
1983 f = (*tab->Fdopen)(tab,fd,mode);
1984 if (f)
1985 {
1986 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
1987 if (init && fd == 2)
1988 {
1989 /* Initial stderr is unbuffered */
1990 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
1991 }
1992#if 0
1993 PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n",
1994 self->name,f,fd,mode,PerlIOBase(f)->flags);
1995#endif
1996 }
1997 return f;
1998}
1999
2000PerlIO *
2001PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
2002{
2003 PerlIO_funcs *tab = PerlIO_default_btm();
2004 PerlIO *f = (*tab->Open)(tab,path,mode);
2005 if (f)
2006 {
2007 PerlIO_push(f,self,mode,Nullch,0);
2008 }
2009 return f;
2010}
2011
2012int
2013PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
2014{
2015 PerlIO *next = PerlIONext(f);
2016 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
2017 if (code = 0)
2018 code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
2019 return code;
2020}
2021
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)
2027{
2028 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2029 int code = 0;
2030 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2031 {
2032 /* write() the buffer */
2033 STDCHAR *buf = b->buf;
2034 STDCHAR *p = buf;
2035 int count;
2036 PerlIO *n = PerlIONext(f);
2037 while (p < b->ptr)
2038 {
2039 count = PerlIO_write(n,p,b->ptr - p);
2040 if (count > 0)
2041 {
2042 p += count;
2043 }
2044 else if (count < 0 || PerlIO_error(n))
2045 {
2046 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2047 code = -1;
2048 break;
2049 }
2050 }
2051 b->posn += (p - buf);
2052 }
2053 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2054 {
2055 STDCHAR *buf = PerlIO_get_base(f);
2056 /* Note position change */
2057 b->posn += (b->ptr - buf);
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 }
2066 }
2067 b->ptr = b->end = b->buf;
2068 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2069 /* FIXME: Is this right for read case ? */
2070 if (PerlIO_flush(PerlIONext(f)) != 0)
2071 code = -1;
2072 return code;
2073}
2074
2075IV
2076PerlIOBuf_fill(PerlIO *f)
2077{
2078 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2079 PerlIO *n = PerlIONext(f);
2080 SSize_t avail;
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 */
2089 if (PerlIO_flush(f) != 0)
2090 return -1;
2091
2092 if (!b->buf)
2093 PerlIO_get_base(f); /* allocate via vtable */
2094
2095 b->ptr = b->end = b->buf;
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 }
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 }
2137 b->end = b->buf+avail;
2138 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2139 return 0;
2140}
2141
2142SSize_t
2143PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
2144{
2145 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2146 STDCHAR *buf = (STDCHAR *) vbuf;
2147 if (f)
2148 {
2149 if (!b->ptr)
2150 PerlIO_get_base(f);
2151 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
2152 return 0;
2153 while (count > 0)
2154 {
2155 SSize_t avail = PerlIO_get_cnt(f);
2156 SSize_t take = (count < avail) ? count : avail;
2157 if (take > 0)
2158 {
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;
2164 }
2165 if (count > 0 && avail <= 0)
2166 {
2167 if (PerlIO_fill(f) != 0)
2168 break;
2169 }
2170 }
2171 return (buf - (STDCHAR *) vbuf);
2172 }
2173 return 0;
2174}
2175
2176SSize_t
2177PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
2178{
2179 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2180 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2181 SSize_t unread = 0;
2182 SSize_t avail;
2183 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2184 PerlIO_flush(f);
2185 if (!b->buf)
2186 PerlIO_get_base(f);
2187 if (b->buf)
2188 {
2189 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2190 {
2191 avail = (b->ptr - b->buf);
2192 }
2193 else
2194 {
2195 avail = b->bufsiz;
2196 b->end = b->buf + avail;
2197 b->ptr = b->end;
2198 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2199 b->posn -= b->bufsiz;
2200 }
2201 if (avail > (SSize_t) count)
2202 avail = count;
2203 if (avail > 0)
2204 {
2205 b->ptr -= avail;
2206 buf -= avail;
2207 if (buf != b->ptr)
2208 {
2209 Copy(buf,b->ptr,avail,STDCHAR);
2210 }
2211 count -= avail;
2212 unread += avail;
2213 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2214 }
2215 }
2216 return unread;
2217}
2218
2219SSize_t
2220PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
2221{
2222 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2223 const STDCHAR *buf = (const STDCHAR *) vbuf;
2224 Size_t written = 0;
2225 if (!b->buf)
2226 PerlIO_get_base(f);
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 {
2255 Copy(buf,b->ptr,avail,STDCHAR);
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 }
2265 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2266 PerlIO_flush(f);
2267 return written;
2268}
2269
2270IV
2271PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
2272{
2273 IV code;
2274 if ((code = PerlIO_flush(f)) == 0)
2275 {
2276 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
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{
2300 dTHX;
2301 IV code = PerlIOBase_close(f);
2302 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2303 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
2304 {
2305 PerlMemShared_free(b->buf);
2306 }
2307 b->buf = NULL;
2308 b->ptr = b->end = b->buf;
2309 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2310 return code;
2311}
2312
2313void
2314PerlIOBuf_setlinebuf(PerlIO *f)
2315{
2316 if (f)
2317 {
2318 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
2319 }
2320}
2321
2322STDCHAR *
2323PerlIOBuf_get_ptr(PerlIO *f)
2324{
2325 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2326 if (!b->buf)
2327 PerlIO_get_base(f);
2328 return b->ptr;
2329}
2330
2331SSize_t
2332PerlIOBuf_get_cnt(PerlIO *f)
2333{
2334 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2335 if (!b->buf)
2336 PerlIO_get_base(f);
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)
2347 {
2348 dTHX;
2349 if (!b->bufsiz)
2350 b->bufsiz = 4096;
2351 b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR));
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 }
2360 return b->buf;
2361}
2362
2363Size_t
2364PerlIOBuf_bufsiz(PerlIO *f)
2365{
2366 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2367 if (!b->buf)
2368 PerlIO_get_base(f);
2369 return (b->end - b->buf);
2370}
2371
2372void
2373PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2374{
2375 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2376 if (!b->buf)
2377 PerlIO_get_base(f);
2378 b->ptr = ptr;
2379 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
2380 {
2381 dTHX;
2382 assert(PerlIO_get_cnt(f) == cnt);
2383 assert(b->ptr >= b->buf);
2384 }
2385 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2386}
2387
2388PerlIO_funcs PerlIO_perlio = {
2389 "perlio",
2390 sizeof(PerlIOBuf),
2391 PERLIO_K_BUFFERED,
2392 PerlIOBase_fileno,
2393 PerlIOBuf_fdopen,
2394 PerlIOBuf_open,
2395 PerlIOBuf_reopen,
2396 PerlIOBuf_pushed,
2397 PerlIOBase_noop_ok,
2398 PerlIOBuf_read,
2399 PerlIOBuf_unread,
2400 PerlIOBuf_write,
2401 PerlIOBuf_seek,
2402 PerlIOBuf_tell,
2403 PerlIOBuf_close,
2404 PerlIOBuf_flush,
2405 PerlIOBuf_fill,
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
2417/*--------------------------------------------------------------------------------------*/
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 {
2451 dTHX;
2452 PerlMemShared_free(b->buf);
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
2473PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
2474{
2475 IV code = PerlIOBase_pushed(f,mode,arg,len);
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 */
2481 l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) |
2482 (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8));
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/*--------------------------------------------------------------------------------------*/
2533/* crlf - translation
2534 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
2535 to hand back a line at a time and keeping a record of which nl we "lied" about.
2536 On write translate "\n" to CR,LF
2537 */
2538
2539typedef struct
2540{
2541 PerlIOBuf base; /* PerlIOBuf stuff */
2542 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
2543} PerlIOCrlf;
2544
2545IV
2546PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
2547{
2548 IV code;
2549 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
2550 code = PerlIOBuf_pushed(f,mode,arg,len);
2551#if 0
2552 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
2553 f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
2554 PerlIOBase(f)->flags);
2555#endif
2556 return code;
2557}
2558
2559
2560SSize_t
2561PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2562{
2563 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2564 if (c->nl)
2565 {
2566 *(c->nl) = 0xd;
2567 c->nl = NULL;
2568 }
2569 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2570 return PerlIOBuf_unread(f,vbuf,count);
2571 else
2572 {
2573 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
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)
2581 {
2582 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2583 {
2584 b->end = b->ptr = b->buf + b->bufsiz;
2585 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2586 b->posn -= b->bufsiz;
2587 }
2588 while (count > 0 && b->ptr > b->buf)
2589 {
2590 int ch = *--buf;
2591 if (ch == '\n')
2592 {
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 }
2605 }
2606 else
2607 {
2608 *--(b->ptr) = ch;
2609 unread++;
2610 count--;
2611 }
2612 }
2613 }
2614 return unread;
2615 }
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);
2627 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl)
2628 {
2629 STDCHAR *nl = b->ptr;
2630 scan:
2631 while (nl < b->end && *nl != 0xd)
2632 nl++;
2633 if (nl < b->end && *nl == 0xd)
2634 {
2635 test:
2636 if (nl+1 < b->end)
2637 {
2638 if (nl[1] == 0xa)
2639 {
2640 *nl = '\n';
2641 c->nl = nl;
2642 }
2643 else
2644 {
2645 /* Not CR,LF but just CR */
2646 nl++;
2647 goto scan;
2648 }
2649 }
2650 else
2651 {
2652 /* Blast - found CR as last char in buffer */
2653 if (b->ptr < nl)
2654 {
2655 /* They may not care, defer work as long as possible */
2656 return (nl - b->ptr);
2657 }
2658 else
2659 {
2660 int code;
2661 dTHX;
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 */
2671 if (code == 0)
2672 goto test; /* fill() call worked */
2673 /* CR at EOF - just fall through */
2674 }
2675 }
2676 }
2677 }
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);
2688 IV flags = PerlIOBase(f)->flags;
2689 if (!b->buf)
2690 PerlIO_get_base(f);
2691 if (!ptr)
2692 {
2693 if (c->nl)
2694 ptr = c->nl+1;
2695 else
2696 {
2697 ptr = b->end;
2698 if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd)
2699 ptr--;
2700 }
2701 ptr -= cnt;
2702 }
2703 else
2704 {
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;
2712 if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd)
2713 chk--;
2714 }
2715 chk -= cnt;
2716
2717 if (ptr != chk)
2718 {
2719 dTHX;
2720 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d",
2721 ptr, chk, flags, c->nl, b->end, cnt);
2722 }
2723 }
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++;
2732 }
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{
2741 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
2742 return PerlIOBuf_write(f,vbuf,count);
2743 else
2744 {
2745 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
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)
2753 {
2754 STDCHAR *eptr = b->buf+b->bufsiz;
2755 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2756 while (buf < ebuf && b->ptr < eptr)
2757 {
2758 if (*buf == '\n')
2759 {
2760 if ((b->ptr + 2) > eptr)
2761 {
2762 /* Not room for both */
2763 PerlIO_flush(f);
2764 break;
2765 }
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;
2787 }
2788 }
2789 }
2790 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
2791 PerlIO_flush(f);
2792 return (buf - (STDCHAR *) vbuf);
2793 }
2794}
2795
2796IV
2797PerlIOCrlf_flush(PerlIO *f)
2798{
2799 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2800 if (c->nl)
2801 {
2802 *(c->nl) = 0xd;
2803 c->nl = NULL;
2804 }
2805 return PerlIOBuf_flush(f);
2806}
2807
2808PerlIO_funcs PerlIO_crlf = {
2809 "crlf",
2810 sizeof(PerlIOCrlf),
2811 PERLIO_K_BUFFERED|PERLIO_K_CANCRLF,
2812 PerlIOBase_fileno,
2813 PerlIOBuf_fdopen,
2814 PerlIOBuf_open,
2815 PerlIOBuf_reopen,
2816 PerlIOCrlf_pushed,
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' */
2821 PerlIOBuf_seek,
2822 PerlIOBuf_tell,
2823 PerlIOBuf_close,
2824 PerlIOCrlf_flush,
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,
2833 PerlIOCrlf_get_cnt,
2834 PerlIOCrlf_set_ptrcnt,
2835};
2836
2837#ifdef HAS_MMAP
2838/*--------------------------------------------------------------------------------------*/
2839/* mmap as "buffer" layer */
2840
2841typedef struct
2842{
2843 PerlIOBuf base; /* PerlIOBuf stuff */
2844 Mmap_t mptr; /* Mapped address */
2845 Size_t len; /* mapped length */
2846 STDCHAR *bbuf; /* malloced buffer if map fails */
2847} PerlIOMmap;
2848
2849static size_t page_size = 0;
2850
2851IV
2852PerlIOMmap_map(PerlIO *f)
760ac839 2853{
961e40ee 2854 dTHX;
0e06870b 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 {
2872 Off_t posn;
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);
2881# endif
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);
2889 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
2890 }
2891 else
2892 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
2893 }
2894 }
760ac839 2895#else
0e06870b 2896# ifdef HAS_GETPAGESIZE
2897 page_size = getpagesize();
2898# else
2899# if defined(I_SYS_PARAM) && defined(PAGESIZE)
2900 page_size = PAGESIZE; /* compiletime, bad */
2901# endif
2902# endif
760ac839 2903#endif
0e06870b 2904 if ((IV)page_size <= 0)
2905 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
2906 }
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;
2914 m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
2915 if (m->mptr && m->mptr != (Mmap_t) -1)
2916 {
2917#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
2918 madvise(m->mptr, len, MADV_SEQUENTIAL);
2919#endif
2920#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
2921 madvise(m->mptr, len, MADV_WILLNEED);
760ac839 2922#endif
0e06870b 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;
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;
760ac839 2944}
2945
0e06870b 2946IV
2947PerlIOMmap_unmap(PerlIO *f)
760ac839 2948{
0e06870b 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 {
2956 code = munmap(m->mptr, m->len);
2957 b->buf = NULL;
2958 m->len = 0;
2959 m->mptr = NULL;
2960 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2961 code = -1;
2962 }
2963 b->ptr = b->end = b->buf;
2964 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2965 }
2966 return code;
760ac839 2967}
2968
0e06870b 2969STDCHAR *
2970PerlIOMmap_get_base(PerlIO *f)
760ac839 2971{
0e06870b 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);
760ac839 2998}
2999
0e06870b 3000SSize_t
3001PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 3002{
0e06870b 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 {
3015 /* Loose the unwritable mapped buffer */
3016 PerlIO_flush(f);
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 }
3025 }
3026return PerlIOBuf_unread(f,vbuf,count);
760ac839 3027}
3028
0e06870b 3029SSize_t
3030PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 3031{
0e06870b 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);
760ac839 3052}
3053
0e06870b 3054IV
3055PerlIOMmap_flush(PerlIO *f)
760ac839 3056{
0e06870b 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 }
3077 return code;
760ac839 3078}
3079
0e06870b 3080IV
3081PerlIOMmap_fill(PerlIO *f)
760ac839 3082{
0e06870b 3083 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
3084 IV code = PerlIO_flush(f);
3085 if (code == 0 && !b->buf)
3086 {
3087 code = PerlIOMmap_map(f);
3088 }
3089 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
3090 {
3091 code = PerlIOBuf_fill(f);
3092 }
3093 return code;
760ac839 3094}
3095
0e06870b 3096IV
3097PerlIOMmap_close(PerlIO *f)
760ac839 3098{
0e06870b 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;
3110 return code;
760ac839 3111}
3112
0e06870b 3113
3114PerlIO_funcs PerlIO_mmap = {
3115 "mmap",
3116 sizeof(PerlIOMmap),
3117 PERLIO_K_BUFFERED,
3118 PerlIOBase_fileno,
3119 PerlIOBuf_fdopen,
3120 PerlIOBuf_open,
3121 PerlIOBuf_reopen,
3122 PerlIOBuf_pushed,
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
3145void
3146PerlIO_init(void)
760ac839 3147{
0e06870b 3148 if (!_perlio)
3149 {
3150#ifndef WIN32
3151 atexit(&PerlIO_cleanup);
3152#endif
3153 }
760ac839 3154}
3155
847a5fae 3156
3157
0e06870b 3158#undef PerlIO_stdin
3159PerlIO *
3160PerlIO_stdin(void)
8c86a920 3161{
0e06870b 3162 if (!_perlio)
3163 PerlIO_stdstreams();
3164 return &_perlio[1];
8c86a920 3165}
760ac839 3166
0e06870b 3167#undef PerlIO_stdout
3168PerlIO *
3169PerlIO_stdout(void)
760ac839 3170{
0e06870b 3171 if (!_perlio)
3172 PerlIO_stdstreams();
3173 return &_perlio[2];
760ac839 3174}
3175
0e06870b 3176#undef PerlIO_stderr
3177PerlIO *
3178PerlIO_stderr(void)
760ac839 3179{
0e06870b 3180 if (!_perlio)
3181 PerlIO_stdstreams();
3182 return &_perlio[3];
760ac839 3183}
3184
0e06870b 3185/*--------------------------------------------------------------------------------------*/
3186
8c86a920 3187#undef PerlIO_getname
3188char *
a20bf0c3 3189PerlIO_getname(PerlIO *f, char *buf)
8c86a920 3190{
961e40ee 3191 dTHX;
cea2e8a9 3192 Perl_croak(aTHX_ "Don't know how to get file name");
c64afb19 3193 return NULL;
760ac839 3194}
3195
760ac839 3196
0e06870b 3197/*--------------------------------------------------------------------------------------*/
3198/* Functions which can be called on any kind of PerlIO implemented
3199 in terms of above
3200*/
760ac839 3201
0e06870b 3202#undef PerlIO_getc
3203int
3204PerlIO_getc(PerlIO *f)
760ac839 3205{
0e06870b 3206 STDCHAR buf[1];
3207 SSize_t count = PerlIO_read(f,buf,1);
3208 if (count == 1)
3209 {
3210 return (unsigned char) buf[0];
3211 }
3212 return EOF;
760ac839 3213}
3214
0e06870b 3215#undef PerlIO_ungetc
3216int
3217PerlIO_ungetc(PerlIO *f, int ch)
760ac839 3218{
0e06870b 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 3226}
3227
3228#undef PerlIO_putc
0e06870b 3229int
c78749f2 3230PerlIO_putc(PerlIO *f, int ch)
760ac839 3231{
0e06870b 3232 STDCHAR buf = ch;
3233 return PerlIO_write(f,&buf,1);
760ac839 3234}
3235
0e06870b 3236#undef PerlIO_puts
3237int
3238PerlIO_puts(PerlIO *f, const char *s)
760ac839 3239{
0e06870b 3240 STRLEN len = strlen(s);
3241 return PerlIO_write(f,s,len);
760ac839 3242}
3243
0e06870b 3244#undef PerlIO_rewind
3245void
3246PerlIO_rewind(PerlIO *f)
760ac839 3247{
0e06870b 3248 PerlIO_seek(f,(Off_t)0,SEEK_SET);
3249 PerlIO_clearerr(f);
760ac839 3250}
3251
3252#undef PerlIO_vprintf
760ac839 3253int
0e06870b 3254PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
760ac839 3255{
0e06870b 3256 dTHX;
3257 SV *sv = newSVpvn("",0);
3258 char *s;
3259 STRLEN len;
3260#ifdef NEED_VA_COPY
3261 va_list apc;
3262 Perl_va_copy(ap, apc);
3263 sv_vcatpvf(sv, fmt, &apc);
dad16317 3264#else
0e06870b 3265 sv_vcatpvf(sv, fmt, &ap);
dad16317 3266#endif
0e06870b 3267 s = SvPV(sv,len);
3268 return PerlIO_write(f,s,len);
760ac839 3269}
3270
3271#undef PerlIO_printf
0e06870b 3272int
760ac839 3273PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839 3274{
3275 va_list ap;
3276 int result;
760ac839 3277 va_start(ap,fmt);
0e06870b 3278 result = PerlIO_vprintf(f,fmt,ap);
760ac839 3279 va_end(ap);
3280 return result;
3281}
3282
3283#undef PerlIO_stdoutf
0e06870b 3284int
760ac839 3285PerlIO_stdoutf(const char *fmt,...)
760ac839 3286{
3287 va_list ap;
3288 int result;
760ac839 3289 va_start(ap,fmt);
760ac839 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{
0e06870b 3299 /* I have no idea how portable mkstemp() is ... */
3300#if defined(WIN32) || !defined(HAVE_MKSTEMP)
3301 dTHX;
3302 PerlIO *f = NULL;
3303 FILE *stdio = PerlSIO_tmpfile();
3304 if (stdio)
3305 {
3306 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
3307 s->stdio = stdio;
3308 }
760ac839 3309 return f;
0e06870b 3310#else
3311 dTHX;
3312 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
3313 int fd = mkstemp(SvPVX(sv));
3314 PerlIO *f = NULL;
3315 if (fd >= 0)
3316 {
3317 f = PerlIO_fdopen(fd,"w+");
3318 if (f)
3319 {
3320 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
3321 }
3322 PerlLIO_unlink(SvPVX(sv));
3323 SvREFCNT_dec(sv);
3324 }
760ac839 3325 return f;
0e06870b 3326#endif
760ac839 3327}
3328
0e06870b 3329#undef HAS_FSETPOS
3330#undef HAS_FGETPOS
760ac839 3331
3332#endif /* USE_SFIO */
3333#endif /* PERLIO_IS_STDIO */
3334
0e06870b 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 3340#ifndef HAS_FSETPOS
3341#undef PerlIO_setpos
3342int
0e06870b 3343PerlIO_setpos(PerlIO *f, SV *pos)
760ac839 3344{
0e06870b 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 3357#undef PerlIO_setpos
3358int
0e06870b 3359PerlIO_setpos(PerlIO *f, SV *pos)
c411622e 3360{
0e06870b 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)
0e06870b 3369 return fsetpos64(f, fpos);
d9b3e12d 3370#else
0e06870b 3371 return fsetpos(f, fpos);
d9b3e12d 3372#endif
0e06870b 3373 }
3374 }
3375 errno = EINVAL;
3376 return -1;
c411622e 3377}
3378#endif
760ac839 3379
3380#ifndef HAS_FGETPOS
3381#undef PerlIO_getpos
3382int
0e06870b 3383PerlIO_getpos(PerlIO *f, SV *pos)
760ac839 3384{
0e06870b 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 3391#undef PerlIO_getpos
3392int
0e06870b 3393PerlIO_getpos(PerlIO *f, SV *pos)
c411622e 3394{
0e06870b 3395 dTHX;
3396 Fpos_t fpos;
3397 int code;
2d4389e4 3398#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
0e06870b 3399 code = fgetpos64(f, &fpos);
d9b3e12d 3400#else
0e06870b 3401 code = fgetpos(f, &fpos);
d9b3e12d 3402#endif
0e06870b 3403 sv_setpvn(pos,(char *)&fpos,sizeof(fpos));
3404 return code;
c411622e 3405}
3406#endif
760ac839 3407
3408#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
3409
3410int
c78749f2 3411vprintf(char *pat, char *args)
662a7e3f 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 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
0e06870b 3427int
8ac85365 3428PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839 3429{
3430 int val = vsprintf(s, fmt, ap);
3431 if (n >= 0)
3432 {
8c86a920 3433 if (strlen(s) >= (STRLEN)n)
760ac839 3434 {
146174a9 3435 dTHX;
0e06870b 3436 (void)PerlIO_puts(Perl_error_log,
3437 "panic: sprintf overflow - memory corrupted!\n");
146174a9 3438 my_exit(1);
760ac839 3439 }
3440 }
3441 return val;
3442}
3443#endif
3444
3445#ifndef PerlIO_sprintf
0e06870b 3446int
760ac839 3447PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839 3448{
3449 va_list ap;
3450 int result;
760ac839 3451 va_start(ap,fmt);
760ac839 3452 result = PerlIO_vsprintf(s, n, fmt, ap);
3453 va_end(ap);
3454 return result;
3455}
3456#endif
3457
c5be433b 3458
Unnamed repository; edit this file to name it for gitweb.