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