This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline.
[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
9e353e3b 1425PerlIO *
06da4f11 1426PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
8c86a920 1427{
9e353e3b 1428 PerlIO_funcs *tab = PerlIO_default_btm();
06da4f11 1429 PerlIO *f = (*tab->Open)(tab,path,mode);
9e353e3b
NIS
1430 if (f)
1431 {
06da4f11 1432 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
9e353e3b
NIS
1433 b->posn = 0;
1434 }
1435 return f;
1436}
1437
1438int
1439PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
1440{
1441 return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
1442}
1443
9e353e3b
NIS
1444/* This "flush" is akin to sfio's sync in that it handles files in either
1445 read or write state
1446*/
1447IV
1448PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1449{
9e353e3b
NIS
1450 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1451 int code = 0;
1452 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1453 {
1454 /* write() the buffer */
1455 STDCHAR *p = b->buf;
1456 int count;
1457 while (p < b->ptr)
1458 {
1459 count = PerlIO_write(PerlIONext(f),p,b->ptr - p);
1460 if (count > 0)
1461 {
1462 p += count;
1463 }
1464 else if (count < 0)
1465 {
1466 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1467 code = -1;
1468 break;
1469 }
1470 }
1471 b->posn += (p - b->buf);
1472 }
1473 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1474 {
9e353e3b
NIS
1475 /* Note position change */
1476 b->posn += (b->ptr - b->buf);
1477 if (b->ptr < b->end)
1478 {
1479 /* We did not consume all of it */
1480 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1481 {
1482 b->posn = PerlIO_tell(PerlIONext(f));
1483 }
1484 }
6f9d8c32 1485 }
9e353e3b
NIS
1486 b->ptr = b->end = b->buf;
1487 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1488 if (PerlIO_flush(PerlIONext(f)) != 0)
1489 code = -1;
1490 return code;
6f9d8c32
NIS
1491}
1492
06da4f11
NIS
1493IV
1494PerlIOBuf_fill(PerlIO *f)
1495{
1496 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1497 SSize_t avail;
1498 if (PerlIO_flush(f) != 0)
1499 return -1;
1500 b->ptr = b->end = b->buf;
1501 avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz);
1502 if (avail <= 0)
1503 {
1504 if (avail == 0)
1505 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1506 else
1507 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1508 return -1;
1509 }
1510 b->end = b->buf+avail;
1511 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1512 return 0;
1513}
1514
6f9d8c32 1515SSize_t
9e353e3b 1516PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1517{
9e353e3b 1518 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
6f9d8c32
NIS
1519 STDCHAR *buf = (STDCHAR *) vbuf;
1520 if (f)
1521 {
1522 Size_t got = 0;
9e353e3b 1523 if (!b->ptr)
06da4f11 1524 PerlIO_get_base(f);
9e353e3b 1525 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1526 return 0;
6f9d8c32
NIS
1527 while (count > 0)
1528 {
9e353e3b 1529 SSize_t avail = (b->end - b->ptr);
6f9d8c32
NIS
1530 if ((SSize_t) count < avail)
1531 avail = count;
1532 if (avail > 0)
1533 {
9e353e3b 1534 Copy(b->ptr,buf,avail,char);
6f9d8c32 1535 got += avail;
9e353e3b 1536 b->ptr += avail;
6f9d8c32
NIS
1537 count -= avail;
1538 buf += avail;
1539 }
9e353e3b 1540 if (count && (b->ptr >= b->end))
6f9d8c32 1541 {
06da4f11
NIS
1542 if (PerlIO_fill(f) != 0)
1543 break;
6f9d8c32
NIS
1544 }
1545 }
1546 return got;
1547 }
1548 return 0;
1549}
1550
9e353e3b
NIS
1551SSize_t
1552PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1553{
9e353e3b
NIS
1554 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1555 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1556 SSize_t unread = 0;
1557 SSize_t avail;
9e353e3b
NIS
1558 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1559 PerlIO_flush(f);
06da4f11
NIS
1560 if (!b->buf)
1561 PerlIO_get_base(f);
9e353e3b
NIS
1562 if (b->buf)
1563 {
1564 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1565 {
1566 avail = (b->ptr - b->buf);
1567 if (avail > (SSize_t) count)
1568 avail = count;
1569 b->ptr -= avail;
1570 }
1571 else
1572 {
1573 avail = b->bufsiz;
1574 if (avail > (SSize_t) count)
1575 avail = count;
1576 b->end = b->ptr + avail;
1577 }
1578 if (avail > 0)
1579 {
1580 buf -= avail;
1581 if (buf != b->ptr)
1582 {
1583 Copy(buf,b->ptr,avail,char);
1584 }
1585 count -= avail;
1586 unread += avail;
1587 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1588 }
1589 }
1590 return unread;
760ac839
LW
1591}
1592
9e353e3b
NIS
1593SSize_t
1594PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1595{
9e353e3b
NIS
1596 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1597 const STDCHAR *buf = (const STDCHAR *) vbuf;
1598 Size_t written = 0;
1599 if (!b->buf)
06da4f11 1600 PerlIO_get_base(f);
9e353e3b
NIS
1601 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1602 return 0;
1603 while (count > 0)
1604 {
1605 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1606 if ((SSize_t) count < avail)
1607 avail = count;
1608 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1609 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1610 {
1611 while (avail > 0)
1612 {
1613 int ch = *buf++;
1614 *(b->ptr)++ = ch;
1615 count--;
1616 avail--;
1617 written++;
1618 if (ch == '\n')
1619 {
1620 PerlIO_flush(f);
1621 break;
1622 }
1623 }
1624 }
1625 else
1626 {
1627 if (avail)
1628 {
1629 Copy(buf,b->ptr,avail,char);
1630 count -= avail;
1631 buf += avail;
1632 written += avail;
1633 b->ptr += avail;
1634 }
1635 }
1636 if (b->ptr >= (b->buf + b->bufsiz))
1637 PerlIO_flush(f);
1638 }
1639 return written;
1640}
1641
1642IV
1643PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1644{
1645 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
06da4f11 1646 int code = PerlIO_flush(f);
9e353e3b
NIS
1647 if (code == 0)
1648 {
1649 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1650 code = PerlIO_seek(PerlIONext(f),offset,whence);
1651 if (code == 0)
1652 {
1653 b->posn = PerlIO_tell(PerlIONext(f));
1654 }
1655 }
1656 return code;
1657}
1658
1659Off_t
1660PerlIOBuf_tell(PerlIO *f)
1661{
1662 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1663 Off_t posn = b->posn;
1664 if (b->buf)
1665 posn += (b->ptr - b->buf);
1666 return posn;
1667}
1668
1669IV
1670PerlIOBuf_close(PerlIO *f)
1671{
1672 IV code = PerlIOBase_close(f);
1673 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1674 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 1675 {
9e353e3b 1676 Safefree(b->buf);
6f9d8c32 1677 }
9e353e3b
NIS
1678 b->buf = NULL;
1679 b->ptr = b->end = b->buf;
1680 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1681 return code;
760ac839
LW
1682}
1683
760ac839 1684void
9e353e3b 1685PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 1686{
6f9d8c32
NIS
1687 if (f)
1688 {
9e353e3b 1689 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 1690 }
760ac839
LW
1691}
1692
760ac839 1693void
9e353e3b 1694PerlIOBuf_set_cnt(PerlIO *f, int cnt)
760ac839 1695{
9e353e3b
NIS
1696 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1697 dTHX;
1698 if (!b->buf)
06da4f11 1699 PerlIO_get_base(f);
9e353e3b
NIS
1700 b->ptr = b->end - cnt;
1701 assert(b->ptr >= b->buf);
1702}
1703
1704STDCHAR *
1705PerlIOBuf_get_ptr(PerlIO *f)
1706{
1707 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1708 if (!b->buf)
06da4f11 1709 PerlIO_get_base(f);
9e353e3b
NIS
1710 return b->ptr;
1711}
1712
05d1247b 1713SSize_t
9e353e3b
NIS
1714PerlIOBuf_get_cnt(PerlIO *f)
1715{
1716 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1717 if (!b->buf)
06da4f11 1718 PerlIO_get_base(f);
9e353e3b
NIS
1719 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1720 return (b->end - b->ptr);
1721 return 0;
1722}
1723
1724STDCHAR *
1725PerlIOBuf_get_base(PerlIO *f)
1726{
1727 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1728 if (!b->buf)
06da4f11
NIS
1729 {
1730 if (!b->bufsiz)
1731 b->bufsiz = 4096;
1732 New('B',b->buf,b->bufsiz,STDCHAR);
1733 if (!b->buf)
1734 {
1735 b->buf = (STDCHAR *)&b->oneword;
1736 b->bufsiz = sizeof(b->oneword);
1737 }
1738 b->ptr = b->buf;
1739 b->end = b->ptr;
1740 }
9e353e3b
NIS
1741 return b->buf;
1742}
1743
1744Size_t
1745PerlIOBuf_bufsiz(PerlIO *f)
1746{
1747 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1748 if (!b->buf)
06da4f11 1749 PerlIO_get_base(f);
9e353e3b
NIS
1750 return (b->end - b->buf);
1751}
1752
1753void
05d1247b 1754PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS
1755{
1756 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1757 if (!b->buf)
06da4f11 1758 PerlIO_get_base(f);
9e353e3b
NIS
1759 b->ptr = ptr;
1760 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 1761 {
9e353e3b
NIS
1762 dTHX;
1763 assert(PerlIO_get_cnt(f) == cnt);
1764 assert(b->ptr >= b->buf);
6f9d8c32 1765 }
9e353e3b 1766 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
1767}
1768
9e353e3b
NIS
1769PerlIO_funcs PerlIO_perlio = {
1770 "perlio",
1771 sizeof(PerlIOBuf),
1772 0,
1773 PerlIOBase_fileno,
1774 PerlIOBuf_fdopen,
1775 PerlIOBuf_open,
1776 PerlIOBase_reopen,
06da4f11
NIS
1777 PerlIOBase_pushed,
1778 PerlIOBase_noop_ok,
9e353e3b
NIS
1779 PerlIOBuf_read,
1780 PerlIOBuf_unread,
1781 PerlIOBuf_write,
1782 PerlIOBuf_seek,
1783 PerlIOBuf_tell,
1784 PerlIOBuf_close,
1785 PerlIOBuf_flush,
06da4f11 1786 PerlIOBuf_fill,
9e353e3b
NIS
1787 PerlIOBase_eof,
1788 PerlIOBase_error,
1789 PerlIOBase_clearerr,
1790 PerlIOBuf_setlinebuf,
1791 PerlIOBuf_get_base,
1792 PerlIOBuf_bufsiz,
1793 PerlIOBuf_get_ptr,
1794 PerlIOBuf_get_cnt,
1795 PerlIOBuf_set_ptrcnt,
1796};
1797
06da4f11
NIS
1798#ifdef HAS_MMAP
1799/*--------------------------------------------------------------------------------------*/
1800/* mmap as "buffer" layer */
1801
1802typedef struct
1803{
1804 PerlIOBuf base; /* PerlIOBuf stuff */
1805 Size_t len; /* mapped length */
1806 STDCHAR *bbuf; /* malloced buffer if map fails */
1807} PerlIOMmap;
1808
1809IV
1810PerlIOMmap_map(PerlIO *f)
1811{
1812 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1813 PerlIOBuf *b = &m->base;
1814 IV flags = PerlIOBase(f)->flags;
1815 IV code = 0;
1816 if (m->len)
1817 abort();
1818 if (flags & PERLIO_F_CANREAD)
1819 {
1820 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1821 int fd = PerlIO_fileno(f);
1822 struct stat st;
1823 code = fstat(fd,&st);
1824 if (code == 0 && S_ISREG(st.st_mode))
1825 {
1826 SSize_t len = st.st_size - b->posn;
1827 if (len > 0)
1828 {
1829 b->buf = (STDCHAR *) mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, b->posn);
06da4f11
NIS
1830 if (b->buf && b->buf != (STDCHAR *) -1)
1831 {
1832#if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
4a4a6116 1833 madvise((Mmap_t) b->buf, len, MADV_SEQUENTIAL);
06da4f11
NIS
1834#endif
1835 PerlIOBase(f)->flags = flags | PERLIO_F_RDBUF;
1836 b->end = b->buf+len;
1837 b->ptr = b->buf;
1838 m->len = len;
1839 }
1840 else
1841 {
1842 b->buf = NULL;
1843 }
1844 }
1845 else
1846 {
1847 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
1848 b->buf = NULL;
1849 b->ptr = b->end = b->ptr;
1850 code = -1;
1851 }
1852 }
1853 }
1854 return code;
1855}
1856
1857IV
1858PerlIOMmap_unmap(PerlIO *f)
1859{
1860 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
1861 PerlIOBuf *b = &m->base;
1862 IV code = 0;
1863 if (m->len)
1864 {
1865 if (b->buf)
1866 {
1867 code = munmap((Mmap_t) b->buf, m->len);
1868 b->buf = NULL;
1869 m->len = 0;
1870 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
1871 code = -1;
06da4f11
NIS
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 {
4a4a6116 1925 /* Loose the unwritable mapped buffer */
06da4f11
NIS
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 }
06da4f11
NIS
1979 return code;
1980}
1981
1982IV
1983PerlIOMmap_fill(PerlIO *f)
1984{
1985 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1986 IV code = PerlIO_flush(f);
06da4f11
NIS
1987 if (code == 0 && !b->buf)
1988 {
1989 code = PerlIOMmap_map(f);
06da4f11
NIS
1990 }
1991 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1992 {
1993 code = PerlIOBuf_fill(f);
06da4f11
NIS
1994 }
1995 return code;
1996}
1997
1998IV
1999PerlIOMmap_close(PerlIO *f)
2000{
2001 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2002 PerlIOBuf *b = &m->base;
2003 IV code = PerlIO_flush(f);
2004 if (m->bbuf)
2005 {
2006 b->buf = m->bbuf;
2007 m->bbuf = NULL;
2008 b->ptr = b->end = b->buf;
2009 }
2010 if (PerlIOBuf_close(f) != 0)
2011 code = -1;
06da4f11
NIS
2012 return code;
2013}
2014
2015
2016PerlIO_funcs PerlIO_mmap = {
2017 "mmap",
2018 sizeof(PerlIOMmap),
2019 0,
2020 PerlIOBase_fileno,
2021 PerlIOBuf_fdopen,
2022 PerlIOBuf_open,
2023 PerlIOBase_reopen,
2024 PerlIOBase_pushed,
2025 PerlIOBase_noop_ok,
2026 PerlIOBuf_read,
2027 PerlIOMmap_unread,
2028 PerlIOMmap_write,
2029 PerlIOBuf_seek,
2030 PerlIOBuf_tell,
2031 PerlIOBuf_close,
2032 PerlIOMmap_flush,
2033 PerlIOMmap_fill,
2034 PerlIOBase_eof,
2035 PerlIOBase_error,
2036 PerlIOBase_clearerr,
2037 PerlIOBuf_setlinebuf,
2038 PerlIOMmap_get_base,
2039 PerlIOBuf_bufsiz,
2040 PerlIOBuf_get_ptr,
2041 PerlIOBuf_get_cnt,
2042 PerlIOBuf_set_ptrcnt,
2043};
2044
2045#endif /* HAS_MMAP */
2046
2047
2048
9e353e3b
NIS
2049void
2050PerlIO_init(void)
760ac839 2051{
9e353e3b 2052 if (!_perlio)
6f9d8c32 2053 {
9e353e3b 2054 atexit(&PerlIO_cleanup);
6f9d8c32 2055 }
760ac839
LW
2056}
2057
9e353e3b
NIS
2058#undef PerlIO_stdin
2059PerlIO *
2060PerlIO_stdin(void)
2061{
2062 if (!_perlio)
f3862f8b 2063 PerlIO_stdstreams();
05d1247b 2064 return &_perlio[1];
9e353e3b
NIS
2065}
2066
2067#undef PerlIO_stdout
2068PerlIO *
2069PerlIO_stdout(void)
2070{
2071 if (!_perlio)
f3862f8b 2072 PerlIO_stdstreams();
05d1247b 2073 return &_perlio[2];
9e353e3b
NIS
2074}
2075
2076#undef PerlIO_stderr
2077PerlIO *
2078PerlIO_stderr(void)
2079{
2080 if (!_perlio)
f3862f8b 2081 PerlIO_stdstreams();
05d1247b 2082 return &_perlio[3];
9e353e3b
NIS
2083}
2084
2085/*--------------------------------------------------------------------------------------*/
2086
2087#undef PerlIO_getname
2088char *
2089PerlIO_getname(PerlIO *f, char *buf)
2090{
2091 dTHX;
2092 Perl_croak(aTHX_ "Don't know how to get file name");
2093 return NULL;
2094}
2095
2096
2097/*--------------------------------------------------------------------------------------*/
2098/* Functions which can be called on any kind of PerlIO implemented
2099 in terms of above
2100*/
2101
2102#undef PerlIO_getc
6f9d8c32 2103int
9e353e3b 2104PerlIO_getc(PerlIO *f)
760ac839 2105{
313ca112
NIS
2106 STDCHAR buf[1];
2107 SSize_t count = PerlIO_read(f,buf,1);
9e353e3b 2108 if (count == 1)
313ca112
NIS
2109 {
2110 return (unsigned char) buf[0];
2111 }
2112 return EOF;
2113}
2114
2115#undef PerlIO_ungetc
2116int
2117PerlIO_ungetc(PerlIO *f, int ch)
2118{
2119 if (ch != EOF)
2120 {
2121 STDCHAR buf = ch;
2122 if (PerlIO_unread(f,&buf,1) == 1)
2123 return ch;
2124 }
2125 return EOF;
760ac839
LW
2126}
2127
9e353e3b
NIS
2128#undef PerlIO_putc
2129int
2130PerlIO_putc(PerlIO *f, int ch)
760ac839 2131{
9e353e3b
NIS
2132 STDCHAR buf = ch;
2133 return PerlIO_write(f,&buf,1);
760ac839
LW
2134}
2135
9e353e3b 2136#undef PerlIO_puts
760ac839 2137int
9e353e3b 2138PerlIO_puts(PerlIO *f, const char *s)
760ac839 2139{
9e353e3b
NIS
2140 STRLEN len = strlen(s);
2141 return PerlIO_write(f,s,len);
760ac839
LW
2142}
2143
2144#undef PerlIO_rewind
2145void
c78749f2 2146PerlIO_rewind(PerlIO *f)
760ac839 2147{
6f9d8c32 2148 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 2149 PerlIO_clearerr(f);
6f9d8c32
NIS
2150}
2151
2152#undef PerlIO_vprintf
2153int
2154PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2155{
2156 dTHX;
bb9950b7 2157 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
2158 char *s;
2159 STRLEN len;
2160 sv_vcatpvf(sv, fmt, &ap);
2161 s = SvPV(sv,len);
bb9950b7 2162 return PerlIO_write(f,s,len);
760ac839
LW
2163}
2164
2165#undef PerlIO_printf
6f9d8c32 2166int
760ac839 2167PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
2168{
2169 va_list ap;
2170 int result;
760ac839 2171 va_start(ap,fmt);
6f9d8c32 2172 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
2173 va_end(ap);
2174 return result;
2175}
2176
2177#undef PerlIO_stdoutf
6f9d8c32 2178int
760ac839 2179PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
2180{
2181 va_list ap;
2182 int result;
760ac839 2183 va_start(ap,fmt);
760ac839
LW
2184 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2185 va_end(ap);
2186 return result;
2187}
2188
2189#undef PerlIO_tmpfile
2190PerlIO *
c78749f2 2191PerlIO_tmpfile(void)
760ac839 2192{
6f9d8c32 2193 dTHX;
b1ef6e3b 2194 /* I have no idea how portable mkstemp() is ... */
6f9d8c32
NIS
2195 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2196 int fd = mkstemp(SvPVX(sv));
2197 PerlIO *f = NULL;
2198 if (fd >= 0)
2199 {
b1ef6e3b 2200 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
2201 if (f)
2202 {
9e353e3b 2203 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32
NIS
2204 }
2205 unlink(SvPVX(sv));
2206 SvREFCNT_dec(sv);
2207 }
2208 return f;
760ac839
LW
2209}
2210
6f9d8c32
NIS
2211#undef HAS_FSETPOS
2212#undef HAS_FGETPOS
2213
760ac839
LW
2214#endif /* USE_SFIO */
2215#endif /* PERLIO_IS_STDIO */
2216
9e353e3b
NIS
2217/*======================================================================================*/
2218/* Now some functions in terms of above which may be needed even if
2219 we are not in true PerlIO mode
2220 */
2221
760ac839
LW
2222#ifndef HAS_FSETPOS
2223#undef PerlIO_setpos
2224int
c78749f2 2225PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 2226{
6f9d8c32 2227 return PerlIO_seek(f,*pos,0);
760ac839 2228}
c411622e
PP
2229#else
2230#ifndef PERLIO_IS_STDIO
2231#undef PerlIO_setpos
2232int
c78749f2 2233PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 2234{
2d4389e4 2235#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2236 return fsetpos64(f, pos);
2237#else
c411622e 2238 return fsetpos(f, pos);
d9b3e12d 2239#endif
c411622e
PP
2240}
2241#endif
760ac839
LW
2242#endif
2243
2244#ifndef HAS_FGETPOS
2245#undef PerlIO_getpos
2246int
c78749f2 2247PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
2248{
2249 *pos = PerlIO_tell(f);
2250 return 0;
2251}
c411622e
PP
2252#else
2253#ifndef PERLIO_IS_STDIO
2254#undef PerlIO_getpos
2255int
c78749f2 2256PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 2257{
2d4389e4 2258#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2259 return fgetpos64(f, pos);
2260#else
c411622e 2261 return fgetpos(f, pos);
d9b3e12d 2262#endif
c411622e
PP
2263}
2264#endif
760ac839
LW
2265#endif
2266
2267#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2268
2269int
c78749f2 2270vprintf(char *pat, char *args)
662a7e3f
CS
2271{
2272 _doprnt(pat, args, stdout);
2273 return 0; /* wrong, but perl doesn't use the return value */
2274}
2275
2276int
c78749f2 2277vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
2278{
2279 _doprnt(pat, args, fd);
2280 return 0; /* wrong, but perl doesn't use the return value */
2281}
2282
2283#endif
2284
2285#ifndef PerlIO_vsprintf
6f9d8c32 2286int
8ac85365 2287PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
2288{
2289 int val = vsprintf(s, fmt, ap);
2290 if (n >= 0)
2291 {
8c86a920 2292 if (strlen(s) >= (STRLEN)n)
760ac839 2293 {
bf49b057
GS
2294 dTHX;
2295 PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
2296 my_exit(1);
760ac839
LW
2297 }
2298 }
2299 return val;
2300}
2301#endif
2302
2303#ifndef PerlIO_sprintf
6f9d8c32 2304int
760ac839 2305PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
2306{
2307 va_list ap;
2308 int result;
760ac839 2309 va_start(ap,fmt);
760ac839
LW
2310 result = PerlIO_vsprintf(s, n, fmt, ap);
2311 va_end(ap);
2312 return result;
2313}
2314#endif
2315
c5be433b
GS
2316#endif /* !PERL_IMPLICIT_SYS */
2317