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