This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Added a mmap layer as a "subclass" of perlio.
[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
0f4eea8f 23 * which are not #defined in iperlsys.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
32e30700
GS
31#if !defined(PERL_IMPLICIT_SYS)
32
6f9d8c32 33#ifdef PERLIO_IS_STDIO
760ac839
LW
34
35void
8ac85365 36PerlIO_init(void)
760ac839 37{
6f9d8c32 38 /* Does nothing (yet) except force this file to be included
760ac839 39 in perl binary. That allows this file to force inclusion
6f9d8c32
NIS
40 of other functions that may be required by loadable
41 extensions e.g. for FileHandle::tmpfile
760ac839
LW
42 */
43}
44
33dcbb9a
PP
45#undef PerlIO_tmpfile
46PerlIO *
8ac85365 47PerlIO_tmpfile(void)
33dcbb9a
PP
48{
49 return tmpfile();
50}
51
760ac839
LW
52#else /* PERLIO_IS_STDIO */
53
54#ifdef USE_SFIO
55
56#undef HAS_FSETPOS
57#undef HAS_FGETPOS
58
6f9d8c32 59/* This section is just to make sure these functions
760ac839
LW
60 get pulled in from libsfio.a
61*/
62
63#undef PerlIO_tmpfile
64PerlIO *
c78749f2 65PerlIO_tmpfile(void)
760ac839
LW
66{
67 return sftmp(0);
68}
69
70void
c78749f2 71PerlIO_init(void)
760ac839 72{
6f9d8c32
NIS
73 /* Force this file to be included in perl binary. Which allows
74 * this file to force inclusion of other functions that may be
75 * required by loadable extensions e.g. for FileHandle::tmpfile
760ac839
LW
76 */
77
78 /* Hack
79 * sfio does its own 'autoflush' on stdout in common cases.
6f9d8c32 80 * Flush results in a lot of lseek()s to regular files and
760ac839
LW
81 * lot of small writes to pipes.
82 */
83 sfset(sfstdout,SF_SHARE,0);
84}
85
17c3b450 86#else /* USE_SFIO */
6f9d8c32 87/*======================================================================================*/
6f9d8c32 88/* Implement all the PerlIO interface ourselves.
9e353e3b 89 */
760ac839 90
b1ef6e3b 91/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
02f66e2f
NIS
92#ifdef I_UNISTD
93#include <unistd.h>
94#endif
06da4f11
NIS
95#ifdef HAS_MMAP
96#include <sys/mman.h>
97#endif
98
f3862f8b 99#include "XSUB.h"
02f66e2f 100
6f9d8c32
NIS
101#undef printf
102void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2)));
103
6f9d8c32
NIS
104void
105PerlIO_debug(char *fmt,...)
106{
107 static int dbg = 0;
108 if (!dbg)
109 {
110 char *s = getenv("PERLIO_DEBUG");
111 if (s && *s)
112 dbg = open(s,O_WRONLY|O_CREAT|O_APPEND,0666);
113 else
114 dbg = -1;
115 }
116 if (dbg > 0)
117 {
118 dTHX;
119 va_list ap;
120 SV *sv = newSVpvn("",0);
121 char *s;
122 STRLEN len;
123 va_start(ap,fmt);
05d1247b
NIS
124 s = CopFILE(PL_curcop);
125 if (!s)
126 s = "(none)";
127 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
c7fc522f
NIS
128 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
129
6f9d8c32
NIS
130 s = SvPV(sv,len);
131 write(dbg,s,len);
132 va_end(ap);
133 SvREFCNT_dec(sv);
134 }
135}
136
9e353e3b
NIS
137/*--------------------------------------------------------------------------------------*/
138
06da4f11
NIS
139typedef struct _PerlIO_funcs PerlIO_funcs;
140struct _PerlIO_funcs
9e353e3b
NIS
141{
142 char * name;
143 Size_t size;
144 IV kind;
145 IV (*Fileno)(PerlIO *f);
06da4f11
NIS
146 PerlIO * (*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
147 PerlIO * (*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
9e353e3b 148 int (*Reopen)(const char *path, const char *mode, PerlIO *f);
06da4f11
NIS
149 IV (*Pushed)(PerlIO *f,const char *mode);
150 IV (*Popped)(PerlIO *f);
9e353e3b
NIS
151 /* Unix-like functions - cf sfio line disciplines */
152 SSize_t (*Read)(PerlIO *f, void *vbuf, Size_t count);
153 SSize_t (*Unread)(PerlIO *f, const void *vbuf, Size_t count);
154 SSize_t (*Write)(PerlIO *f, const void *vbuf, Size_t count);
155 IV (*Seek)(PerlIO *f, Off_t offset, int whence);
156 Off_t (*Tell)(PerlIO *f);
157 IV (*Close)(PerlIO *f);
158 /* Stdio-like buffered IO functions */
159 IV (*Flush)(PerlIO *f);
06da4f11 160 IV (*Fill)(PerlIO *f);
9e353e3b
NIS
161 IV (*Eof)(PerlIO *f);
162 IV (*Error)(PerlIO *f);
163 void (*Clearerr)(PerlIO *f);
164 void (*Setlinebuf)(PerlIO *f);
165 /* Perl's snooping functions */
166 STDCHAR * (*Get_base)(PerlIO *f);
167 Size_t (*Get_bufsiz)(PerlIO *f);
168 STDCHAR * (*Get_ptr)(PerlIO *f);
169 SSize_t (*Get_cnt)(PerlIO *f);
170 void (*Set_ptrcnt)(PerlIO *f,STDCHAR *ptr,SSize_t cnt);
06da4f11 171};
6f9d8c32
NIS
172
173struct _PerlIO
174{
9e353e3b
NIS
175 PerlIOl * next; /* Lower layer */
176 PerlIO_funcs * tab; /* Functions for this layer */
177 IV flags; /* Various flags for state */
6f9d8c32
NIS
178};
179
9e353e3b
NIS
180/*--------------------------------------------------------------------------------------*/
181
182/* Flag values */
f3862f8b
NIS
183#define PERLIO_F_EOF 0x00010000
184#define PERLIO_F_CANWRITE 0x00020000
185#define PERLIO_F_CANREAD 0x00040000
186#define PERLIO_F_ERROR 0x00080000
187#define PERLIO_F_TRUNCATE 0x00100000
188#define PERLIO_F_APPEND 0x00200000
189#define PERLIO_F_BINARY 0x00400000
190#define PERLIO_F_UTF8 0x00800000
191#define PERLIO_F_LINEBUF 0x01000000
192#define PERLIO_F_WRBUF 0x02000000
193#define PERLIO_F_RDBUF 0x04000000
194#define PERLIO_F_TEMP 0x08000000
195#define PERLIO_F_OPEN 0x10000000
9e353e3b
NIS
196
197#define PerlIOBase(f) (*(f))
198#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
199#define PerlIONext(f) (&(PerlIOBase(f)->next))
200
201/*--------------------------------------------------------------------------------------*/
202/* Inner level routines */
203
b1ef6e3b 204/* Table of pointers to the PerlIO structs (malloc'ed) */
05d1247b
NIS
205PerlIO *_perlio = NULL;
206#define PERLIO_TABLE_SIZE 64
6f9d8c32 207
760ac839 208PerlIO *
6f9d8c32
NIS
209PerlIO_allocate(void)
210{
f3862f8b 211 /* Find a free slot in the table, allocating new table as necessary */
05d1247b 212 PerlIO **last = &_perlio;
6f9d8c32 213 PerlIO *f;
05d1247b 214 while ((f = *last))
6f9d8c32 215 {
05d1247b
NIS
216 int i;
217 last = (PerlIO **)(f);
218 for (i=1; i < PERLIO_TABLE_SIZE; i++)
6f9d8c32 219 {
05d1247b 220 if (!*++f)
6f9d8c32 221 {
6f9d8c32
NIS
222 return f;
223 }
6f9d8c32 224 }
6f9d8c32 225 }
05d1247b
NIS
226 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
227 if (!f)
228 return NULL;
229 *last = f;
230 return f+1;
231}
232
233void
234PerlIO_cleantable(PerlIO **tablep)
235{
236 PerlIO *table = *tablep;
237 if (table)
238 {
239 int i;
240 PerlIO_cleantable((PerlIO **) &(table[0]));
241 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
242 {
243 PerlIO *f = table+i;
244 if (*f)
245 PerlIO_close(f);
246 }
247 Safefree(table);
248 *tablep = NULL;
249 }
250}
251
252void
253PerlIO_cleanup(void)
254{
255 PerlIO_cleantable(&_perlio);
6f9d8c32
NIS
256}
257
9e353e3b
NIS
258void
259PerlIO_pop(PerlIO *f)
760ac839 260{
9e353e3b
NIS
261 PerlIOl *l = *f;
262 if (l)
6f9d8c32 263 {
06da4f11 264 (*l->tab->Popped)(f);
9e353e3b
NIS
265 *f = l->next;
266 Safefree(l);
6f9d8c32 267 }
6f9d8c32
NIS
268}
269
270#undef PerlIO_close
271int
272PerlIO_close(PerlIO *f)
273{
9e353e3b
NIS
274 int code = (*PerlIOBase(f)->tab->Close)(f);
275 while (*f)
6f9d8c32 276 {
9e353e3b 277 PerlIO_pop(f);
6f9d8c32
NIS
278 }
279 return code;
280}
281
9e353e3b
NIS
282
283/*--------------------------------------------------------------------------------------*/
284/* Given the abstraction above the public API functions */
285
286#undef PerlIO_fileno
287int
288PerlIO_fileno(PerlIO *f)
289{
290 return (*PerlIOBase(f)->tab->Fileno)(f);
291}
292
f3862f8b 293
9e353e3b 294extern PerlIO_funcs PerlIO_unix;
9e353e3b 295extern PerlIO_funcs PerlIO_perlio;
f3862f8b 296extern PerlIO_funcs PerlIO_stdio;
06da4f11
NIS
297#ifdef HAS_MMAP
298extern PerlIO_funcs PerlIO_mmap;
299#endif
f3862f8b
NIS
300
301XS(XS_perlio_import)
302{
303 dXSARGS;
304 GV *gv = CvGV(cv);
305 char *s = GvNAME(gv);
306 STRLEN l = GvNAMELEN(gv);
307 PerlIO_debug("%.*s\n",(int) l,s);
308 XSRETURN_EMPTY;
309}
310
311XS(XS_perlio_unimport)
312{
313 dXSARGS;
314 GV *gv = CvGV(cv);
315 char *s = GvNAME(gv);
316 STRLEN l = GvNAMELEN(gv);
317 PerlIO_debug("%.*s\n",(int) l,s);
318 XSRETURN_EMPTY;
319}
320
321HV *PerlIO_layer_hv;
322AV *PerlIO_layer_av;
9e353e3b 323
f3862f8b
NIS
324SV *
325PerlIO_find_layer(char *name, STRLEN len)
326{
327 dTHX;
328 SV **svp;
329 SV *sv;
330 if (len <= 0)
331 len = strlen(name);
332 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
333 if (svp && (sv = *svp) && SvROK(sv))
334 return *svp;
335 return NULL;
336}
337
338void
339PerlIO_define_layer(PerlIO_funcs *tab)
340{
341 dTHX;
342 HV *stash = gv_stashpv("perlio::Layer", TRUE);
343 SV *sv = sv_bless(newRV_noinc(newSViv((IV) tab)),stash);
344 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
345}
346
347PerlIO_funcs *
348PerlIO_default_layer(I32 n)
349{
350 dTHX;
351 SV **svp;
352 SV *layer;
353 PerlIO_funcs *tab = &PerlIO_stdio;
354 int len;
355 if (!PerlIO_layer_hv)
356 {
357 char *s = getenv("PERLIO");
358 newXS("perlio::import",XS_perlio_import,__FILE__);
359 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
360 PerlIO_layer_hv = get_hv("perlio::layers",GV_ADD|GV_ADDMULTI);
361 PerlIO_layer_av = get_av("perlio::layers",GV_ADD|GV_ADDMULTI);
362 PerlIO_define_layer(&PerlIO_unix);
f3862f8b
NIS
363 PerlIO_define_layer(&PerlIO_perlio);
364 PerlIO_define_layer(&PerlIO_stdio);
06da4f11
NIS
365#ifdef HAS_MMAP
366 PerlIO_define_layer(&PerlIO_mmap);
367#endif
f3862f8b
NIS
368 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
369 if (s)
370 {
371 while (*s)
372 {
373 while (*s && isspace((unsigned char)*s))
374 s++;
375 if (*s)
376 {
377 char *e = s;
378 SV *layer;
379 while (*e && !isspace((unsigned char)*e))
380 e++;
381 layer = PerlIO_find_layer(s,e-s);
382 if (layer)
383 {
384 PerlIO_debug("Pushing %.*s\n",(e-s),s);
385 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
386 }
387 else
313ca112 388 Perl_warn(aTHX_ "Unknown layer %.*s",(e-s),s);
f3862f8b
NIS
389 s = e;
390 }
391 }
392 }
393 }
394 len = av_len(PerlIO_layer_av);
395 if (len < 1)
396 {
397 if (PerlIO_stdio.Set_ptrcnt)
398 {
399 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
400 }
401 else
402 {
403 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
404 }
405 len = av_len(PerlIO_layer_av);
406 }
407 if (n < 0)
408 n += len+1;
409 svp = av_fetch(PerlIO_layer_av,n,0);
410 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
411 {
412 tab = (PerlIO_funcs *) SvIV(layer);
413 }
414 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
415 return tab;
416}
417
418#define PerlIO_default_top() PerlIO_default_layer(-1)
419#define PerlIO_default_btm() PerlIO_default_layer(0)
420
421void
422PerlIO_stdstreams()
423{
424 if (!_perlio)
425 {
426 PerlIO_allocate();
427 PerlIO_fdopen(0,"Ir");
428 PerlIO_fdopen(1,"Iw");
429 PerlIO_fdopen(2,"Iw");
430 }
431}
9e353e3b
NIS
432
433#undef PerlIO_fdopen
434PerlIO *
435PerlIO_fdopen(int fd, const char *mode)
436{
437 PerlIO_funcs *tab = PerlIO_default_top();
f3862f8b
NIS
438 if (!_perlio)
439 PerlIO_stdstreams();
06da4f11 440 return (*tab->Fdopen)(tab,fd,mode);
9e353e3b
NIS
441}
442
6f9d8c32
NIS
443#undef PerlIO_open
444PerlIO *
445PerlIO_open(const char *path, const char *mode)
446{
9e353e3b 447 PerlIO_funcs *tab = PerlIO_default_top();
f3862f8b
NIS
448 if (!_perlio)
449 PerlIO_stdstreams();
06da4f11 450 return (*tab->Open)(tab,path,mode);
6f9d8c32
NIS
451}
452
9e353e3b 453IV
06da4f11 454PerlIOBase_pushed(PerlIO *f, const char *mode)
6f9d8c32 455{
9e353e3b
NIS
456 PerlIOl *l = PerlIOBase(f);
457 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
458 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
459 if (mode)
6f9d8c32 460 {
9e353e3b
NIS
461 switch (*mode++)
462 {
463 case 'r':
464 l->flags = PERLIO_F_CANREAD;
465 break;
466 case 'a':
467 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
468 break;
469 case 'w':
470 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
471 break;
472 default:
473 errno = EINVAL;
474 return -1;
475 }
476 while (*mode)
6f9d8c32 477 {
9e353e3b 478 switch (*mode++)
6f9d8c32 479 {
9e353e3b
NIS
480 case '+':
481 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
482 break;
483 case 'b':
484 l->flags |= PERLIO_F_BINARY;
485 break;
486 default:
487 errno = EINVAL;
488 return -1;
6f9d8c32
NIS
489 }
490 }
9e353e3b
NIS
491 }
492 else
493 {
494 if (l->next)
6f9d8c32 495 {
9e353e3b
NIS
496 l->flags |= l->next->flags &
497 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
498 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
6f9d8c32
NIS
499 }
500 }
9e353e3b 501 return 0;
6f9d8c32
NIS
502}
503
9e353e3b
NIS
504#undef PerlIO_reopen
505PerlIO *
506PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
6f9d8c32 507{
9e353e3b 508 if (f)
6f9d8c32 509 {
9e353e3b
NIS
510 PerlIO_flush(f);
511 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
512 {
06da4f11
NIS
513 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
514 return f;
9e353e3b
NIS
515 }
516 return NULL;
6f9d8c32 517 }
9e353e3b
NIS
518 else
519 return PerlIO_open(path,mode);
760ac839
LW
520}
521
9e353e3b
NIS
522#undef PerlIO_read
523SSize_t
524PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 525{
9e353e3b 526 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
760ac839
LW
527}
528
313ca112
NIS
529#undef PerlIO_unread
530SSize_t
531PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 532{
313ca112 533 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
760ac839
LW
534}
535
9e353e3b
NIS
536#undef PerlIO_write
537SSize_t
538PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 539{
9e353e3b 540 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
760ac839
LW
541}
542
9e353e3b 543#undef PerlIO_seek
6f9d8c32 544int
9e353e3b 545PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 546{
9e353e3b 547 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
760ac839
LW
548}
549
9e353e3b
NIS
550#undef PerlIO_tell
551Off_t
552PerlIO_tell(PerlIO *f)
760ac839 553{
9e353e3b 554 return (*PerlIOBase(f)->tab->Tell)(f);
760ac839
LW
555}
556
9e353e3b 557#undef PerlIO_flush
6f9d8c32 558int
9e353e3b 559PerlIO_flush(PerlIO *f)
760ac839 560{
6f9d8c32
NIS
561 if (f)
562 {
9e353e3b 563 return (*PerlIOBase(f)->tab->Flush)(f);
6f9d8c32 564 }
9e353e3b 565 else
6f9d8c32 566 {
05d1247b 567 PerlIO **table = &_perlio;
9e353e3b 568 int code = 0;
05d1247b 569 while ((f = *table))
6f9d8c32 570 {
05d1247b
NIS
571 int i;
572 table = (PerlIO **)(f++);
573 for (i=1; i < PERLIO_TABLE_SIZE; i++)
9e353e3b
NIS
574 {
575 if (*f && PerlIO_flush(f) != 0)
576 code = -1;
05d1247b 577 f++;
9e353e3b 578 }
6f9d8c32 579 }
9e353e3b 580 return code;
6f9d8c32 581 }
760ac839
LW
582}
583
06da4f11
NIS
584#undef PerlIO_fill
585int
586PerlIO_fill(PerlIO *f)
587{
588 return (*PerlIOBase(f)->tab->Fill)(f);
589}
590
f3862f8b
NIS
591#undef PerlIO_isutf8
592int
593PerlIO_isutf8(PerlIO *f)
594{
595 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
596}
597
9e353e3b 598#undef PerlIO_eof
6f9d8c32 599int
9e353e3b 600PerlIO_eof(PerlIO *f)
760ac839 601{
9e353e3b
NIS
602 return (*PerlIOBase(f)->tab->Eof)(f);
603}
604
605#undef PerlIO_error
606int
607PerlIO_error(PerlIO *f)
608{
609 return (*PerlIOBase(f)->tab->Error)(f);
610}
611
612#undef PerlIO_clearerr
613void
614PerlIO_clearerr(PerlIO *f)
615{
616 (*PerlIOBase(f)->tab->Clearerr)(f);
617}
618
619#undef PerlIO_setlinebuf
620void
621PerlIO_setlinebuf(PerlIO *f)
622{
623 (*PerlIOBase(f)->tab->Setlinebuf)(f);
624}
625
626#undef PerlIO_has_base
627int
628PerlIO_has_base(PerlIO *f)
629{
630 if (f && *f)
6f9d8c32 631 {
9e353e3b 632 return (PerlIOBase(f)->tab->Get_base != NULL);
6f9d8c32 633 }
9e353e3b 634 return 0;
760ac839
LW
635}
636
9e353e3b
NIS
637#undef PerlIO_fast_gets
638int
639PerlIO_fast_gets(PerlIO *f)
760ac839 640{
9e353e3b 641 if (f && *f)
6f9d8c32 642 {
c7fc522f
NIS
643 PerlIOl *l = PerlIOBase(f);
644 return (l->tab->Set_ptrcnt != NULL);
6f9d8c32 645 }
9e353e3b
NIS
646 return 0;
647}
648
649#undef PerlIO_has_cntptr
650int
651PerlIO_has_cntptr(PerlIO *f)
652{
653 if (f && *f)
654 {
655 PerlIO_funcs *tab = PerlIOBase(f)->tab;
656 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
657 }
658 return 0;
659}
660
661#undef PerlIO_canset_cnt
662int
663PerlIO_canset_cnt(PerlIO *f)
664{
665 if (f && *f)
666 {
c7fc522f
NIS
667 PerlIOl *l = PerlIOBase(f);
668 return (l->tab->Set_ptrcnt != NULL);
9e353e3b 669 }
c7fc522f 670 return 0;
760ac839
LW
671}
672
673#undef PerlIO_get_base
888911fc 674STDCHAR *
a20bf0c3 675PerlIO_get_base(PerlIO *f)
760ac839 676{
9e353e3b
NIS
677 return (*PerlIOBase(f)->tab->Get_base)(f);
678}
679
680#undef PerlIO_get_bufsiz
681int
682PerlIO_get_bufsiz(PerlIO *f)
683{
684 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
685}
686
687#undef PerlIO_get_ptr
688STDCHAR *
689PerlIO_get_ptr(PerlIO *f)
690{
691 return (*PerlIOBase(f)->tab->Get_ptr)(f);
692}
693
694#undef PerlIO_get_cnt
05d1247b 695int
9e353e3b
NIS
696PerlIO_get_cnt(PerlIO *f)
697{
698 return (*PerlIOBase(f)->tab->Get_cnt)(f);
699}
700
701#undef PerlIO_set_cnt
702void
05d1247b 703PerlIO_set_cnt(PerlIO *f,int cnt)
9e353e3b 704{
f3862f8b 705 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
9e353e3b
NIS
706}
707
708#undef PerlIO_set_ptrcnt
709void
05d1247b 710PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
9e353e3b 711{
f3862f8b 712 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
9e353e3b
NIS
713}
714
715/*--------------------------------------------------------------------------------------*/
716/* "Methods" of the "base class" */
717
718IV
719PerlIOBase_fileno(PerlIO *f)
720{
721 return PerlIO_fileno(PerlIONext(f));
722}
723
724PerlIO *
725PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
726{
727 PerlIOl *l = NULL;
728 Newc('L',l,tab->size,char,PerlIOl);
729 if (l)
6f9d8c32 730 {
9e353e3b
NIS
731 Zero(l,tab->size,char);
732 l->next = *f;
733 l->tab = tab;
734 *f = l;
06da4f11
NIS
735 if ((*l->tab->Pushed)(f,mode) != 0)
736 {
737 PerlIO_pop(f);
738 return NULL;
739 }
6f9d8c32 740 }
9e353e3b 741 return f;
760ac839
LW
742}
743
9e353e3b
NIS
744SSize_t
745PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
746{
747 Off_t old = PerlIO_tell(f);
748 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
749 {
750 Off_t new = PerlIO_tell(f);
751 return old - new;
752 }
753 return 0;
754}
755
756IV
06da4f11 757PerlIOBase_noop_ok(PerlIO *f)
9e353e3b
NIS
758{
759 return 0;
760}
761
762IV
06da4f11
NIS
763PerlIOBase_noop_fail(PerlIO *f)
764{
765 return -1;
766}
767
768IV
9e353e3b
NIS
769PerlIOBase_close(PerlIO *f)
770{
771 IV code = 0;
772 if (PerlIO_flush(f) != 0)
773 code = -1;
774 if (PerlIO_close(PerlIONext(f)) != 0)
775 code = -1;
776 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
777 return code;
778}
779
780IV
781PerlIOBase_eof(PerlIO *f)
782{
783 if (f && *f)
784 {
785 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
786 }
787 return 1;
788}
789
790IV
791PerlIOBase_error(PerlIO *f)
792{
793 if (f && *f)
794 {
795 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
796 }
797 return 1;
798}
799
800void
801PerlIOBase_clearerr(PerlIO *f)
802{
803 if (f && *f)
804 {
805 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
806 }
807}
808
809void
810PerlIOBase_setlinebuf(PerlIO *f)
811{
812
813}
814
815
816
817/*--------------------------------------------------------------------------------------*/
818/* Bottom-most level for UNIX-like case */
819
820typedef struct
821{
822 struct _PerlIO base; /* The generic part */
823 int fd; /* UNIX like file descriptor */
824 int oflags; /* open/fcntl flags */
825} PerlIOUnix;
826
6f9d8c32 827int
9e353e3b 828PerlIOUnix_oflags(const char *mode)
760ac839 829{
9e353e3b
NIS
830 int oflags = -1;
831 switch(*mode)
832 {
833 case 'r':
834 oflags = O_RDONLY;
835 if (*++mode == '+')
836 {
837 oflags = O_RDWR;
838 mode++;
839 }
840 break;
841
842 case 'w':
843 oflags = O_CREAT|O_TRUNC;
844 if (*++mode == '+')
845 {
846 oflags |= O_RDWR;
847 mode++;
848 }
849 else
850 oflags |= O_WRONLY;
851 break;
852
853 case 'a':
854 oflags = O_CREAT|O_APPEND;
855 if (*++mode == '+')
856 {
857 oflags |= O_RDWR;
858 mode++;
859 }
860 else
861 oflags |= O_WRONLY;
862 break;
863 }
864 if (*mode || oflags == -1)
6f9d8c32 865 {
9e353e3b
NIS
866 errno = EINVAL;
867 oflags = -1;
6f9d8c32 868 }
9e353e3b
NIS
869 return oflags;
870}
871
872IV
873PerlIOUnix_fileno(PerlIO *f)
874{
875 return PerlIOSelf(f,PerlIOUnix)->fd;
876}
877
878PerlIO *
06da4f11 879PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
880{
881 PerlIO *f = NULL;
c7fc522f
NIS
882 if (*mode == 'I')
883 mode++;
9e353e3b
NIS
884 if (fd >= 0)
885 {
886 int oflags = PerlIOUnix_oflags(mode);
887 if (oflags != -1)
888 {
06da4f11 889 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
9e353e3b
NIS
890 s->fd = fd;
891 s->oflags = oflags;
892 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
893 }
894 }
895 return f;
896}
897
898PerlIO *
06da4f11 899PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
900{
901 PerlIO *f = NULL;
902 int oflags = PerlIOUnix_oflags(mode);
903 if (oflags != -1)
904 {
905 int fd = open(path,oflags,0666);
906 if (fd >= 0)
907 {
06da4f11 908 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
9e353e3b
NIS
909 s->fd = fd;
910 s->oflags = oflags;
911 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
912 }
913 }
914 return f;
760ac839
LW
915}
916
760ac839 917int
9e353e3b 918PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
760ac839 919{
9e353e3b
NIS
920 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
921 int oflags = PerlIOUnix_oflags(mode);
922 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
923 (*PerlIOBase(f)->tab->Close)(f);
924 if (oflags != -1)
925 {
926 int fd = open(path,oflags,0666);
927 if (fd >= 0)
928 {
929 s->fd = fd;
930 s->oflags = oflags;
931 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
932 return 0;
933 }
934 }
935 return -1;
936}
937
938SSize_t
939PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
940{
941 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
8f24bd79
NIS
942 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
943 return 0;
9e353e3b
NIS
944 while (1)
945 {
946 SSize_t len = read(fd,vbuf,count);
947 if (len >= 0 || errno != EINTR)
06da4f11
NIS
948 {
949 if (len < 0)
950 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
951 else if (len == 0 && count != 0)
952 PerlIOBase(f)->flags |= PERLIO_F_EOF;
953 return len;
954 }
9e353e3b
NIS
955 }
956}
957
958SSize_t
959PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
960{
961 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
962 while (1)
963 {
964 SSize_t len = write(fd,vbuf,count);
965 if (len >= 0 || errno != EINTR)
06da4f11
NIS
966 {
967 if (len < 0)
968 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
969 return len;
970 }
9e353e3b
NIS
971 }
972}
973
974IV
975PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
976{
977 Off_t new = lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
06da4f11 978 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
9e353e3b
NIS
979 return (new == (Off_t) -1) ? -1 : 0;
980}
981
982Off_t
983PerlIOUnix_tell(PerlIO *f)
984{
985 return lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
986}
987
988IV
989PerlIOUnix_close(PerlIO *f)
990{
991 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
992 int code = 0;
993 while (close(fd) != 0)
994 {
995 if (errno != EINTR)
996 {
997 code = -1;
998 break;
999 }
1000 }
1001 if (code == 0)
1002 {
1003 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1004 }
1005 return code;
1006}
1007
1008PerlIO_funcs PerlIO_unix = {
1009 "unix",
1010 sizeof(PerlIOUnix),
1011 0,
1012 PerlIOUnix_fileno,
1013 PerlIOUnix_fdopen,
1014 PerlIOUnix_open,
1015 PerlIOUnix_reopen,
06da4f11
NIS
1016 PerlIOBase_pushed,
1017 PerlIOBase_noop_ok,
9e353e3b
NIS
1018 PerlIOUnix_read,
1019 PerlIOBase_unread,
1020 PerlIOUnix_write,
1021 PerlIOUnix_seek,
1022 PerlIOUnix_tell,
1023 PerlIOUnix_close,
06da4f11
NIS
1024 PerlIOBase_noop_ok,
1025 PerlIOBase_noop_fail,
9e353e3b
NIS
1026 PerlIOBase_eof,
1027 PerlIOBase_error,
1028 PerlIOBase_clearerr,
1029 PerlIOBase_setlinebuf,
1030 NULL, /* get_base */
1031 NULL, /* get_bufsiz */
1032 NULL, /* get_ptr */
1033 NULL, /* get_cnt */
1034 NULL, /* set_ptrcnt */
1035};
1036
1037/*--------------------------------------------------------------------------------------*/
1038/* stdio as a layer */
1039
1040typedef struct
1041{
1042 struct _PerlIO base;
1043 FILE * stdio; /* The stream */
1044} PerlIOStdio;
1045
1046IV
1047PerlIOStdio_fileno(PerlIO *f)
1048{
1049 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1050}
1051
1052
1053PerlIO *
06da4f11 1054PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
1055{
1056 PerlIO *f = NULL;
c7fc522f
NIS
1057 int init = 0;
1058 if (*mode == 'I')
1059 {
1060 init = 1;
1061 mode++;
1062 }
9e353e3b
NIS
1063 if (fd >= 0)
1064 {
c7fc522f
NIS
1065 FILE *stdio = NULL;
1066 if (init)
1067 {
1068 switch(fd)
1069 {
1070 case 0:
1071 stdio = stdin;
1072 break;
1073 case 1:
1074 stdio = stdout;
1075 break;
1076 case 2:
1077 stdio = stderr;
1078 break;
1079 }
1080 }
1081 else
1082 stdio = fdopen(fd,mode);
9e353e3b
NIS
1083 if (stdio)
1084 {
06da4f11 1085 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1086 s->stdio = stdio;
1087 }
1088 }
1089 return f;
1090}
1091
1092#undef PerlIO_importFILE
1093PerlIO *
1094PerlIO_importFILE(FILE *stdio, int fl)
1095{
1096 PerlIO *f = NULL;
1097 if (stdio)
1098 {
1099 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1100 s->stdio = stdio;
1101 }
1102 return f;
1103}
1104
1105PerlIO *
06da4f11 1106PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
1107{
1108 PerlIO *f = NULL;
1109 FILE *stdio = fopen(path,mode);
1110 if (stdio)
1111 {
06da4f11 1112 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1113 s->stdio = stdio;
1114 }
1115 return f;
760ac839
LW
1116}
1117
6f9d8c32 1118int
9e353e3b
NIS
1119PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1120{
1121 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1122 FILE *stdio = freopen(path,mode,s->stdio);
1123 if (!s->stdio)
1124 return -1;
1125 s->stdio = stdio;
1126 return 0;
1127}
1128
1129SSize_t
1130PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1131{
1132 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 1133 SSize_t got = 0;
9e353e3b
NIS
1134 if (count == 1)
1135 {
1136 STDCHAR *buf = (STDCHAR *) vbuf;
1137 /* Perl is expecting PerlIO_getc() to fill the buffer
1138 * Linux's stdio does not do that for fread()
1139 */
1140 int ch = fgetc(s);
1141 if (ch != EOF)
1142 {
1143 *buf = ch;
c7fc522f 1144 got = 1;
9e353e3b 1145 }
9e353e3b 1146 }
c7fc522f
NIS
1147 else
1148 got = fread(vbuf,1,count,s);
1149 return got;
9e353e3b
NIS
1150}
1151
1152SSize_t
1153PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1154{
1155 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1156 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1157 SSize_t unread = 0;
1158 while (count > 0)
1159 {
1160 int ch = *buf-- & 0xff;
1161 if (ungetc(ch,s) != ch)
1162 break;
1163 unread++;
1164 count--;
1165 }
1166 return unread;
1167}
1168
1169SSize_t
1170PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1171{
1172 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1173}
1174
1175IV
1176PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1177{
c7fc522f
NIS
1178 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1179 return fseek(stdio,offset,whence);
9e353e3b
NIS
1180}
1181
1182Off_t
1183PerlIOStdio_tell(PerlIO *f)
1184{
c7fc522f
NIS
1185 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1186 return ftell(stdio);
9e353e3b
NIS
1187}
1188
1189IV
1190PerlIOStdio_close(PerlIO *f)
1191{
1192 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1193}
1194
1195IV
1196PerlIOStdio_flush(PerlIO *f)
1197{
1198 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1199 return fflush(stdio);
1200}
1201
1202IV
06da4f11
NIS
1203PerlIOStdio_fill(PerlIO *f)
1204{
1205 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1206 int c;
1207 if (fflush(stdio) != 0)
1208 return EOF;
1209 c = fgetc(stdio);
1210 if (c == EOF || ungetc(c,stdio) != c)
1211 return EOF;
1212 return 0;
1213}
1214
1215IV
9e353e3b
NIS
1216PerlIOStdio_eof(PerlIO *f)
1217{
1218 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1219}
1220
1221IV
1222PerlIOStdio_error(PerlIO *f)
1223{
1224 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1225}
1226
1227void
1228PerlIOStdio_clearerr(PerlIO *f)
1229{
1230 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1231}
1232
1233void
1234PerlIOStdio_setlinebuf(PerlIO *f)
1235{
1236#ifdef HAS_SETLINEBUF
1237 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1238#else
1239 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1240#endif
1241}
1242
1243#ifdef FILE_base
1244STDCHAR *
1245PerlIOStdio_get_base(PerlIO *f)
1246{
1247 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1248 return FILE_base(stdio);
1249}
1250
1251Size_t
1252PerlIOStdio_get_bufsiz(PerlIO *f)
1253{
1254 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1255 return FILE_bufsiz(stdio);
1256}
1257#endif
1258
1259#ifdef USE_STDIO_PTR
1260STDCHAR *
1261PerlIOStdio_get_ptr(PerlIO *f)
1262{
1263 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1264 return FILE_ptr(stdio);
1265}
1266
1267SSize_t
1268PerlIOStdio_get_cnt(PerlIO *f)
1269{
1270 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1271 return FILE_cnt(stdio);
1272}
1273
1274void
1275PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1276{
1277 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1278 if (ptr != NULL)
1279 {
1280#ifdef STDIO_PTR_LVALUE
1281 FILE_ptr(stdio) = ptr;
1282#ifdef STDIO_PTR_LVAL_SETS_CNT
1283 if (FILE_cnt(stdio) != (cnt))
1284 {
1285 dTHX;
1286 assert(FILE_cnt(stdio) == (cnt));
1287 }
1288#endif
1289#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1290 /* Setting ptr _does_ change cnt - we are done */
1291 return;
1292#endif
1293#else /* STDIO_PTR_LVALUE */
1294 abort();
1295#endif /* STDIO_PTR_LVALUE */
1296 }
1297/* Now (or only) set cnt */
1298#ifdef STDIO_CNT_LVALUE
1299 FILE_cnt(stdio) = cnt;
1300#else /* STDIO_CNT_LVALUE */
1301#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1302 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1303#else /* STDIO_PTR_LVAL_SETS_CNT */
1304 abort();
1305#endif /* STDIO_PTR_LVAL_SETS_CNT */
1306#endif /* STDIO_CNT_LVALUE */
1307}
1308
1309#endif
1310
1311PerlIO_funcs PerlIO_stdio = {
1312 "stdio",
1313 sizeof(PerlIOStdio),
1314 0,
1315 PerlIOStdio_fileno,
1316 PerlIOStdio_fdopen,
1317 PerlIOStdio_open,
1318 PerlIOStdio_reopen,
06da4f11
NIS
1319 PerlIOBase_pushed,
1320 PerlIOBase_noop_ok,
9e353e3b
NIS
1321 PerlIOStdio_read,
1322 PerlIOStdio_unread,
1323 PerlIOStdio_write,
1324 PerlIOStdio_seek,
1325 PerlIOStdio_tell,
1326 PerlIOStdio_close,
1327 PerlIOStdio_flush,
06da4f11 1328 PerlIOStdio_fill,
9e353e3b
NIS
1329 PerlIOStdio_eof,
1330 PerlIOStdio_error,
1331 PerlIOStdio_clearerr,
1332 PerlIOStdio_setlinebuf,
1333#ifdef FILE_base
1334 PerlIOStdio_get_base,
1335 PerlIOStdio_get_bufsiz,
1336#else
1337 NULL,
1338 NULL,
1339#endif
1340#ifdef USE_STDIO_PTR
1341 PerlIOStdio_get_ptr,
1342 PerlIOStdio_get_cnt,
1343#if (defined(STDIO_PTR_LVALUE) && \
1344 (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
1345 PerlIOStdio_set_ptrcnt
1346#else /* STDIO_PTR_LVALUE */
1347 NULL
1348#endif /* STDIO_PTR_LVALUE */
1349#else /* USE_STDIO_PTR */
1350 NULL,
1351 NULL,
1352 NULL
1353#endif /* USE_STDIO_PTR */
1354};
1355
1356#undef PerlIO_exportFILE
1357FILE *
1358PerlIO_exportFILE(PerlIO *f, int fl)
1359{
1360 PerlIO_flush(f);
1361 /* Should really push stdio discipline when we have them */
1362 return fdopen(PerlIO_fileno(f),"r+");
1363}
1364
1365#undef PerlIO_findFILE
1366FILE *
1367PerlIO_findFILE(PerlIO *f)
1368{
1369 return PerlIO_exportFILE(f,0);
1370}
1371
1372#undef PerlIO_releaseFILE
1373void
1374PerlIO_releaseFILE(PerlIO *p, FILE *f)
1375{
1376}
1377
1378/*--------------------------------------------------------------------------------------*/
1379/* perlio buffer layer */
1380
1381typedef struct
760ac839 1382{
9e353e3b
NIS
1383 struct _PerlIO base;
1384 Off_t posn; /* Offset of buf into the file */
1385 STDCHAR * buf; /* Start of buffer */
1386 STDCHAR * end; /* End of valid part of buffer */
1387 STDCHAR * ptr; /* Current position in buffer */
1388 Size_t bufsiz; /* Size of buffer */
1389 IV oneword; /* Emergency buffer */
1390} PerlIOBuf;
1391
1392
1393PerlIO *
06da4f11 1394PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
9e353e3b
NIS
1395{
1396 PerlIO_funcs *tab = PerlIO_default_btm();
c7fc522f
NIS
1397 int init = 0;
1398 PerlIO *f;
1399 if (*mode == 'I')
1400 {
1401 init = 1;
1402 mode++;
1403 }
06da4f11 1404 f = (*tab->Fdopen)(tab,fd,mode);
6f9d8c32
NIS
1405 if (f)
1406 {
c7fc522f
NIS
1407 /* Initial stderr is unbuffered */
1408 if (!init || fd != 2)
1409 {
06da4f11 1410 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
c7fc522f
NIS
1411 b->posn = PerlIO_tell(PerlIONext(f));
1412 }
6f9d8c32 1413 }
9e353e3b 1414 return f;
760ac839
LW
1415}
1416
9e353e3b 1417PerlIO *
06da4f11 1418PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
8c86a920 1419{
9e353e3b 1420 PerlIO_funcs *tab = PerlIO_default_btm();
06da4f11 1421 PerlIO *f = (*tab->Open)(tab,path,mode);
9e353e3b
NIS
1422 if (f)
1423 {
06da4f11 1424 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
9e353e3b
NIS
1425 b->posn = 0;
1426 }
1427 return f;
1428}
1429
1430int
1431PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1432{
1433 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1434}
1435
9e353e3b
NIS
1436/* This "flush" is akin to sfio's sync in that it handles files in either
1437 read or write state
1438*/
1439IV
1440PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1441{
9e353e3b
NIS
1442 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1443 int code = 0;
1444 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1445 {
1446 /* write() the buffer */
1447 STDCHAR *p = b->buf;
1448 int count;
1449 while (p < b->ptr)
1450 {
1451 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1452 if (count > 0)
1453 {
1454 p += count;
1455 }
1456 else if (count < 0)
1457 {
1458 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1459 code = -1;
1460 break;
1461 }
1462 }
1463 b->posn += (p - b->buf);
1464 }
1465 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1466 {
9e353e3b
NIS
1467 /* Note position change */
1468 b->posn += (b->ptr - b->buf);
1469 if (b->ptr < b->end)
1470 {
1471 /* We did not consume all of it */
1472 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1473 {
1474 b->posn = PerlIO_tell(PerlIONext(f));
1475 }
1476 }
6f9d8c32 1477 }
9e353e3b
NIS
1478 b->ptr = b->end = b->buf;
1479 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1480 if (PerlIO_flush(PerlIONext(f)) != 0)
1481 code = -1;
1482 return code;
6f9d8c32
NIS
1483}
1484
06da4f11
NIS
1485IV
1486PerlIOBuf_fill(PerlIO *f)
1487{
1488 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1489 SSize_t avail;
1490 if (PerlIO_flush(f) != 0)
1491 return -1;
1492 b->ptr = b->end = b->buf;
1493 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1494 if (avail <= 0)
1495 {
1496 if (avail == 0)
1497 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1498 else
1499 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1500 return -1;
1501 }
1502 b->end = b->buf+avail;
1503 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1504 return 0;
1505}
1506
6f9d8c32 1507SSize_t
9e353e3b 1508PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1509{
9e353e3b 1510 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
6f9d8c32
NIS
1511 STDCHAR *buf = (STDCHAR *) vbuf;
1512 if (f)
1513 {
1514 Size_t got = 0;
9e353e3b 1515 if (!b->ptr)
06da4f11 1516 PerlIO_get_base(f);
9e353e3b 1517 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1518 return 0;
6f9d8c32
NIS
1519 while (count > 0)
1520 {
9e353e3b 1521 SSize_t avail = (b->end - b->ptr);
6f9d8c32
NIS
1522 if ((SSize_t) count < avail)
1523 avail = count;
1524 if (avail > 0)
1525 {
9e353e3b 1526 Copy(b->ptr,buf,avail,char);
6f9d8c32 1527 got += avail;
9e353e3b 1528 b->ptr += avail;
6f9d8c32
NIS
1529 count -= avail;
1530 buf += avail;
1531 }
9e353e3b 1532 if (count && (b->ptr >= b->end))
6f9d8c32 1533 {
06da4f11
NIS
1534 if (PerlIO_fill(f) != 0)
1535 break;
6f9d8c32
NIS
1536 }
1537 }
1538 return got;
1539 }
1540 return 0;
1541}
1542
9e353e3b
NIS
1543SSize_t
1544PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1545{
9e353e3b
NIS
1546 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1547 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1548 SSize_t unread = 0;
1549 SSize_t avail;
9e353e3b
NIS
1550 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1551 PerlIO_flush(f);
06da4f11
NIS
1552 if (!b->buf)
1553 PerlIO_get_base(f);
9e353e3b
NIS
1554 if (b->buf)
1555 {
1556 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1557 {
1558 avail = (b->ptr - b->buf);
1559 if (avail > (SSize_t) count)
1560 avail = count;
1561 b->ptr -= avail;
1562 }
1563 else
1564 {
1565 avail = b->bufsiz;
1566 if (avail > (SSize_t) count)
1567 avail = count;
1568 b->end = b->ptr + avail;
1569 }
1570 if (avail > 0)
1571 {
1572 buf -= avail;
1573 if (buf != b->ptr)
1574 {
1575 Copy(buf,b->ptr,avail,char);
1576 }
1577 count -= avail;
1578 unread += avail;
1579 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1580 }
1581 }
1582 return unread;
760ac839
LW
1583}
1584
9e353e3b
NIS
1585SSize_t
1586PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1587{
9e353e3b
NIS
1588 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1589 const STDCHAR *buf = (const STDCHAR *) vbuf;
1590 Size_t written = 0;
1591 if (!b->buf)
06da4f11 1592 PerlIO_get_base(f);
9e353e3b
NIS
1593 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1594 return 0;
1595 while (count > 0)
1596 {
1597 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1598 if ((SSize_t) count < avail)
1599 avail = count;
1600 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1601 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1602 {
1603 while (avail > 0)
1604 {
1605 int ch = *buf++;
1606 *(b->ptr)++ = ch;
1607 count--;
1608 avail--;
1609 written++;
1610 if (ch == '\n')
1611 {
1612 PerlIO_flush(f);
1613 break;
1614 }
1615 }
1616 }
1617 else
1618 {
1619 if (avail)
1620 {
1621 Copy(buf,b->ptr,avail,char);
1622 count -= avail;
1623 buf += avail;
1624 written += avail;
1625 b->ptr += avail;
1626 }
1627 }
1628 if (b->ptr >= (b->buf + b->bufsiz))
1629 PerlIO_flush(f);
1630 }
1631 return written;
1632}
1633
1634IV
1635PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1636{
1637 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
06da4f11 1638 int code = PerlIO_flush(f);
9e353e3b
NIS
1639 if (code == 0)
1640 {
1641 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1642 code = PerlIO_seek(PerlIONext(f),offset,whence);
1643 if (code == 0)
1644 {
1645 b->posn = PerlIO_tell(PerlIONext(f));
06da4f11 1646 PerlIO_debug(__FUNCTION__ " f=%p posn=%ld\n",f,(long) b->posn);
9e353e3b
NIS
1647 }
1648 }
06da4f11
NIS
1649 if (code)
1650 PerlIO_debug(__FUNCTION__ " f=%p code%d\n",f,code);
9e353e3b
NIS
1651 return code;
1652}
1653
1654Off_t
1655PerlIOBuf_tell(PerlIO *f)
1656{
1657 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1658 Off_t posn = b->posn;
1659 if (b->buf)
1660 posn += (b->ptr - b->buf);
06da4f11 1661 PerlIO_debug(__FUNCTION__ " f=%p posn=%ld\n",f,(long) posn);
9e353e3b
NIS
1662 return posn;
1663}
1664
1665IV
1666PerlIOBuf_close(PerlIO *f)
1667{
1668 IV code = PerlIOBase_close(f);
1669 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1670 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 1671 {
9e353e3b 1672 Safefree(b->buf);
6f9d8c32 1673 }
9e353e3b
NIS
1674 b->buf = NULL;
1675 b->ptr = b->end = b->buf;
1676 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1677 return code;
760ac839
LW
1678}
1679
760ac839 1680void
9e353e3b 1681PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 1682{
6f9d8c32
NIS
1683 if (f)
1684 {
9e353e3b 1685 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 1686 }
760ac839
LW
1687}
1688
760ac839 1689void
9e353e3b 1690PerlIOBuf_set_cnt(PerlIO *f, int cnt)
760ac839 1691{
9e353e3b
NIS
1692 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1693 dTHX;
1694 if (!b->buf)
06da4f11 1695 PerlIO_get_base(f);
9e353e3b
NIS
1696 b->ptr = b->end - cnt;
1697 assert(b->ptr >= b->buf);
1698}
1699
1700STDCHAR *
1701PerlIOBuf_get_ptr(PerlIO *f)
1702{
1703 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1704 if (!b->buf)
06da4f11 1705 PerlIO_get_base(f);
9e353e3b
NIS
1706 return b->ptr;
1707}
1708
05d1247b 1709SSize_t
9e353e3b
NIS
1710PerlIOBuf_get_cnt(PerlIO *f)
1711{
1712 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1713 if (!b->buf)
06da4f11 1714 PerlIO_get_base(f);
9e353e3b
NIS
1715 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1716 return (b->end - b->ptr);
1717 return 0;
1718}
1719
1720STDCHAR *
1721PerlIOBuf_get_base(PerlIO *f)
1722{
1723 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1724 if (!b->buf)
06da4f11
NIS
1725 {
1726 if (!b->bufsiz)
1727 b->bufsiz = 4096;
1728 New('B',b->buf,b->bufsiz,STDCHAR);
1729 if (!b->buf)
1730 {
1731 b->buf = (STDCHAR *)&b->oneword;
1732 b->bufsiz = sizeof(b->oneword);
1733 }
1734 b->ptr = b->buf;
1735 b->end = b->ptr;
1736 }
9e353e3b
NIS
1737 return b->buf;
1738}
1739
1740Size_t
1741PerlIOBuf_bufsiz(PerlIO *f)
1742{
1743 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1744 if (!b->buf)
06da4f11 1745 PerlIO_get_base(f);
9e353e3b
NIS
1746 return (b->end - b->buf);
1747}
1748
1749void
05d1247b 1750PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS
1751{
1752 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1753 if (!b->buf)
06da4f11 1754 PerlIO_get_base(f);
9e353e3b
NIS
1755 b->ptr = ptr;
1756 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 1757 {
9e353e3b
NIS
1758 dTHX;
1759 assert(PerlIO_get_cnt(f) == cnt);
1760 assert(b->ptr >= b->buf);
6f9d8c32 1761 }
9e353e3b 1762 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
1763}
1764
9e353e3b
NIS
1765PerlIO_funcs PerlIO_perlio = {
1766 "perlio",
1767 sizeof(PerlIOBuf),
1768 0,
1769 PerlIOBase_fileno,
1770 PerlIOBuf_fdopen,
1771 PerlIOBuf_open,
1772 PerlIOBase_reopen,
06da4f11
NIS
1773 PerlIOBase_pushed,
1774 PerlIOBase_noop_ok,
9e353e3b
NIS
1775 PerlIOBuf_read,
1776 PerlIOBuf_unread,
1777 PerlIOBuf_write,
1778 PerlIOBuf_seek,
1779 PerlIOBuf_tell,
1780 PerlIOBuf_close,
1781 PerlIOBuf_flush,
06da4f11 1782 PerlIOBuf_fill,
9e353e3b
NIS
1783 PerlIOBase_eof,
1784 PerlIOBase_error,
1785 PerlIOBase_clearerr,
1786 PerlIOBuf_setlinebuf,
1787 PerlIOBuf_get_base,
1788 PerlIOBuf_bufsiz,
1789 PerlIOBuf_get_ptr,
1790 PerlIOBuf_get_cnt,
1791 PerlIOBuf_set_ptrcnt,
1792};
1793
06da4f11
NIS
1794#ifdef HAS_MMAP
1795/*--------------------------------------------------------------------------------------*/
1796/* mmap as "buffer" layer */
1797
1798typedef struct
1799{
1800 PerlIOBuf base; /* PerlIOBuf stuff */
1801 Size_t len; /* mapped length */
1802 STDCHAR *bbuf; /* malloced buffer if map fails */
1803} PerlIOMmap;
1804
1805IV
1806PerlIOMmap_map(PerlIO *f)
1807{
1808 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1809 PerlIOBuf *b = &m->base;
1810 IV flags = PerlIOBase(f)->flags;
1811 IV code = 0;
1812 if (m->len)
1813 abort();
1814 if (flags & PERLIO_F_CANREAD)
1815 {
1816 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1817 int fd = PerlIO_fileno(f);
1818 struct stat st;
1819 code = fstat(fd,&st);
1820 if (code == 0 && S_ISREG(st.st_mode))
1821 {
1822 SSize_t len = st.st_size - b->posn;
1823 if (len > 0)
1824 {
1825 b->buf = (STDCHAR *) mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, b->posn);
1826 PerlIO_debug(__FUNCTION__ " f=%p b=%p for %ld @ %ld\n",
1827 f, b->buf, (long) len, (long) b->posn);
1828 if (b->buf && b->buf != (STDCHAR *) -1)
1829 {
1830#if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
1831 madvise(b->buf, len, MADV_SEQUENTIAL);
1832#endif
1833 PerlIOBase(f)->flags = flags | PERLIO_F_RDBUF;
1834 b->end = b->buf+len;
1835 b->ptr = b->buf;
1836 m->len = len;
1837 }
1838 else
1839 {
1840 b->buf = NULL;
1841 }
1842 }
1843 else
1844 {
1845 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1846 b->buf = NULL;
1847 b->ptr = b->end = b->ptr;
1848 code = -1;
1849 }
1850 }
1851 }
1852 return code;
1853}
1854
1855IV
1856PerlIOMmap_unmap(PerlIO *f)
1857{
1858 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1859 PerlIOBuf *b = &m->base;
1860 IV code = 0;
1861 if (m->len)
1862 {
1863 if (b->buf)
1864 {
1865 code = munmap((Mmap_t) b->buf, m->len);
1866 b->buf = NULL;
1867 m->len = 0;
1868 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1869 code = -1;
1870 PerlIO_debug(__FUNCTION__ " f=%p b=%p c=%ld posn=%ld\n",
1871 f,b->buf,(long)m->len,(long) b->posn);
1872 }
1873 b->ptr = b->end = b->buf;
1874 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1875 }
1876 return code;
1877}
1878
1879STDCHAR *
1880PerlIOMmap_get_base(PerlIO *f)
1881{
1882 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1883 PerlIOBuf *b = &m->base;
1884 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1885 {
1886 /* Already have a readbuffer in progress */
1887 return b->buf;
1888 }
1889 if (b->buf)
1890 {
1891 /* We have a write buffer or flushed PerlIOBuf read buffer */
1892 m->bbuf = b->buf; /* save it in case we need it again */
1893 b->buf = NULL; /* Clear to trigger below */
1894 }
1895 if (!b->buf)
1896 {
1897 PerlIOMmap_map(f); /* Try and map it */
1898 if (!b->buf)
1899 {
1900 /* Map did not work - recover PerlIOBuf buffer if we have one */
1901 b->buf = m->bbuf;
1902 }
1903 }
1904 b->ptr = b->end = b->buf;
1905 if (b->buf)
1906 return b->buf;
1907 return PerlIOBuf_get_base(f);
1908}
1909
1910SSize_t
1911PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1912{
1913 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1914 PerlIOBuf *b = &m->base;
1915 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1916 PerlIO_flush(f);
1917 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1918 {
1919 b->ptr -= count;
1920 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1921 return count;
1922 }
1923 if (m->len)
1924 {
1925 PerlIO_debug(__FUNCTION__ " f=%p %d '%.*s'\n",f,count,count,(char *)vbuf);
1926 PerlIO_flush(f);
1927 }
1928 return PerlIOBuf_unread(f,vbuf,count);
1929}
1930
1931SSize_t
1932PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
1933{
1934 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1935 PerlIOBuf *b = &m->base;
1936 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
1937 {
1938 /* No, or wrong sort of, buffer */
1939 if (m->len)
1940 {
1941 if (PerlIOMmap_unmap(f) != 0)
1942 return 0;
1943 }
1944 /* If unmap took the "buffer" see if we have one from before */
1945 if (!b->buf && m->bbuf)
1946 b->buf = m->bbuf;
1947 if (!b->buf)
1948 {
1949 PerlIOBuf_get_base(f);
1950 m->bbuf = b->buf;
1951 }
1952 }
1953 return PerlIOBuf_write(f,vbuf,count);
1954}
1955
1956IV
1957PerlIOMmap_flush(PerlIO *f)
1958{
1959 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1960 PerlIOBuf *b = &m->base;
1961 IV code = PerlIOBuf_flush(f);
1962 /* Now we are "synced" at PerlIOBuf level */
1963 if (b->buf)
1964 {
1965 if (m->len)
1966 {
1967 /* Unmap the buffer */
1968 if (PerlIOMmap_unmap(f) != 0)
1969 code = -1;
1970 }
1971 else
1972 {
1973 /* We seem to have a PerlIOBuf buffer which was not mapped
1974 * remember it in case we need one later
1975 */
1976 m->bbuf = b->buf;
1977 }
1978 }
1979 if (code)
1980 PerlIO_debug(__FUNCTION__ " f=%p %d\n",f,code);
1981 return code;
1982}
1983
1984IV
1985PerlIOMmap_fill(PerlIO *f)
1986{
1987 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1988 IV code = PerlIO_flush(f);
1989 PerlIO_debug(__FUNCTION__ " f=%p flush posn=%ld\n",f,(long)b->posn);
1990 if (code == 0 && !b->buf)
1991 {
1992 code = PerlIOMmap_map(f);
1993 PerlIO_debug(__FUNCTION__ " f=%p mmap code=%d posn=%ld\n",f,code,(long)b->posn);
1994 }
1995 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1996 {
1997 code = PerlIOBuf_fill(f);
1998 PerlIO_debug(__FUNCTION__ " f=%p fill code=%d posn=%ld\n",f,code,(long)b->posn);
1999 }
2000 return code;
2001}
2002
2003IV
2004PerlIOMmap_close(PerlIO *f)
2005{
2006 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2007 PerlIOBuf *b = &m->base;
2008 IV code = PerlIO_flush(f);
2009 if (m->bbuf)
2010 {
2011 b->buf = m->bbuf;
2012 m->bbuf = NULL;
2013 b->ptr = b->end = b->buf;
2014 }
2015 if (PerlIOBuf_close(f) != 0)
2016 code = -1;
2017 PerlIO_debug(__FUNCTION__ " f=%p %d\n",f,code);
2018 return code;
2019}
2020
2021
2022PerlIO_funcs PerlIO_mmap = {
2023 "mmap",
2024 sizeof(PerlIOMmap),
2025 0,
2026 PerlIOBase_fileno,
2027 PerlIOBuf_fdopen,
2028 PerlIOBuf_open,
2029 PerlIOBase_reopen,
2030 PerlIOBase_pushed,
2031 PerlIOBase_noop_ok,
2032 PerlIOBuf_read,
2033 PerlIOMmap_unread,
2034 PerlIOMmap_write,
2035 PerlIOBuf_seek,
2036 PerlIOBuf_tell,
2037 PerlIOBuf_close,
2038 PerlIOMmap_flush,
2039 PerlIOMmap_fill,
2040 PerlIOBase_eof,
2041 PerlIOBase_error,
2042 PerlIOBase_clearerr,
2043 PerlIOBuf_setlinebuf,
2044 PerlIOMmap_get_base,
2045 PerlIOBuf_bufsiz,
2046 PerlIOBuf_get_ptr,
2047 PerlIOBuf_get_cnt,
2048 PerlIOBuf_set_ptrcnt,
2049};
2050
2051#endif /* HAS_MMAP */
2052
2053
2054
9e353e3b
NIS
2055void
2056PerlIO_init(void)
760ac839 2057{
9e353e3b 2058 if (!_perlio)
6f9d8c32 2059 {
9e353e3b 2060 atexit(&PerlIO_cleanup);
6f9d8c32 2061 }
760ac839
LW
2062}
2063
9e353e3b
NIS
2064#undef PerlIO_stdin
2065PerlIO *
2066PerlIO_stdin(void)
2067{
2068 if (!_perlio)
f3862f8b 2069 PerlIO_stdstreams();
05d1247b 2070 return &_perlio[1];
9e353e3b
NIS
2071}
2072
2073#undef PerlIO_stdout
2074PerlIO *
2075PerlIO_stdout(void)
2076{
2077 if (!_perlio)
f3862f8b 2078 PerlIO_stdstreams();
05d1247b 2079 return &_perlio[2];
9e353e3b
NIS
2080}
2081
2082#undef PerlIO_stderr
2083PerlIO *
2084PerlIO_stderr(void)
2085{
2086 if (!_perlio)
f3862f8b 2087 PerlIO_stdstreams();
05d1247b 2088 return &_perlio[3];
9e353e3b
NIS
2089}
2090
2091/*--------------------------------------------------------------------------------------*/
2092
2093#undef PerlIO_getname
2094char *
2095PerlIO_getname(PerlIO *f, char *buf)
2096{
2097 dTHX;
2098 Perl_croak(aTHX_ "Don't know how to get file name");
2099 return NULL;
2100}
2101
2102
2103/*--------------------------------------------------------------------------------------*/
2104/* Functions which can be called on any kind of PerlIO implemented
2105 in terms of above
2106*/
2107
2108#undef PerlIO_getc
6f9d8c32 2109int
9e353e3b 2110PerlIO_getc(PerlIO *f)
760ac839 2111{
313ca112
NIS
2112 STDCHAR buf[1];
2113 SSize_t count = PerlIO_read(f,buf,1);
9e353e3b 2114 if (count == 1)
313ca112
NIS
2115 {
2116 return (unsigned char) buf[0];
2117 }
2118 return EOF;
2119}
2120
2121#undef PerlIO_ungetc
2122int
2123PerlIO_ungetc(PerlIO *f, int ch)
2124{
2125 if (ch != EOF)
2126 {
2127 STDCHAR buf = ch;
2128 if (PerlIO_unread(f,&buf,1) == 1)
2129 return ch;
2130 }
2131 return EOF;
760ac839
LW
2132}
2133
9e353e3b
NIS
2134#undef PerlIO_putc
2135int
2136PerlIO_putc(PerlIO *f, int ch)
760ac839 2137{
9e353e3b
NIS
2138 STDCHAR buf = ch;
2139 return PerlIO_write(f,&buf,1);
760ac839
LW
2140}
2141
9e353e3b 2142#undef PerlIO_puts
760ac839 2143int
9e353e3b 2144PerlIO_puts(PerlIO *f, const char *s)
760ac839 2145{
9e353e3b
NIS
2146 STRLEN len = strlen(s);
2147 return PerlIO_write(f,s,len);
760ac839
LW
2148}
2149
2150#undef PerlIO_rewind
2151void
c78749f2 2152PerlIO_rewind(PerlIO *f)
760ac839 2153{
6f9d8c32 2154 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 2155 PerlIO_clearerr(f);
6f9d8c32
NIS
2156}
2157
2158#undef PerlIO_vprintf
2159int
2160PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2161{
2162 dTHX;
bb9950b7 2163 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
2164 char *s;
2165 STRLEN len;
2166 sv_vcatpvf(sv, fmt, &ap);
2167 s = SvPV(sv,len);
bb9950b7 2168 return PerlIO_write(f,s,len);
760ac839
LW
2169}
2170
2171#undef PerlIO_printf
6f9d8c32 2172int
760ac839 2173PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
2174{
2175 va_list ap;
2176 int result;
760ac839 2177 va_start(ap,fmt);
6f9d8c32 2178 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
2179 va_end(ap);
2180 return result;
2181}
2182
2183#undef PerlIO_stdoutf
6f9d8c32 2184int
760ac839 2185PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
2186{
2187 va_list ap;
2188 int result;
760ac839 2189 va_start(ap,fmt);
760ac839
LW
2190 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2191 va_end(ap);
2192 return result;
2193}
2194
2195#undef PerlIO_tmpfile
2196PerlIO *
c78749f2 2197PerlIO_tmpfile(void)
760ac839 2198{
6f9d8c32 2199 dTHX;
b1ef6e3b 2200 /* I have no idea how portable mkstemp() is ... */
6f9d8c32
NIS
2201 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2202 int fd = mkstemp(SvPVX(sv));
2203 PerlIO *f = NULL;
2204 if (fd >= 0)
2205 {
b1ef6e3b 2206 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
2207 if (f)
2208 {
9e353e3b 2209 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32
NIS
2210 }
2211 unlink(SvPVX(sv));
2212 SvREFCNT_dec(sv);
2213 }
2214 return f;
760ac839
LW
2215}
2216
6f9d8c32
NIS
2217#undef HAS_FSETPOS
2218#undef HAS_FGETPOS
2219
760ac839
LW
2220#endif /* USE_SFIO */
2221#endif /* PERLIO_IS_STDIO */
2222
9e353e3b
NIS
2223/*======================================================================================*/
2224/* Now some functions in terms of above which may be needed even if
2225 we are not in true PerlIO mode
2226 */
2227
760ac839
LW
2228#ifndef HAS_FSETPOS
2229#undef PerlIO_setpos
2230int
c78749f2 2231PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 2232{
6f9d8c32 2233 return PerlIO_seek(f,*pos,0);
760ac839 2234}
c411622e
PP
2235#else
2236#ifndef PERLIO_IS_STDIO
2237#undef PerlIO_setpos
2238int
c78749f2 2239PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 2240{
2d4389e4 2241#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2242 return fsetpos64(f, pos);
2243#else
c411622e 2244 return fsetpos(f, pos);
d9b3e12d 2245#endif
c411622e
PP
2246}
2247#endif
760ac839
LW
2248#endif
2249
2250#ifndef HAS_FGETPOS
2251#undef PerlIO_getpos
2252int
c78749f2 2253PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
2254{
2255 *pos = PerlIO_tell(f);
2256 return 0;
2257}
c411622e
PP
2258#else
2259#ifndef PERLIO_IS_STDIO
2260#undef PerlIO_getpos
2261int
c78749f2 2262PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 2263{
2d4389e4 2264#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2265 return fgetpos64(f, pos);
2266#else
c411622e 2267 return fgetpos(f, pos);
d9b3e12d 2268#endif
c411622e
PP
2269}
2270#endif
760ac839
LW
2271#endif
2272
2273#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2274
2275int
c78749f2 2276vprintf(char *pat, char *args)
662a7e3f
CS
2277{
2278 _doprnt(pat, args, stdout);
2279 return 0; /* wrong, but perl doesn't use the return value */
2280}
2281
2282int
c78749f2 2283vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
2284{
2285 _doprnt(pat, args, fd);
2286 return 0; /* wrong, but perl doesn't use the return value */
2287}
2288
2289#endif
2290
2291#ifndef PerlIO_vsprintf
6f9d8c32 2292int
8ac85365 2293PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
2294{
2295 int val = vsprintf(s, fmt, ap);
2296 if (n >= 0)
2297 {
8c86a920 2298 if (strlen(s) >= (STRLEN)n)
760ac839 2299 {
bf49b057
GS
2300 dTHX;
2301 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
2302 my_exit(1);
760ac839
LW
2303 }
2304 }
2305 return val;
2306}
2307#endif
2308
2309#ifndef PerlIO_sprintf
6f9d8c32 2310int
760ac839 2311PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
2312{
2313 va_list ap;
2314 int result;
760ac839 2315 va_start(ap,fmt);
760ac839
LW
2316 result = PerlIO_vsprintf(s, n, fmt, ap);
2317 va_end(ap);
2318 return result;
2319}
2320#endif
2321
c5be433b
GS
2322#endif /* !PERL_IMPLICIT_SYS */
2323