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