This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate 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
4a4a6116
NIS
252HV *PerlIO_layer_hv;
253AV *PerlIO_layer_av;
254
05d1247b
NIS
255void
256PerlIO_cleanup(void)
257{
258 PerlIO_cleantable(&_perlio);
6f9d8c32
NIS
259}
260
9e353e3b
NIS
261void
262PerlIO_pop(PerlIO *f)
760ac839 263{
9e353e3b
NIS
264 PerlIOl *l = *f;
265 if (l)
6f9d8c32 266 {
06da4f11 267 (*l->tab->Popped)(f);
9e353e3b
NIS
268 *f = l->next;
269 Safefree(l);
6f9d8c32 270 }
6f9d8c32
NIS
271}
272
273#undef PerlIO_close
274int
275PerlIO_close(PerlIO *f)
276{
9e353e3b
NIS
277 int code = (*PerlIOBase(f)->tab->Close)(f);
278 while (*f)
6f9d8c32 279 {
9e353e3b 280 PerlIO_pop(f);
6f9d8c32
NIS
281 }
282 return code;
283}
284
9e353e3b
NIS
285
286/*--------------------------------------------------------------------------------------*/
287/* Given the abstraction above the public API functions */
288
289#undef PerlIO_fileno
290int
291PerlIO_fileno(PerlIO *f)
292{
293 return (*PerlIOBase(f)->tab->Fileno)(f);
294}
295
f3862f8b 296
9e353e3b 297extern PerlIO_funcs PerlIO_unix;
9e353e3b 298extern PerlIO_funcs PerlIO_perlio;
f3862f8b 299extern PerlIO_funcs PerlIO_stdio;
06da4f11
NIS
300#ifdef HAS_MMAP
301extern PerlIO_funcs PerlIO_mmap;
302#endif
f3862f8b
NIS
303
304XS(XS_perlio_import)
305{
306 dXSARGS;
307 GV *gv = CvGV(cv);
308 char *s = GvNAME(gv);
309 STRLEN l = GvNAMELEN(gv);
310 PerlIO_debug("%.*s\n",(int) l,s);
311 XSRETURN_EMPTY;
312}
313
314XS(XS_perlio_unimport)
315{
316 dXSARGS;
317 GV *gv = CvGV(cv);
318 char *s = GvNAME(gv);
319 STRLEN l = GvNAMELEN(gv);
320 PerlIO_debug("%.*s\n",(int) l,s);
321 XSRETURN_EMPTY;
322}
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);
e7778b43 343 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
f3862f8b
NIS
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 {
e7778b43 412 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
f3862f8b
NIS
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
c512ea76
NIS
1040#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
1041#define fseek fseeko
1042#endif
1043
1044#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
1045#define ftell ftello
1046#endif
1047
1048
9e353e3b
NIS
1049typedef struct
1050{
1051 struct _PerlIO base;
1052 FILE * stdio; /* The stream */
1053} PerlIOStdio;
1054
1055IV
1056PerlIOStdio_fileno(PerlIO *f)
1057{
1058 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1059}
1060
1061
1062PerlIO *
06da4f11 1063PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
1064{
1065 PerlIO *f = NULL;
c7fc522f
NIS
1066 int init = 0;
1067 if (*mode == 'I')
1068 {
1069 init = 1;
1070 mode++;
1071 }
9e353e3b
NIS
1072 if (fd >= 0)
1073 {
c7fc522f
NIS
1074 FILE *stdio = NULL;
1075 if (init)
1076 {
1077 switch(fd)
1078 {
1079 case 0:
1080 stdio = stdin;
1081 break;
1082 case 1:
1083 stdio = stdout;
1084 break;
1085 case 2:
1086 stdio = stderr;
1087 break;
1088 }
1089 }
1090 else
1091 stdio = fdopen(fd,mode);
9e353e3b
NIS
1092 if (stdio)
1093 {
06da4f11 1094 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1095 s->stdio = stdio;
1096 }
1097 }
1098 return f;
1099}
1100
1101#undef PerlIO_importFILE
1102PerlIO *
1103PerlIO_importFILE(FILE *stdio, int fl)
1104{
1105 PerlIO *f = NULL;
1106 if (stdio)
1107 {
1108 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1109 s->stdio = stdio;
1110 }
1111 return f;
1112}
1113
1114PerlIO *
06da4f11 1115PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
1116{
1117 PerlIO *f = NULL;
1118 FILE *stdio = fopen(path,mode);
1119 if (stdio)
1120 {
06da4f11 1121 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1122 s->stdio = stdio;
1123 }
1124 return f;
760ac839
LW
1125}
1126
6f9d8c32 1127int
9e353e3b
NIS
1128PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1129{
1130 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1131 FILE *stdio = freopen(path,mode,s->stdio);
1132 if (!s->stdio)
1133 return -1;
1134 s->stdio = stdio;
1135 return 0;
1136}
1137
1138SSize_t
1139PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1140{
1141 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 1142 SSize_t got = 0;
9e353e3b
NIS
1143 if (count == 1)
1144 {
1145 STDCHAR *buf = (STDCHAR *) vbuf;
1146 /* Perl is expecting PerlIO_getc() to fill the buffer
1147 * Linux's stdio does not do that for fread()
1148 */
1149 int ch = fgetc(s);
1150 if (ch != EOF)
1151 {
1152 *buf = ch;
c7fc522f 1153 got = 1;
9e353e3b 1154 }
9e353e3b 1155 }
c7fc522f
NIS
1156 else
1157 got = fread(vbuf,1,count,s);
1158 return got;
9e353e3b
NIS
1159}
1160
1161SSize_t
1162PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1163{
1164 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1165 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1166 SSize_t unread = 0;
1167 while (count > 0)
1168 {
1169 int ch = *buf-- & 0xff;
1170 if (ungetc(ch,s) != ch)
1171 break;
1172 unread++;
1173 count--;
1174 }
1175 return unread;
1176}
1177
1178SSize_t
1179PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1180{
1181 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1182}
1183
1184IV
1185PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1186{
c7fc522f
NIS
1187 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1188 return fseek(stdio,offset,whence);
9e353e3b
NIS
1189}
1190
1191Off_t
1192PerlIOStdio_tell(PerlIO *f)
1193{
c7fc522f
NIS
1194 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1195 return ftell(stdio);
9e353e3b
NIS
1196}
1197
1198IV
1199PerlIOStdio_close(PerlIO *f)
1200{
1201 return fclose(PerlIOSelf(f,PerlIOStdio)->stdio);
1202}
1203
1204IV
1205PerlIOStdio_flush(PerlIO *f)
1206{
1207 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1208 return fflush(stdio);
1209}
1210
1211IV
06da4f11
NIS
1212PerlIOStdio_fill(PerlIO *f)
1213{
1214 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1215 int c;
1216 if (fflush(stdio) != 0)
1217 return EOF;
1218 c = fgetc(stdio);
1219 if (c == EOF || ungetc(c,stdio) != c)
1220 return EOF;
1221 return 0;
1222}
1223
1224IV
9e353e3b
NIS
1225PerlIOStdio_eof(PerlIO *f)
1226{
1227 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1228}
1229
1230IV
1231PerlIOStdio_error(PerlIO *f)
1232{
1233 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1234}
1235
1236void
1237PerlIOStdio_clearerr(PerlIO *f)
1238{
1239 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1240}
1241
1242void
1243PerlIOStdio_setlinebuf(PerlIO *f)
1244{
1245#ifdef HAS_SETLINEBUF
1246 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1247#else
1248 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1249#endif
1250}
1251
1252#ifdef FILE_base
1253STDCHAR *
1254PerlIOStdio_get_base(PerlIO *f)
1255{
1256 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1257 return FILE_base(stdio);
1258}
1259
1260Size_t
1261PerlIOStdio_get_bufsiz(PerlIO *f)
1262{
1263 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1264 return FILE_bufsiz(stdio);
1265}
1266#endif
1267
1268#ifdef USE_STDIO_PTR
1269STDCHAR *
1270PerlIOStdio_get_ptr(PerlIO *f)
1271{
1272 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1273 return FILE_ptr(stdio);
1274}
1275
1276SSize_t
1277PerlIOStdio_get_cnt(PerlIO *f)
1278{
1279 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1280 return FILE_cnt(stdio);
1281}
1282
1283void
1284PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1285{
1286 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1287 if (ptr != NULL)
1288 {
1289#ifdef STDIO_PTR_LVALUE
1290 FILE_ptr(stdio) = ptr;
1291#ifdef STDIO_PTR_LVAL_SETS_CNT
1292 if (FILE_cnt(stdio) != (cnt))
1293 {
1294 dTHX;
1295 assert(FILE_cnt(stdio) == (cnt));
1296 }
1297#endif
1298#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1299 /* Setting ptr _does_ change cnt - we are done */
1300 return;
1301#endif
1302#else /* STDIO_PTR_LVALUE */
1303 abort();
1304#endif /* STDIO_PTR_LVALUE */
1305 }
1306/* Now (or only) set cnt */
1307#ifdef STDIO_CNT_LVALUE
1308 FILE_cnt(stdio) = cnt;
1309#else /* STDIO_CNT_LVALUE */
1310#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1311 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1312#else /* STDIO_PTR_LVAL_SETS_CNT */
1313 abort();
1314#endif /* STDIO_PTR_LVAL_SETS_CNT */
1315#endif /* STDIO_CNT_LVALUE */
1316}
1317
1318#endif
1319
1320PerlIO_funcs PerlIO_stdio = {
1321 "stdio",
1322 sizeof(PerlIOStdio),
1323 0,
1324 PerlIOStdio_fileno,
1325 PerlIOStdio_fdopen,
1326 PerlIOStdio_open,
1327 PerlIOStdio_reopen,
06da4f11
NIS
1328 PerlIOBase_pushed,
1329 PerlIOBase_noop_ok,
9e353e3b
NIS
1330 PerlIOStdio_read,
1331 PerlIOStdio_unread,
1332 PerlIOStdio_write,
1333 PerlIOStdio_seek,
1334 PerlIOStdio_tell,
1335 PerlIOStdio_close,
1336 PerlIOStdio_flush,
06da4f11 1337 PerlIOStdio_fill,
9e353e3b
NIS
1338 PerlIOStdio_eof,
1339 PerlIOStdio_error,
1340 PerlIOStdio_clearerr,
1341 PerlIOStdio_setlinebuf,
1342#ifdef FILE_base
1343 PerlIOStdio_get_base,
1344 PerlIOStdio_get_bufsiz,
1345#else
1346 NULL,
1347 NULL,
1348#endif
1349#ifdef USE_STDIO_PTR
1350 PerlIOStdio_get_ptr,
1351 PerlIOStdio_get_cnt,
0eb1d8a4 1352#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
9e353e3b
NIS
1353 PerlIOStdio_set_ptrcnt
1354#else /* STDIO_PTR_LVALUE */
1355 NULL
1356#endif /* STDIO_PTR_LVALUE */
1357#else /* USE_STDIO_PTR */
1358 NULL,
1359 NULL,
1360 NULL
1361#endif /* USE_STDIO_PTR */
1362};
1363
1364#undef PerlIO_exportFILE
1365FILE *
1366PerlIO_exportFILE(PerlIO *f, int fl)
1367{
1368 PerlIO_flush(f);
1369 /* Should really push stdio discipline when we have them */
1370 return fdopen(PerlIO_fileno(f),"r+");
1371}
1372
1373#undef PerlIO_findFILE
1374FILE *
1375PerlIO_findFILE(PerlIO *f)
1376{
1377 return PerlIO_exportFILE(f,0);
1378}
1379
1380#undef PerlIO_releaseFILE
1381void
1382PerlIO_releaseFILE(PerlIO *p, FILE *f)
1383{
1384}
1385
1386/*--------------------------------------------------------------------------------------*/
1387/* perlio buffer layer */
1388
1389typedef struct
760ac839 1390{
9e353e3b
NIS
1391 struct _PerlIO base;
1392 Off_t posn; /* Offset of buf into the file */
1393 STDCHAR * buf; /* Start of buffer */
1394 STDCHAR * end; /* End of valid part of buffer */
1395 STDCHAR * ptr; /* Current position in buffer */
1396 Size_t bufsiz; /* Size of buffer */
1397 IV oneword; /* Emergency buffer */
1398} PerlIOBuf;
1399
1400
1401PerlIO *
06da4f11 1402PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
9e353e3b
NIS
1403{
1404 PerlIO_funcs *tab = PerlIO_default_btm();
c7fc522f
NIS
1405 int init = 0;
1406 PerlIO *f;
1407 if (*mode == 'I')
1408 {
1409 init = 1;
1410 mode++;
1411 }
06da4f11 1412 f = (*tab->Fdopen)(tab,fd,mode);
6f9d8c32
NIS
1413 if (f)
1414 {
c7fc522f
NIS
1415 /* Initial stderr is unbuffered */
1416 if (!init || fd != 2)
1417 {
06da4f11 1418 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
c7fc522f
NIS
1419 b->posn = PerlIO_tell(PerlIONext(f));
1420 }
6f9d8c32 1421 }
9e353e3b 1422 return f;
760ac839
LW
1423}
1424
c3d7c7c9 1425
9e353e3b 1426PerlIO *
06da4f11 1427PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
8c86a920 1428{
9e353e3b 1429 PerlIO_funcs *tab = PerlIO_default_btm();
06da4f11 1430 PerlIO *f = (*tab->Open)(tab,path,mode);
9e353e3b
NIS
1431 if (f)
1432 {
06da4f11 1433 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
c3d7c7c9 1434 b->posn = PerlIO_tell(PerlIONext(f));
9e353e3b
NIS
1435 }
1436 return f;
1437}
1438
1439int
c3d7c7c9 1440PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
9e353e3b 1441{
c3d7c7c9
NIS
1442 PerlIO *next = PerlIONext(f);
1443 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1444 if (code = 0)
1445 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1446 if (code == 0)
1447 {
1448 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1449 b->posn = PerlIO_tell(PerlIONext(f));
1450 }
1451 return code;
9e353e3b
NIS
1452}
1453
9e353e3b
NIS
1454/* This "flush" is akin to sfio's sync in that it handles files in either
1455 read or write state
1456*/
1457IV
1458PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1459{
9e353e3b
NIS
1460 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1461 int code = 0;
1462 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1463 {
1464 /* write() the buffer */
1465 STDCHAR *p = b->buf;
1466 int count;
1467 while (p < b->ptr)
1468 {
1469 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1470 if (count > 0)
1471 {
1472 p += count;
1473 }
1474 else if (count < 0)
1475 {
1476 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1477 code = -1;
1478 break;
1479 }
1480 }
1481 b->posn += (p - b->buf);
1482 }
1483 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1484 {
9e353e3b
NIS
1485 /* Note position change */
1486 b->posn += (b->ptr - b->buf);
1487 if (b->ptr < b->end)
1488 {
1489 /* We did not consume all of it */
1490 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1491 {
1492 b->posn = PerlIO_tell(PerlIONext(f));
1493 }
1494 }
6f9d8c32 1495 }
9e353e3b
NIS
1496 b->ptr = b->end = b->buf;
1497 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1498 if (PerlIO_flush(PerlIONext(f)) != 0)
1499 code = -1;
1500 return code;
6f9d8c32
NIS
1501}
1502
06da4f11
NIS
1503IV
1504PerlIOBuf_fill(PerlIO *f)
1505{
1506 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1507 SSize_t avail;
1508 if (PerlIO_flush(f) != 0)
1509 return -1;
1510 b->ptr = b->end = b->buf;
1511 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1512 if (avail <= 0)
1513 {
1514 if (avail == 0)
1515 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1516 else
1517 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1518 return -1;
1519 }
1520 b->end = b->buf+avail;
1521 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1522 return 0;
1523}
1524
6f9d8c32 1525SSize_t
9e353e3b 1526PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1527{
9e353e3b 1528 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
6f9d8c32
NIS
1529 STDCHAR *buf = (STDCHAR *) vbuf;
1530 if (f)
1531 {
1532 Size_t got = 0;
9e353e3b 1533 if (!b->ptr)
06da4f11 1534 PerlIO_get_base(f);
9e353e3b 1535 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1536 return 0;
6f9d8c32
NIS
1537 while (count > 0)
1538 {
9e353e3b 1539 SSize_t avail = (b->end - b->ptr);
6f9d8c32
NIS
1540 if ((SSize_t) count < avail)
1541 avail = count;
1542 if (avail > 0)
1543 {
9e353e3b 1544 Copy(b->ptr,buf,avail,char);
6f9d8c32 1545 got += avail;
9e353e3b 1546 b->ptr += avail;
6f9d8c32
NIS
1547 count -= avail;
1548 buf += avail;
1549 }
9e353e3b 1550 if (count && (b->ptr >= b->end))
6f9d8c32 1551 {
06da4f11
NIS
1552 if (PerlIO_fill(f) != 0)
1553 break;
6f9d8c32
NIS
1554 }
1555 }
1556 return got;
1557 }
1558 return 0;
1559}
1560
9e353e3b
NIS
1561SSize_t
1562PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1563{
9e353e3b
NIS
1564 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1565 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1566 SSize_t unread = 0;
1567 SSize_t avail;
9e353e3b
NIS
1568 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1569 PerlIO_flush(f);
06da4f11
NIS
1570 if (!b->buf)
1571 PerlIO_get_base(f);
9e353e3b
NIS
1572 if (b->buf)
1573 {
1574 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1575 {
1576 avail = (b->ptr - b->buf);
1577 if (avail > (SSize_t) count)
1578 avail = count;
1579 b->ptr -= avail;
1580 }
1581 else
1582 {
1583 avail = b->bufsiz;
1584 if (avail > (SSize_t) count)
1585 avail = count;
1586 b->end = b->ptr + avail;
1587 }
1588 if (avail > 0)
1589 {
1590 buf -= avail;
1591 if (buf != b->ptr)
1592 {
1593 Copy(buf,b->ptr,avail,char);
1594 }
1595 count -= avail;
1596 unread += avail;
1597 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1598 }
1599 }
1600 return unread;
760ac839
LW
1601}
1602
9e353e3b
NIS
1603SSize_t
1604PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1605{
9e353e3b
NIS
1606 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1607 const STDCHAR *buf = (const STDCHAR *) vbuf;
1608 Size_t written = 0;
1609 if (!b->buf)
06da4f11 1610 PerlIO_get_base(f);
9e353e3b
NIS
1611 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1612 return 0;
1613 while (count > 0)
1614 {
1615 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1616 if ((SSize_t) count < avail)
1617 avail = count;
1618 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1619 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1620 {
1621 while (avail > 0)
1622 {
1623 int ch = *buf++;
1624 *(b->ptr)++ = ch;
1625 count--;
1626 avail--;
1627 written++;
1628 if (ch == '\n')
1629 {
1630 PerlIO_flush(f);
1631 break;
1632 }
1633 }
1634 }
1635 else
1636 {
1637 if (avail)
1638 {
1639 Copy(buf,b->ptr,avail,char);
1640 count -= avail;
1641 buf += avail;
1642 written += avail;
1643 b->ptr += avail;
1644 }
1645 }
1646 if (b->ptr >= (b->buf + b->bufsiz))
1647 PerlIO_flush(f);
1648 }
1649 return written;
1650}
1651
1652IV
1653PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1654{
1655 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
06da4f11 1656 int code = PerlIO_flush(f);
9e353e3b
NIS
1657 if (code == 0)
1658 {
1659 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1660 code = PerlIO_seek(PerlIONext(f),offset,whence);
1661 if (code == 0)
1662 {
1663 b->posn = PerlIO_tell(PerlIONext(f));
1664 }
1665 }
1666 return code;
1667}
1668
1669Off_t
1670PerlIOBuf_tell(PerlIO *f)
1671{
1672 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1673 Off_t posn = b->posn;
1674 if (b->buf)
1675 posn += (b->ptr - b->buf);
1676 return posn;
1677}
1678
1679IV
1680PerlIOBuf_close(PerlIO *f)
1681{
1682 IV code = PerlIOBase_close(f);
1683 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1684 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 1685 {
9e353e3b 1686 Safefree(b->buf);
6f9d8c32 1687 }
9e353e3b
NIS
1688 b->buf = NULL;
1689 b->ptr = b->end = b->buf;
1690 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1691 return code;
760ac839
LW
1692}
1693
760ac839 1694void
9e353e3b 1695PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 1696{
6f9d8c32
NIS
1697 if (f)
1698 {
9e353e3b 1699 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 1700 }
760ac839
LW
1701}
1702
760ac839 1703void
9e353e3b 1704PerlIOBuf_set_cnt(PerlIO *f, int cnt)
760ac839 1705{
9e353e3b
NIS
1706 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1707 dTHX;
1708 if (!b->buf)
06da4f11 1709 PerlIO_get_base(f);
9e353e3b
NIS
1710 b->ptr = b->end - cnt;
1711 assert(b->ptr >= b->buf);
1712}
1713
1714STDCHAR *
1715PerlIOBuf_get_ptr(PerlIO *f)
1716{
1717 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1718 if (!b->buf)
06da4f11 1719 PerlIO_get_base(f);
9e353e3b
NIS
1720 return b->ptr;
1721}
1722
05d1247b 1723SSize_t
9e353e3b
NIS
1724PerlIOBuf_get_cnt(PerlIO *f)
1725{
1726 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1727 if (!b->buf)
06da4f11 1728 PerlIO_get_base(f);
9e353e3b
NIS
1729 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1730 return (b->end - b->ptr);
1731 return 0;
1732}
1733
1734STDCHAR *
1735PerlIOBuf_get_base(PerlIO *f)
1736{
1737 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1738 if (!b->buf)
06da4f11
NIS
1739 {
1740 if (!b->bufsiz)
1741 b->bufsiz = 4096;
1742 New('B',b->buf,b->bufsiz,STDCHAR);
1743 if (!b->buf)
1744 {
1745 b->buf = (STDCHAR *)&b->oneword;
1746 b->bufsiz = sizeof(b->oneword);
1747 }
1748 b->ptr = b->buf;
1749 b->end = b->ptr;
1750 }
9e353e3b
NIS
1751 return b->buf;
1752}
1753
1754Size_t
1755PerlIOBuf_bufsiz(PerlIO *f)
1756{
1757 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1758 if (!b->buf)
06da4f11 1759 PerlIO_get_base(f);
9e353e3b
NIS
1760 return (b->end - b->buf);
1761}
1762
1763void
05d1247b 1764PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS
1765{
1766 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1767 if (!b->buf)
06da4f11 1768 PerlIO_get_base(f);
9e353e3b
NIS
1769 b->ptr = ptr;
1770 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 1771 {
9e353e3b
NIS
1772 dTHX;
1773 assert(PerlIO_get_cnt(f) == cnt);
1774 assert(b->ptr >= b->buf);
6f9d8c32 1775 }
9e353e3b 1776 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
1777}
1778
9e353e3b
NIS
1779PerlIO_funcs PerlIO_perlio = {
1780 "perlio",
1781 sizeof(PerlIOBuf),
1782 0,
1783 PerlIOBase_fileno,
1784 PerlIOBuf_fdopen,
1785 PerlIOBuf_open,
c3d7c7c9 1786 PerlIOBuf_reopen,
06da4f11
NIS
1787 PerlIOBase_pushed,
1788 PerlIOBase_noop_ok,
9e353e3b
NIS
1789 PerlIOBuf_read,
1790 PerlIOBuf_unread,
1791 PerlIOBuf_write,
1792 PerlIOBuf_seek,
1793 PerlIOBuf_tell,
1794 PerlIOBuf_close,
1795 PerlIOBuf_flush,
06da4f11 1796 PerlIOBuf_fill,
9e353e3b
NIS
1797 PerlIOBase_eof,
1798 PerlIOBase_error,
1799 PerlIOBase_clearerr,
1800 PerlIOBuf_setlinebuf,
1801 PerlIOBuf_get_base,
1802 PerlIOBuf_bufsiz,
1803 PerlIOBuf_get_ptr,
1804 PerlIOBuf_get_cnt,
1805 PerlIOBuf_set_ptrcnt,
1806};
1807
06da4f11
NIS
1808#ifdef HAS_MMAP
1809/*--------------------------------------------------------------------------------------*/
1810/* mmap as "buffer" layer */
1811
1812typedef struct
1813{
1814 PerlIOBuf base; /* PerlIOBuf stuff */
c3d7c7c9 1815 Mmap_t mptr; /* Mapped address */
06da4f11
NIS
1816 Size_t len; /* mapped length */
1817 STDCHAR *bbuf; /* malloced buffer if map fails */
c3d7c7c9 1818
06da4f11
NIS
1819} PerlIOMmap;
1820
c3d7c7c9
NIS
1821static size_t page_size = 0;
1822
06da4f11
NIS
1823IV
1824PerlIOMmap_map(PerlIO *f)
1825{
1826 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1827 PerlIOBuf *b = &m->base;
1828 IV flags = PerlIOBase(f)->flags;
1829 IV code = 0;
1830 if (m->len)
1831 abort();
1832 if (flags & PERLIO_F_CANREAD)
1833 {
1834 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1835 int fd = PerlIO_fileno(f);
1836 struct stat st;
1837 code = fstat(fd,&st);
1838 if (code == 0 && S_ISREG(st.st_mode))
1839 {
1840 SSize_t len = st.st_size - b->posn;
1841 if (len > 0)
1842 {
c3d7c7c9
NIS
1843 Off_t posn;
1844 if (!page_size)
1845 page_size = getpagesize();
1846 if (b->posn < 0)
1847 {
1848 /* This is a hack - should never happen - open should have set it ! */
1849 b->posn = PerlIO_tell(PerlIONext(f));
1850 }
1851 posn = (b->posn / page_size) * page_size;
1852 len = st.st_size - posn;
1853 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
1854 if (m->mptr && m->mptr != (Mmap_t) -1)
06da4f11
NIS
1855 {
1856#if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
c3d7c7c9 1857 madvise(m->mptr, len, MADV_SEQUENTIAL);
06da4f11 1858#endif
c3d7c7c9
NIS
1859 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
1860 b->end = ((STDCHAR *)m->mptr) + len;
1861 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
1862 b->ptr = b->buf;
1863 m->len = len;
06da4f11
NIS
1864 }
1865 else
1866 {
1867 b->buf = NULL;
1868 }
1869 }
1870 else
1871 {
1872 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1873 b->buf = NULL;
1874 b->ptr = b->end = b->ptr;
1875 code = -1;
1876 }
1877 }
1878 }
1879 return code;
1880}
1881
1882IV
1883PerlIOMmap_unmap(PerlIO *f)
1884{
1885 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1886 PerlIOBuf *b = &m->base;
1887 IV code = 0;
1888 if (m->len)
1889 {
1890 if (b->buf)
1891 {
c3d7c7c9
NIS
1892 code = munmap(m->mptr, m->len);
1893 b->buf = NULL;
1894 m->len = 0;
1895 m->mptr = NULL;
06da4f11
NIS
1896 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1897 code = -1;
06da4f11
NIS
1898 }
1899 b->ptr = b->end = b->buf;
1900 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1901 }
1902 return code;
1903}
1904
1905STDCHAR *
1906PerlIOMmap_get_base(PerlIO *f)
1907{
1908 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1909 PerlIOBuf *b = &m->base;
1910 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1911 {
1912 /* Already have a readbuffer in progress */
1913 return b->buf;
1914 }
1915 if (b->buf)
1916 {
1917 /* We have a write buffer or flushed PerlIOBuf read buffer */
1918 m->bbuf = b->buf; /* save it in case we need it again */
1919 b->buf = NULL; /* Clear to trigger below */
1920 }
1921 if (!b->buf)
1922 {
1923 PerlIOMmap_map(f); /* Try and map it */
1924 if (!b->buf)
1925 {
1926 /* Map did not work - recover PerlIOBuf buffer if we have one */
1927 b->buf = m->bbuf;
1928 }
1929 }
1930 b->ptr = b->end = b->buf;
1931 if (b->buf)
1932 return b->buf;
1933 return PerlIOBuf_get_base(f);
1934}
1935
1936SSize_t
1937PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
1938{
1939 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1940 PerlIOBuf *b = &m->base;
1941 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1942 PerlIO_flush(f);
1943 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
1944 {
1945 b->ptr -= count;
1946 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1947 return count;
1948 }
1949 if (m->len)
1950 {
4a4a6116 1951 /* Loose the unwritable mapped buffer */
06da4f11 1952 PerlIO_flush(f);
c3d7c7c9
NIS
1953 /* If flush took the "buffer" see if we have one from before */
1954 if (!b->buf && m->bbuf)
1955 b->buf = m->bbuf;
1956 if (!b->buf)
1957 {
1958 PerlIOBuf_get_base(f);
1959 m->bbuf = b->buf;
1960 }
06da4f11
NIS
1961 }
1962 return PerlIOBuf_unread(f,vbuf,count);
1963}
1964
1965SSize_t
1966PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
1967{
1968 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1969 PerlIOBuf *b = &m->base;
1970 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
1971 {
1972 /* No, or wrong sort of, buffer */
1973 if (m->len)
1974 {
1975 if (PerlIOMmap_unmap(f) != 0)
1976 return 0;
1977 }
1978 /* If unmap took the "buffer" see if we have one from before */
1979 if (!b->buf && m->bbuf)
1980 b->buf = m->bbuf;
1981 if (!b->buf)
1982 {
1983 PerlIOBuf_get_base(f);
1984 m->bbuf = b->buf;
1985 }
1986 }
1987 return PerlIOBuf_write(f,vbuf,count);
1988}
1989
1990IV
1991PerlIOMmap_flush(PerlIO *f)
1992{
1993 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1994 PerlIOBuf *b = &m->base;
1995 IV code = PerlIOBuf_flush(f);
1996 /* Now we are "synced" at PerlIOBuf level */
1997 if (b->buf)
1998 {
1999 if (m->len)
2000 {
2001 /* Unmap the buffer */
2002 if (PerlIOMmap_unmap(f) != 0)
2003 code = -1;
2004 }
2005 else
2006 {
2007 /* We seem to have a PerlIOBuf buffer which was not mapped
2008 * remember it in case we need one later
2009 */
2010 m->bbuf = b->buf;
2011 }
2012 }
06da4f11
NIS
2013 return code;
2014}
2015
2016IV
2017PerlIOMmap_fill(PerlIO *f)
2018{
2019 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2020 IV code = PerlIO_flush(f);
06da4f11
NIS
2021 if (code == 0 && !b->buf)
2022 {
2023 code = PerlIOMmap_map(f);
06da4f11
NIS
2024 }
2025 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2026 {
2027 code = PerlIOBuf_fill(f);
06da4f11
NIS
2028 }
2029 return code;
2030}
2031
2032IV
2033PerlIOMmap_close(PerlIO *f)
2034{
2035 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2036 PerlIOBuf *b = &m->base;
2037 IV code = PerlIO_flush(f);
2038 if (m->bbuf)
2039 {
2040 b->buf = m->bbuf;
2041 m->bbuf = NULL;
2042 b->ptr = b->end = b->buf;
2043 }
2044 if (PerlIOBuf_close(f) != 0)
2045 code = -1;
06da4f11
NIS
2046 return code;
2047}
2048
2049
2050PerlIO_funcs PerlIO_mmap = {
2051 "mmap",
2052 sizeof(PerlIOMmap),
2053 0,
2054 PerlIOBase_fileno,
2055 PerlIOBuf_fdopen,
2056 PerlIOBuf_open,
c3d7c7c9 2057 PerlIOBuf_reopen,
06da4f11
NIS
2058 PerlIOBase_pushed,
2059 PerlIOBase_noop_ok,
2060 PerlIOBuf_read,
2061 PerlIOMmap_unread,
2062 PerlIOMmap_write,
2063 PerlIOBuf_seek,
2064 PerlIOBuf_tell,
2065 PerlIOBuf_close,
2066 PerlIOMmap_flush,
2067 PerlIOMmap_fill,
2068 PerlIOBase_eof,
2069 PerlIOBase_error,
2070 PerlIOBase_clearerr,
2071 PerlIOBuf_setlinebuf,
2072 PerlIOMmap_get_base,
2073 PerlIOBuf_bufsiz,
2074 PerlIOBuf_get_ptr,
2075 PerlIOBuf_get_cnt,
2076 PerlIOBuf_set_ptrcnt,
2077};
2078
2079#endif /* HAS_MMAP */
2080
2081
2082
9e353e3b
NIS
2083void
2084PerlIO_init(void)
760ac839 2085{
9e353e3b 2086 if (!_perlio)
6f9d8c32 2087 {
9e353e3b 2088 atexit(&PerlIO_cleanup);
6f9d8c32 2089 }
760ac839
LW
2090}
2091
9e353e3b
NIS
2092#undef PerlIO_stdin
2093PerlIO *
2094PerlIO_stdin(void)
2095{
2096 if (!_perlio)
f3862f8b 2097 PerlIO_stdstreams();
05d1247b 2098 return &_perlio[1];
9e353e3b
NIS
2099}
2100
2101#undef PerlIO_stdout
2102PerlIO *
2103PerlIO_stdout(void)
2104{
2105 if (!_perlio)
f3862f8b 2106 PerlIO_stdstreams();
05d1247b 2107 return &_perlio[2];
9e353e3b
NIS
2108}
2109
2110#undef PerlIO_stderr
2111PerlIO *
2112PerlIO_stderr(void)
2113{
2114 if (!_perlio)
f3862f8b 2115 PerlIO_stdstreams();
05d1247b 2116 return &_perlio[3];
9e353e3b
NIS
2117}
2118
2119/*--------------------------------------------------------------------------------------*/
2120
2121#undef PerlIO_getname
2122char *
2123PerlIO_getname(PerlIO *f, char *buf)
2124{
2125 dTHX;
2126 Perl_croak(aTHX_ "Don't know how to get file name");
2127 return NULL;
2128}
2129
2130
2131/*--------------------------------------------------------------------------------------*/
2132/* Functions which can be called on any kind of PerlIO implemented
2133 in terms of above
2134*/
2135
2136#undef PerlIO_getc
6f9d8c32 2137int
9e353e3b 2138PerlIO_getc(PerlIO *f)
760ac839 2139{
313ca112
NIS
2140 STDCHAR buf[1];
2141 SSize_t count = PerlIO_read(f,buf,1);
9e353e3b 2142 if (count == 1)
313ca112
NIS
2143 {
2144 return (unsigned char) buf[0];
2145 }
2146 return EOF;
2147}
2148
2149#undef PerlIO_ungetc
2150int
2151PerlIO_ungetc(PerlIO *f, int ch)
2152{
2153 if (ch != EOF)
2154 {
2155 STDCHAR buf = ch;
2156 if (PerlIO_unread(f,&buf,1) == 1)
2157 return ch;
2158 }
2159 return EOF;
760ac839
LW
2160}
2161
9e353e3b
NIS
2162#undef PerlIO_putc
2163int
2164PerlIO_putc(PerlIO *f, int ch)
760ac839 2165{
9e353e3b
NIS
2166 STDCHAR buf = ch;
2167 return PerlIO_write(f,&buf,1);
760ac839
LW
2168}
2169
9e353e3b 2170#undef PerlIO_puts
760ac839 2171int
9e353e3b 2172PerlIO_puts(PerlIO *f, const char *s)
760ac839 2173{
9e353e3b
NIS
2174 STRLEN len = strlen(s);
2175 return PerlIO_write(f,s,len);
760ac839
LW
2176}
2177
2178#undef PerlIO_rewind
2179void
c78749f2 2180PerlIO_rewind(PerlIO *f)
760ac839 2181{
6f9d8c32 2182 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 2183 PerlIO_clearerr(f);
6f9d8c32
NIS
2184}
2185
2186#undef PerlIO_vprintf
2187int
2188PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2189{
2190 dTHX;
bb9950b7 2191 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
2192 char *s;
2193 STRLEN len;
2194 sv_vcatpvf(sv, fmt, &ap);
2195 s = SvPV(sv,len);
bb9950b7 2196 return PerlIO_write(f,s,len);
760ac839
LW
2197}
2198
2199#undef PerlIO_printf
6f9d8c32 2200int
760ac839 2201PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
2202{
2203 va_list ap;
2204 int result;
760ac839 2205 va_start(ap,fmt);
6f9d8c32 2206 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
2207 va_end(ap);
2208 return result;
2209}
2210
2211#undef PerlIO_stdoutf
6f9d8c32 2212int
760ac839 2213PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
2214{
2215 va_list ap;
2216 int result;
760ac839 2217 va_start(ap,fmt);
760ac839
LW
2218 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2219 va_end(ap);
2220 return result;
2221}
2222
2223#undef PerlIO_tmpfile
2224PerlIO *
c78749f2 2225PerlIO_tmpfile(void)
760ac839 2226{
6f9d8c32 2227 dTHX;
b1ef6e3b 2228 /* I have no idea how portable mkstemp() is ... */
6f9d8c32
NIS
2229 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2230 int fd = mkstemp(SvPVX(sv));
2231 PerlIO *f = NULL;
2232 if (fd >= 0)
2233 {
b1ef6e3b 2234 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
2235 if (f)
2236 {
9e353e3b 2237 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32
NIS
2238 }
2239 unlink(SvPVX(sv));
2240 SvREFCNT_dec(sv);
2241 }
2242 return f;
760ac839
LW
2243}
2244
6f9d8c32
NIS
2245#undef HAS_FSETPOS
2246#undef HAS_FGETPOS
2247
760ac839
LW
2248#endif /* USE_SFIO */
2249#endif /* PERLIO_IS_STDIO */
2250
9e353e3b
NIS
2251/*======================================================================================*/
2252/* Now some functions in terms of above which may be needed even if
2253 we are not in true PerlIO mode
2254 */
2255
760ac839
LW
2256#ifndef HAS_FSETPOS
2257#undef PerlIO_setpos
2258int
c78749f2 2259PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 2260{
6f9d8c32 2261 return PerlIO_seek(f,*pos,0);
760ac839 2262}
c411622e
PP
2263#else
2264#ifndef PERLIO_IS_STDIO
2265#undef PerlIO_setpos
2266int
c78749f2 2267PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 2268{
2d4389e4 2269#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2270 return fsetpos64(f, pos);
2271#else
c411622e 2272 return fsetpos(f, pos);
d9b3e12d 2273#endif
c411622e
PP
2274}
2275#endif
760ac839
LW
2276#endif
2277
2278#ifndef HAS_FGETPOS
2279#undef PerlIO_getpos
2280int
c78749f2 2281PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
2282{
2283 *pos = PerlIO_tell(f);
2284 return 0;
2285}
c411622e
PP
2286#else
2287#ifndef PERLIO_IS_STDIO
2288#undef PerlIO_getpos
2289int
c78749f2 2290PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 2291{
2d4389e4 2292#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2293 return fgetpos64(f, pos);
2294#else
c411622e 2295 return fgetpos(f, pos);
d9b3e12d 2296#endif
c411622e
PP
2297}
2298#endif
760ac839
LW
2299#endif
2300
2301#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2302
2303int
c78749f2 2304vprintf(char *pat, char *args)
662a7e3f
CS
2305{
2306 _doprnt(pat, args, stdout);
2307 return 0; /* wrong, but perl doesn't use the return value */
2308}
2309
2310int
c78749f2 2311vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
2312{
2313 _doprnt(pat, args, fd);
2314 return 0; /* wrong, but perl doesn't use the return value */
2315}
2316
2317#endif
2318
2319#ifndef PerlIO_vsprintf
6f9d8c32 2320int
8ac85365 2321PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
2322{
2323 int val = vsprintf(s, fmt, ap);
2324 if (n >= 0)
2325 {
8c86a920 2326 if (strlen(s) >= (STRLEN)n)
760ac839 2327 {
bf49b057
GS
2328 dTHX;
2329 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
2330 my_exit(1);
760ac839
LW
2331 }
2332 }
2333 return val;
2334}
2335#endif
2336
2337#ifndef PerlIO_sprintf
6f9d8c32 2338int
760ac839 2339PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
2340{
2341 va_list ap;
2342 int result;
760ac839 2343 va_start(ap,fmt);
760ac839
LW
2344 result = PerlIO_vsprintf(s, n, fmt, ap);
2345 va_end(ap);
2346 return result;
2347}
2348#endif
2349
c5be433b
GS
2350#endif /* !PERL_IMPLICIT_SYS */
2351