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