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