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