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