This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Win32/perlio Now just fails one io/argv.t test - lack
[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
ac27b0f5
NIS
31#ifndef PERLIO_LAYERS
32int
33PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
34{
95c70f20
NIS
35 if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw"))
36 {
37 return 0;
88b61e10 38 }
ac27b0f5 39 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names);
5a2dd417 40 /* NOTREACHED */
88b61e10 41 return -1;
ac27b0f5 42}
60382766
NIS
43
44int
45PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
46{
47/* This used to be contents of do_binmode in doio.c */
48#ifdef DOSISH
49# if defined(atarist) || defined(__MINT__)
50 if (!PerlIO_flush(fp)) {
51 if (mode & O_BINARY)
52 ((FILE*)fp)->_flag |= _IOBIN;
53 else
54 ((FILE*)fp)->_flag &= ~ _IOBIN;
55 return 1;
56 }
57 return 0;
58# else
59 if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
60# if defined(WIN32) && defined(__BORLANDC__)
61 /* The translation mode of the stream is maintained independent
62 * of the translation mode of the fd in the Borland RTL (heavy
63 * digging through their runtime sources reveal). User has to
64 * set the mode explicitly for the stream (though they don't
65 * document this anywhere). GSAR 97-5-24
66 */
67 PerlIO_seek(fp,0L,0);
68 if (mode & O_BINARY)
69 ((FILE*)fp)->flags |= _F_BIN;
70 else
71 ((FILE*)fp)->flags &= ~ _F_BIN;
72# endif
73 return 1;
74 }
75 else
76 return 0;
77# endif
78#else
79# if defined(USEMYBINMODE)
80 if (my_binmode(fp, iotype, mode) != FALSE)
81 return 1;
82 else
83 return 0;
84# else
85 return 1;
86# endif
87#endif
88}
89
90
91
92
ac27b0f5
NIS
93#endif
94
32e30700
GS
95#if !defined(PERL_IMPLICIT_SYS)
96
6f9d8c32 97#ifdef PERLIO_IS_STDIO
760ac839
LW
98
99void
8ac85365 100PerlIO_init(void)
760ac839 101{
6f9d8c32 102 /* Does nothing (yet) except force this file to be included
760ac839 103 in perl binary. That allows this file to force inclusion
6f9d8c32
NIS
104 of other functions that may be required by loadable
105 extensions e.g. for FileHandle::tmpfile
760ac839
LW
106 */
107}
108
33dcbb9a
PP
109#undef PerlIO_tmpfile
110PerlIO *
8ac85365 111PerlIO_tmpfile(void)
33dcbb9a
PP
112{
113 return tmpfile();
114}
115
760ac839
LW
116#else /* PERLIO_IS_STDIO */
117
118#ifdef USE_SFIO
119
120#undef HAS_FSETPOS
121#undef HAS_FGETPOS
122
6f9d8c32 123/* This section is just to make sure these functions
760ac839
LW
124 get pulled in from libsfio.a
125*/
126
127#undef PerlIO_tmpfile
128PerlIO *
c78749f2 129PerlIO_tmpfile(void)
760ac839
LW
130{
131 return sftmp(0);
132}
133
134void
c78749f2 135PerlIO_init(void)
760ac839 136{
6f9d8c32
NIS
137 /* Force this file to be included in perl binary. Which allows
138 * this file to force inclusion of other functions that may be
139 * required by loadable extensions e.g. for FileHandle::tmpfile
760ac839
LW
140 */
141
142 /* Hack
143 * sfio does its own 'autoflush' on stdout in common cases.
6f9d8c32 144 * Flush results in a lot of lseek()s to regular files and
760ac839
LW
145 * lot of small writes to pipes.
146 */
147 sfset(sfstdout,SF_SHARE,0);
148}
149
17c3b450 150#else /* USE_SFIO */
6f9d8c32 151/*======================================================================================*/
6f9d8c32 152/* Implement all the PerlIO interface ourselves.
9e353e3b 153 */
760ac839 154
76ced9ad
NIS
155#include "perliol.h"
156
b1ef6e3b 157/* We _MUST_ have <unistd.h> if we are using lseek() and may have large files */
02f66e2f
NIS
158#ifdef I_UNISTD
159#include <unistd.h>
160#endif
06da4f11
NIS
161#ifdef HAS_MMAP
162#include <sys/mman.h>
163#endif
164
f3862f8b 165#include "XSUB.h"
02f66e2f 166
88b61e10 167void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
6f9d8c32 168
6f9d8c32 169void
88b61e10 170PerlIO_debug(const char *fmt,...)
6f9d8c32
NIS
171{
172 static int dbg = 0;
88b61e10
NIS
173 va_list ap;
174 va_start(ap,fmt);
6f9d8c32
NIS
175 if (!dbg)
176 {
00b02797 177 char *s = PerlEnv_getenv("PERLIO_DEBUG");
6f9d8c32 178 if (s && *s)
00b02797 179 dbg = PerlLIO_open3(s,O_WRONLY|O_CREAT|O_APPEND,0666);
6f9d8c32
NIS
180 else
181 dbg = -1;
182 }
183 if (dbg > 0)
184 {
185 dTHX;
6f9d8c32
NIS
186 SV *sv = newSVpvn("",0);
187 char *s;
188 STRLEN len;
05d1247b
NIS
189 s = CopFILE(PL_curcop);
190 if (!s)
191 s = "(none)";
192 Perl_sv_catpvf(aTHX_ sv, "%s:%"IVdf" ", s, (IV)CopLINE(PL_curcop));
c7fc522f
NIS
193 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
194
6f9d8c32 195 s = SvPV(sv,len);
00b02797 196 PerlLIO_write(dbg,s,len);
6f9d8c32
NIS
197 SvREFCNT_dec(sv);
198 }
88b61e10 199 va_end(ap);
6f9d8c32
NIS
200}
201
9e353e3b
NIS
202/*--------------------------------------------------------------------------------------*/
203
9e353e3b
NIS
204/* Inner level routines */
205
b1ef6e3b 206/* Table of pointers to the PerlIO structs (malloc'ed) */
05d1247b
NIS
207PerlIO *_perlio = NULL;
208#define PERLIO_TABLE_SIZE 64
6f9d8c32 209
760ac839 210PerlIO *
6f9d8c32
NIS
211PerlIO_allocate(void)
212{
f3862f8b 213 /* Find a free slot in the table, allocating new table as necessary */
05d1247b 214 PerlIO **last = &_perlio;
6f9d8c32 215 PerlIO *f;
05d1247b 216 while ((f = *last))
6f9d8c32 217 {
05d1247b
NIS
218 int i;
219 last = (PerlIO **)(f);
220 for (i=1; i < PERLIO_TABLE_SIZE; i++)
6f9d8c32 221 {
05d1247b 222 if (!*++f)
6f9d8c32 223 {
6f9d8c32
NIS
224 return f;
225 }
6f9d8c32 226 }
6f9d8c32 227 }
05d1247b
NIS
228 Newz('I',f,PERLIO_TABLE_SIZE,PerlIO);
229 if (!f)
230 return NULL;
231 *last = f;
232 return f+1;
233}
234
235void
236PerlIO_cleantable(PerlIO **tablep)
237{
238 PerlIO *table = *tablep;
239 if (table)
240 {
241 int i;
242 PerlIO_cleantable((PerlIO **) &(table[0]));
243 for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
244 {
245 PerlIO *f = table+i;
60382766 246 if (*f)
3789aae2
NIS
247 {
248 PerlIO_close(f);
249 }
05d1247b
NIS
250 }
251 Safefree(table);
252 *tablep = NULL;
253 }
254}
255
4a4a6116
NIS
256HV *PerlIO_layer_hv;
257AV *PerlIO_layer_av;
258
05d1247b
NIS
259void
260PerlIO_cleanup(void)
261{
262 PerlIO_cleantable(&_perlio);
6f9d8c32
NIS
263}
264
9e353e3b
NIS
265void
266PerlIO_pop(PerlIO *f)
760ac839 267{
9e353e3b
NIS
268 PerlIOl *l = *f;
269 if (l)
6f9d8c32 270 {
06da4f11 271 (*l->tab->Popped)(f);
9e353e3b
NIS
272 *f = l->next;
273 Safefree(l);
6f9d8c32 274 }
6f9d8c32
NIS
275}
276
9e353e3b 277/*--------------------------------------------------------------------------------------*/
b931b1d9 278/* XS Interface for perl code */
9e353e3b 279
b931b1d9 280XS(XS_perlio_import)
f3862f8b
NIS
281{
282 dXSARGS;
283 GV *gv = CvGV(cv);
284 char *s = GvNAME(gv);
285 STRLEN l = GvNAMELEN(gv);
286 PerlIO_debug("%.*s\n",(int) l,s);
287 XSRETURN_EMPTY;
288}
289
b931b1d9 290XS(XS_perlio_unimport)
f3862f8b
NIS
291{
292 dXSARGS;
293 GV *gv = CvGV(cv);
294 char *s = GvNAME(gv);
295 STRLEN l = GvNAMELEN(gv);
296 PerlIO_debug("%.*s\n",(int) l,s);
297 XSRETURN_EMPTY;
298}
299
f3862f8b 300SV *
ac27b0f5 301PerlIO_find_layer(const char *name, STRLEN len)
f3862f8b
NIS
302{
303 dTHX;
304 SV **svp;
305 SV *sv;
306 if (len <= 0)
307 len = strlen(name);
308 svp = hv_fetch(PerlIO_layer_hv,name,len,0);
309 if (svp && (sv = *svp) && SvROK(sv))
310 return *svp;
311 return NULL;
312}
313
b13b2135
NIS
314
315static int
316perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
317{
318 if (SvROK(sv))
319 {
b931b1d9 320 IO *io = GvIOn((GV *)SvRV(sv));
b13b2135
NIS
321 PerlIO *ifp = IoIFP(io);
322 PerlIO *ofp = IoOFP(io);
323 AV *av = (AV *) mg->mg_obj;
324 Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
325 }
326 return 0;
327}
328
329static int
330perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
331{
332 if (SvROK(sv))
333 {
b931b1d9 334 IO *io = GvIOn((GV *)SvRV(sv));
b13b2135
NIS
335 PerlIO *ifp = IoIFP(io);
336 PerlIO *ofp = IoOFP(io);
337 AV *av = (AV *) mg->mg_obj;
338 Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
339 }
340 return 0;
341}
342
343static int
344perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
345{
346 Perl_warn(aTHX_ "clear %_",sv);
347 return 0;
348}
349
350static int
351perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
352{
353 Perl_warn(aTHX_ "free %_",sv);
354 return 0;
355}
356
357MGVTBL perlio_vtab = {
358 perlio_mg_get,
359 perlio_mg_set,
360 NULL, /* len */
361 NULL,
362 perlio_mg_free
363};
364
365XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
366{
367 dXSARGS;
368 SV *sv = SvRV(ST(1));
369 AV *av = newAV();
370 MAGIC *mg;
371 int count = 0;
372 int i;
373 sv_magic(sv, (SV *)av, '~', NULL, 0);
374 SvRMAGICAL_off(sv);
375 mg = mg_find(sv,'~');
376 mg->mg_virtual = &perlio_vtab;
377 mg_magical(sv);
378 Perl_warn(aTHX_ "attrib %_",sv);
379 for (i=2; i < items; i++)
380 {
381 STRLEN len;
ac27b0f5 382 const char *name = SvPV(ST(i),len);
b13b2135
NIS
383 SV *layer = PerlIO_find_layer(name,len);
384 if (layer)
385 {
386 av_push(av,SvREFCNT_inc(layer));
387 }
388 else
389 {
390 ST(count) = ST(i);
391 count++;
392 }
393 }
394 SvREFCNT_dec(av);
395 XSRETURN(count);
396}
397
f3862f8b
NIS
398void
399PerlIO_define_layer(PerlIO_funcs *tab)
400{
401 dTHX;
b931b1d9 402 HV *stash = gv_stashpv("perlio::Layer", TRUE);
e7778b43 403 SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
f3862f8b
NIS
404 hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
405}
406
407PerlIO_funcs *
408PerlIO_default_layer(I32 n)
409{
410 dTHX;
411 SV **svp;
412 SV *layer;
413 PerlIO_funcs *tab = &PerlIO_stdio;
414 int len;
415 if (!PerlIO_layer_hv)
416 {
ac27b0f5 417 const char *s = PerlEnv_getenv("PERLIO");
b931b1d9
NIS
418 newXS("perlio::import",XS_perlio_import,__FILE__);
419 newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
420#if 0
b13b2135 421 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
b931b1d9
NIS
422#endif
423 PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
424 PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
f3862f8b 425 PerlIO_define_layer(&PerlIO_unix);
f3862f8b
NIS
426 PerlIO_define_layer(&PerlIO_perlio);
427 PerlIO_define_layer(&PerlIO_stdio);
66ecd56b 428 PerlIO_define_layer(&PerlIO_crlf);
06da4f11
NIS
429#ifdef HAS_MMAP
430 PerlIO_define_layer(&PerlIO_mmap);
431#endif
f3862f8b
NIS
432 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
433 if (s)
434 {
435 while (*s)
436 {
00b02797 437 while (*s && isSPACE((unsigned char)*s))
f3862f8b
NIS
438 s++;
439 if (*s)
440 {
ac27b0f5 441 const char *e = s;
f3862f8b 442 SV *layer;
00b02797 443 while (*e && !isSPACE((unsigned char)*e))
f3862f8b 444 e++;
ac27b0f5
NIS
445 if (*s == ':')
446 s++;
f3862f8b
NIS
447 layer = PerlIO_find_layer(s,e-s);
448 if (layer)
449 {
450 PerlIO_debug("Pushing %.*s\n",(e-s),s);
451 av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
452 }
453 else
ef0f9817 454 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
f3862f8b
NIS
455 s = e;
456 }
457 }
458 }
459 }
460 len = av_len(PerlIO_layer_av);
461 if (len < 1)
462 {
463 if (PerlIO_stdio.Set_ptrcnt)
464 {
465 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
466 }
467 else
468 {
469 av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
470 }
471 len = av_len(PerlIO_layer_av);
472 }
473 if (n < 0)
474 n += len+1;
475 svp = av_fetch(PerlIO_layer_av,n,0);
476 if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer))))
477 {
e7778b43 478 tab = INT2PTR(PerlIO_funcs *, SvIV(layer));
f3862f8b
NIS
479 }
480 /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */
481 return tab;
482}
483
60382766
NIS
484#define PerlIO_default_top() PerlIO_default_layer(-1)
485#define PerlIO_default_btm() PerlIO_default_layer(0)
486
487void
488PerlIO_stdstreams()
489{
490 if (!_perlio)
491 {
492 PerlIO_allocate();
493 PerlIO_fdopen(0,"Ir");
494 PerlIO_fdopen(1,"Iw");
495 PerlIO_fdopen(2,"Iw");
496 }
497}
498
499PerlIO *
500PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
501{
502 PerlIOl *l = NULL;
503 Newc('L',l,tab->size,char,PerlIOl);
504 if (l)
505 {
506 Zero(l,tab->size,char);
507 l->next = *f;
508 l->tab = tab;
509 *f = l;
510 if ((*l->tab->Pushed)(f,mode) != 0)
511 {
512 PerlIO_pop(f);
513 return NULL;
514 }
515 }
516 return f;
517}
518
ac27b0f5
NIS
519int
520PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
521{
522 if (names)
523 {
524 const char *s = names;
525 while (*s)
526 {
527 while (isSPACE(*s))
528 s++;
529 if (*s == ':')
530 s++;
531 if (*s)
532 {
533 const char *e = s;
534 while (*e && *e != ':' && !isSPACE(*e))
535 e++;
536 if (e > s)
537 {
60382766 538 if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
ac27b0f5 539 {
60382766
NIS
540 /* Pop back to bottom layer */
541 if (PerlIONext(f))
ac27b0f5 542 {
60382766
NIS
543 PerlIO_flush(f);
544 while (PerlIONext(f))
545 {
546 PerlIO_pop(f);
547 }
ac27b0f5
NIS
548 }
549 }
550 else
60382766
NIS
551 {
552 SV *layer = PerlIO_find_layer(s,e-s);
553 if (layer)
554 {
555 PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
556 if (tab)
557 {
558 PerlIO *new = PerlIO_push(f,tab,mode);
559 if (!new)
560 return -1;
561 }
562 }
563 else
564 Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
565 }
ac27b0f5
NIS
566 }
567 s = e;
568 }
569 }
570 }
571 return 0;
572}
573
f3862f8b 574
9e353e3b 575
60382766
NIS
576/*--------------------------------------------------------------------------------------*/
577/* Given the abstraction above the public API functions */
578
579int
580PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
76ced9ad 581{
60382766 582 if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
76ced9ad 583 {
60382766
NIS
584 PerlIO *top = fp;
585 PerlIOl *l;
586 while (l = *top)
76ced9ad 587 {
60382766
NIS
588 if (PerlIOBase(top)->tab == &PerlIO_crlf)
589 {
590 PerlIO_flush(top);
591 PerlIO_pop(top);
592 break;
593 }
594 top = PerlIONext(top);
76ced9ad
NIS
595 }
596 }
60382766 597 return PerlIO_apply_layers(aTHX_ fp, NULL, names) == 0 ? TRUE : FALSE;
76ced9ad
NIS
598}
599
b931b1d9
NIS
600#undef PerlIO_close
601int
602PerlIO_close(PerlIO *f)
603{
604 int code = (*PerlIOBase(f)->tab->Close)(f);
605 while (*f)
606 {
607 PerlIO_pop(f);
608 }
609 return code;
610}
611
612#undef PerlIO_fileno
613int
614PerlIO_fileno(PerlIO *f)
615{
616 return (*PerlIOBase(f)->tab->Fileno)(f);
617}
618
619
620
9e353e3b
NIS
621#undef PerlIO_fdopen
622PerlIO *
623PerlIO_fdopen(int fd, const char *mode)
624{
625 PerlIO_funcs *tab = PerlIO_default_top();
f3862f8b
NIS
626 if (!_perlio)
627 PerlIO_stdstreams();
06da4f11 628 return (*tab->Fdopen)(tab,fd,mode);
9e353e3b
NIS
629}
630
6f9d8c32
NIS
631#undef PerlIO_open
632PerlIO *
633PerlIO_open(const char *path, const char *mode)
634{
9e353e3b 635 PerlIO_funcs *tab = PerlIO_default_top();
f3862f8b
NIS
636 if (!_perlio)
637 PerlIO_stdstreams();
06da4f11 638 return (*tab->Open)(tab,path,mode);
6f9d8c32
NIS
639}
640
9e353e3b
NIS
641#undef PerlIO_reopen
642PerlIO *
643PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
6f9d8c32 644{
9e353e3b 645 if (f)
6f9d8c32 646 {
9e353e3b
NIS
647 PerlIO_flush(f);
648 if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
649 {
06da4f11
NIS
650 if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
651 return f;
9e353e3b
NIS
652 }
653 return NULL;
6f9d8c32 654 }
9e353e3b
NIS
655 else
656 return PerlIO_open(path,mode);
760ac839
LW
657}
658
9e353e3b
NIS
659#undef PerlIO_read
660SSize_t
661PerlIO_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 662{
9e353e3b 663 return (*PerlIOBase(f)->tab->Read)(f,vbuf,count);
760ac839
LW
664}
665
313ca112
NIS
666#undef PerlIO_unread
667SSize_t
668PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 669{
313ca112 670 return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count);
760ac839
LW
671}
672
9e353e3b
NIS
673#undef PerlIO_write
674SSize_t
675PerlIO_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 676{
9e353e3b 677 return (*PerlIOBase(f)->tab->Write)(f,vbuf,count);
760ac839
LW
678}
679
9e353e3b 680#undef PerlIO_seek
6f9d8c32 681int
9e353e3b 682PerlIO_seek(PerlIO *f, Off_t offset, int whence)
760ac839 683{
9e353e3b 684 return (*PerlIOBase(f)->tab->Seek)(f,offset,whence);
760ac839
LW
685}
686
9e353e3b
NIS
687#undef PerlIO_tell
688Off_t
689PerlIO_tell(PerlIO *f)
760ac839 690{
9e353e3b 691 return (*PerlIOBase(f)->tab->Tell)(f);
760ac839
LW
692}
693
9e353e3b 694#undef PerlIO_flush
6f9d8c32 695int
9e353e3b 696PerlIO_flush(PerlIO *f)
760ac839 697{
6f9d8c32
NIS
698 if (f)
699 {
9e353e3b 700 return (*PerlIOBase(f)->tab->Flush)(f);
6f9d8c32 701 }
9e353e3b 702 else
6f9d8c32 703 {
05d1247b 704 PerlIO **table = &_perlio;
9e353e3b 705 int code = 0;
05d1247b 706 while ((f = *table))
6f9d8c32 707 {
05d1247b
NIS
708 int i;
709 table = (PerlIO **)(f++);
710 for (i=1; i < PERLIO_TABLE_SIZE; i++)
9e353e3b
NIS
711 {
712 if (*f && PerlIO_flush(f) != 0)
713 code = -1;
05d1247b 714 f++;
9e353e3b 715 }
6f9d8c32 716 }
9e353e3b 717 return code;
6f9d8c32 718 }
760ac839
LW
719}
720
06da4f11
NIS
721#undef PerlIO_fill
722int
723PerlIO_fill(PerlIO *f)
724{
725 return (*PerlIOBase(f)->tab->Fill)(f);
726}
727
f3862f8b
NIS
728#undef PerlIO_isutf8
729int
730PerlIO_isutf8(PerlIO *f)
731{
732 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
733}
734
9e353e3b 735#undef PerlIO_eof
6f9d8c32 736int
9e353e3b 737PerlIO_eof(PerlIO *f)
760ac839 738{
9e353e3b
NIS
739 return (*PerlIOBase(f)->tab->Eof)(f);
740}
741
742#undef PerlIO_error
743int
744PerlIO_error(PerlIO *f)
745{
746 return (*PerlIOBase(f)->tab->Error)(f);
747}
748
749#undef PerlIO_clearerr
750void
751PerlIO_clearerr(PerlIO *f)
752{
753 (*PerlIOBase(f)->tab->Clearerr)(f);
754}
755
756#undef PerlIO_setlinebuf
757void
758PerlIO_setlinebuf(PerlIO *f)
759{
760 (*PerlIOBase(f)->tab->Setlinebuf)(f);
761}
762
763#undef PerlIO_has_base
764int
765PerlIO_has_base(PerlIO *f)
766{
767 if (f && *f)
6f9d8c32 768 {
9e353e3b 769 return (PerlIOBase(f)->tab->Get_base != NULL);
6f9d8c32 770 }
9e353e3b 771 return 0;
760ac839
LW
772}
773
9e353e3b
NIS
774#undef PerlIO_fast_gets
775int
776PerlIO_fast_gets(PerlIO *f)
760ac839 777{
9e353e3b 778 if (f && *f)
6f9d8c32 779 {
c7fc522f
NIS
780 PerlIOl *l = PerlIOBase(f);
781 return (l->tab->Set_ptrcnt != NULL);
6f9d8c32 782 }
9e353e3b
NIS
783 return 0;
784}
785
786#undef PerlIO_has_cntptr
787int
788PerlIO_has_cntptr(PerlIO *f)
789{
790 if (f && *f)
791 {
792 PerlIO_funcs *tab = PerlIOBase(f)->tab;
793 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
794 }
795 return 0;
796}
797
798#undef PerlIO_canset_cnt
799int
800PerlIO_canset_cnt(PerlIO *f)
801{
802 if (f && *f)
803 {
c7fc522f
NIS
804 PerlIOl *l = PerlIOBase(f);
805 return (l->tab->Set_ptrcnt != NULL);
9e353e3b 806 }
c7fc522f 807 return 0;
760ac839
LW
808}
809
810#undef PerlIO_get_base
888911fc 811STDCHAR *
a20bf0c3 812PerlIO_get_base(PerlIO *f)
760ac839 813{
9e353e3b
NIS
814 return (*PerlIOBase(f)->tab->Get_base)(f);
815}
816
817#undef PerlIO_get_bufsiz
818int
819PerlIO_get_bufsiz(PerlIO *f)
820{
821 return (*PerlIOBase(f)->tab->Get_bufsiz)(f);
822}
823
824#undef PerlIO_get_ptr
825STDCHAR *
826PerlIO_get_ptr(PerlIO *f)
827{
828 return (*PerlIOBase(f)->tab->Get_ptr)(f);
829}
830
831#undef PerlIO_get_cnt
05d1247b 832int
9e353e3b
NIS
833PerlIO_get_cnt(PerlIO *f)
834{
835 return (*PerlIOBase(f)->tab->Get_cnt)(f);
836}
837
838#undef PerlIO_set_cnt
839void
05d1247b 840PerlIO_set_cnt(PerlIO *f,int cnt)
9e353e3b 841{
f3862f8b 842 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt);
9e353e3b
NIS
843}
844
845#undef PerlIO_set_ptrcnt
846void
05d1247b 847PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
9e353e3b 848{
f3862f8b 849 (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
9e353e3b
NIS
850}
851
852/*--------------------------------------------------------------------------------------*/
853/* "Methods" of the "base class" */
854
855IV
856PerlIOBase_fileno(PerlIO *f)
857{
858 return PerlIO_fileno(PerlIONext(f));
859}
860
76ced9ad
NIS
861IV
862PerlIOBase_pushed(PerlIO *f, const char *mode)
9e353e3b 863{
76ced9ad
NIS
864 PerlIOl *l = PerlIOBase(f);
865 l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
866 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
867 if (mode)
6f9d8c32 868 {
76ced9ad 869 switch (*mode++)
06da4f11 870 {
76ced9ad
NIS
871 case 'r':
872 l->flags = PERLIO_F_CANREAD;
873 break;
874 case 'a':
875 l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE;
876 break;
877 case 'w':
878 l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE;
879 break;
880 default:
881 errno = EINVAL;
882 return -1;
883 }
884 while (*mode)
885 {
886 switch (*mode++)
887 {
888 case '+':
889 l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE;
890 break;
891 case 'b':
892 l->flags |= PERLIO_F_BINARY;
893 break;
894 default:
895 errno = EINVAL;
896 return -1;
897 }
06da4f11 898 }
6f9d8c32 899 }
76ced9ad
NIS
900 else
901 {
902 if (l->next)
903 {
904 l->flags |= l->next->flags &
905 (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
906 PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY);
907 }
908 }
909 return 0;
910}
911
912IV
913PerlIOBase_popped(PerlIO *f)
914{
915 return 0;
760ac839
LW
916}
917
9e353e3b
NIS
918SSize_t
919PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
920{
921 Off_t old = PerlIO_tell(f);
922 if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
923 {
924 Off_t new = PerlIO_tell(f);
925 return old - new;
926 }
927 return 0;
928}
929
930IV
06da4f11 931PerlIOBase_noop_ok(PerlIO *f)
9e353e3b
NIS
932{
933 return 0;
934}
935
936IV
06da4f11
NIS
937PerlIOBase_noop_fail(PerlIO *f)
938{
939 return -1;
940}
941
942IV
9e353e3b
NIS
943PerlIOBase_close(PerlIO *f)
944{
945 IV code = 0;
946 if (PerlIO_flush(f) != 0)
947 code = -1;
948 if (PerlIO_close(PerlIONext(f)) != 0)
949 code = -1;
950 PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN);
951 return code;
952}
953
954IV
955PerlIOBase_eof(PerlIO *f)
956{
957 if (f && *f)
958 {
959 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
960 }
961 return 1;
962}
963
964IV
965PerlIOBase_error(PerlIO *f)
966{
967 if (f && *f)
968 {
969 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
970 }
971 return 1;
972}
973
974void
975PerlIOBase_clearerr(PerlIO *f)
976{
977 if (f && *f)
978 {
979 PerlIOBase(f)->flags &= ~PERLIO_F_ERROR;
980 }
981}
982
983void
984PerlIOBase_setlinebuf(PerlIO *f)
985{
986
987}
988
9e353e3b
NIS
989/*--------------------------------------------------------------------------------------*/
990/* Bottom-most level for UNIX-like case */
991
992typedef struct
993{
994 struct _PerlIO base; /* The generic part */
995 int fd; /* UNIX like file descriptor */
996 int oflags; /* open/fcntl flags */
997} PerlIOUnix;
998
6f9d8c32 999int
9e353e3b 1000PerlIOUnix_oflags(const char *mode)
760ac839 1001{
9e353e3b
NIS
1002 int oflags = -1;
1003 switch(*mode)
1004 {
1005 case 'r':
1006 oflags = O_RDONLY;
1007 if (*++mode == '+')
1008 {
1009 oflags = O_RDWR;
1010 mode++;
1011 }
1012 break;
1013
1014 case 'w':
1015 oflags = O_CREAT|O_TRUNC;
1016 if (*++mode == '+')
1017 {
1018 oflags |= O_RDWR;
1019 mode++;
1020 }
1021 else
1022 oflags |= O_WRONLY;
1023 break;
1024
1025 case 'a':
1026 oflags = O_CREAT|O_APPEND;
1027 if (*++mode == '+')
1028 {
1029 oflags |= O_RDWR;
1030 mode++;
1031 }
1032 else
1033 oflags |= O_WRONLY;
1034 break;
1035 }
83b075c3
NIS
1036 if (*mode == 'b')
1037 {
1038 oflags |= O_BINARY;
60382766
NIS
1039 mode++;
1040 }
99efab12
NIS
1041 /* Always open in binary mode */
1042 oflags |= O_BINARY;
9e353e3b 1043 if (*mode || oflags == -1)
6f9d8c32 1044 {
9e353e3b
NIS
1045 errno = EINVAL;
1046 oflags = -1;
6f9d8c32 1047 }
9e353e3b
NIS
1048 return oflags;
1049}
1050
1051IV
1052PerlIOUnix_fileno(PerlIO *f)
1053{
1054 return PerlIOSelf(f,PerlIOUnix)->fd;
1055}
1056
1057PerlIO *
06da4f11 1058PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
1059{
1060 PerlIO *f = NULL;
c7fc522f
NIS
1061 if (*mode == 'I')
1062 mode++;
9e353e3b
NIS
1063 if (fd >= 0)
1064 {
1065 int oflags = PerlIOUnix_oflags(mode);
1066 if (oflags != -1)
1067 {
06da4f11 1068 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
9e353e3b
NIS
1069 s->fd = fd;
1070 s->oflags = oflags;
1071 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1072 }
1073 }
1074 return f;
1075}
1076
1077PerlIO *
06da4f11 1078PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
1079{
1080 PerlIO *f = NULL;
1081 int oflags = PerlIOUnix_oflags(mode);
1082 if (oflags != -1)
1083 {
00b02797 1084 int fd = PerlLIO_open3(path,oflags,0666);
9e353e3b
NIS
1085 if (fd >= 0)
1086 {
06da4f11 1087 PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix);
9e353e3b
NIS
1088 s->fd = fd;
1089 s->oflags = oflags;
1090 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1091 }
1092 }
1093 return f;
760ac839
LW
1094}
1095
760ac839 1096int
9e353e3b 1097PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f)
760ac839 1098{
9e353e3b
NIS
1099 PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
1100 int oflags = PerlIOUnix_oflags(mode);
1101 if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
1102 (*PerlIOBase(f)->tab->Close)(f);
1103 if (oflags != -1)
1104 {
00b02797 1105 int fd = PerlLIO_open3(path,oflags,0666);
9e353e3b
NIS
1106 if (fd >= 0)
1107 {
1108 s->fd = fd;
1109 s->oflags = oflags;
1110 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
1111 return 0;
1112 }
1113 }
1114 return -1;
1115}
1116
1117SSize_t
1118PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count)
1119{
1120 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
8f24bd79
NIS
1121 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
1122 return 0;
9e353e3b
NIS
1123 while (1)
1124 {
00b02797 1125 SSize_t len = PerlLIO_read(fd,vbuf,count);
9e353e3b 1126 if (len >= 0 || errno != EINTR)
06da4f11
NIS
1127 {
1128 if (len < 0)
1129 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1130 else if (len == 0 && count != 0)
1131 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1132 return len;
1133 }
9e353e3b
NIS
1134 }
1135}
1136
1137SSize_t
1138PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count)
1139{
1140 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1141 while (1)
1142 {
00b02797 1143 SSize_t len = PerlLIO_write(fd,vbuf,count);
9e353e3b 1144 if (len >= 0 || errno != EINTR)
06da4f11
NIS
1145 {
1146 if (len < 0)
1147 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1148 return len;
1149 }
9e353e3b
NIS
1150 }
1151}
1152
1153IV
1154PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence)
1155{
00b02797 1156 Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence);
06da4f11 1157 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
9e353e3b
NIS
1158 return (new == (Off_t) -1) ? -1 : 0;
1159}
1160
1161Off_t
1162PerlIOUnix_tell(PerlIO *f)
1163{
00b02797 1164 return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR);
9e353e3b
NIS
1165}
1166
1167IV
1168PerlIOUnix_close(PerlIO *f)
1169{
1170 int fd = PerlIOSelf(f,PerlIOUnix)->fd;
1171 int code = 0;
00b02797 1172 while (PerlLIO_close(fd) != 0)
9e353e3b
NIS
1173 {
1174 if (errno != EINTR)
1175 {
1176 code = -1;
1177 break;
1178 }
1179 }
1180 if (code == 0)
1181 {
1182 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
1183 }
1184 return code;
1185}
1186
1187PerlIO_funcs PerlIO_unix = {
1188 "unix",
1189 sizeof(PerlIOUnix),
1190 0,
1191 PerlIOUnix_fileno,
1192 PerlIOUnix_fdopen,
1193 PerlIOUnix_open,
1194 PerlIOUnix_reopen,
06da4f11
NIS
1195 PerlIOBase_pushed,
1196 PerlIOBase_noop_ok,
9e353e3b
NIS
1197 PerlIOUnix_read,
1198 PerlIOBase_unread,
1199 PerlIOUnix_write,
1200 PerlIOUnix_seek,
1201 PerlIOUnix_tell,
1202 PerlIOUnix_close,
76ced9ad
NIS
1203 PerlIOBase_noop_ok, /* flush */
1204 PerlIOBase_noop_fail, /* fill */
9e353e3b
NIS
1205 PerlIOBase_eof,
1206 PerlIOBase_error,
1207 PerlIOBase_clearerr,
1208 PerlIOBase_setlinebuf,
1209 NULL, /* get_base */
1210 NULL, /* get_bufsiz */
1211 NULL, /* get_ptr */
1212 NULL, /* get_cnt */
1213 NULL, /* set_ptrcnt */
1214};
1215
1216/*--------------------------------------------------------------------------------------*/
1217/* stdio as a layer */
1218
1219typedef struct
1220{
1221 struct _PerlIO base;
1222 FILE * stdio; /* The stream */
1223} PerlIOStdio;
1224
1225IV
1226PerlIOStdio_fileno(PerlIO *f)
1227{
1228 return fileno(PerlIOSelf(f,PerlIOStdio)->stdio);
1229}
1230
1231
1232PerlIO *
06da4f11 1233PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
9e353e3b
NIS
1234{
1235 PerlIO *f = NULL;
c7fc522f
NIS
1236 int init = 0;
1237 if (*mode == 'I')
1238 {
1239 init = 1;
1240 mode++;
1241 }
9e353e3b
NIS
1242 if (fd >= 0)
1243 {
c7fc522f
NIS
1244 FILE *stdio = NULL;
1245 if (init)
1246 {
1247 switch(fd)
1248 {
1249 case 0:
1250 stdio = stdin;
1251 break;
1252 case 1:
1253 stdio = stdout;
1254 break;
1255 case 2:
1256 stdio = stderr;
1257 break;
1258 }
1259 }
1260 else
1261 stdio = fdopen(fd,mode);
9e353e3b
NIS
1262 if (stdio)
1263 {
06da4f11 1264 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1265 s->stdio = stdio;
1266 }
1267 }
1268 return f;
1269}
1270
1271#undef PerlIO_importFILE
1272PerlIO *
1273PerlIO_importFILE(FILE *stdio, int fl)
1274{
1275 PerlIO *f = NULL;
1276 if (stdio)
1277 {
1278 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio);
1279 s->stdio = stdio;
1280 }
1281 return f;
1282}
1283
1284PerlIO *
06da4f11 1285PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
9e353e3b
NIS
1286{
1287 PerlIO *f = NULL;
1288 FILE *stdio = fopen(path,mode);
1289 if (stdio)
1290 {
06da4f11 1291 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio);
9e353e3b
NIS
1292 s->stdio = stdio;
1293 }
1294 return f;
760ac839
LW
1295}
1296
6f9d8c32 1297int
9e353e3b
NIS
1298PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f)
1299{
1300 PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
1301 FILE *stdio = freopen(path,mode,s->stdio);
1302 if (!s->stdio)
1303 return -1;
1304 s->stdio = stdio;
1305 return 0;
1306}
1307
1308SSize_t
1309PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count)
1310{
1311 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
c7fc522f 1312 SSize_t got = 0;
9e353e3b
NIS
1313 if (count == 1)
1314 {
1315 STDCHAR *buf = (STDCHAR *) vbuf;
1316 /* Perl is expecting PerlIO_getc() to fill the buffer
1317 * Linux's stdio does not do that for fread()
1318 */
1319 int ch = fgetc(s);
1320 if (ch != EOF)
1321 {
1322 *buf = ch;
c7fc522f 1323 got = 1;
9e353e3b 1324 }
9e353e3b 1325 }
c7fc522f
NIS
1326 else
1327 got = fread(vbuf,1,count,s);
1328 return got;
9e353e3b
NIS
1329}
1330
1331SSize_t
1332PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count)
1333{
1334 FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio;
1335 STDCHAR *buf = ((STDCHAR *)vbuf)+count-1;
1336 SSize_t unread = 0;
1337 while (count > 0)
1338 {
1339 int ch = *buf-- & 0xff;
1340 if (ungetc(ch,s) != ch)
1341 break;
1342 unread++;
1343 count--;
1344 }
1345 return unread;
1346}
1347
1348SSize_t
1349PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count)
1350{
1351 return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio);
1352}
1353
1354IV
1355PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence)
1356{
c7fc522f
NIS
1357 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1358 return fseek(stdio,offset,whence);
9e353e3b
NIS
1359}
1360
1361Off_t
1362PerlIOStdio_tell(PerlIO *f)
1363{
c7fc522f
NIS
1364 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1365 return ftell(stdio);
9e353e3b
NIS
1366}
1367
1368IV
1369PerlIOStdio_close(PerlIO *f)
1370{
3789aae2
NIS
1371 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1372 return fclose(stdio);
9e353e3b
NIS
1373}
1374
1375IV
1376PerlIOStdio_flush(PerlIO *f)
1377{
1378 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
88b61e10
NIS
1379 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
1380 {
1381 return fflush(stdio);
1382 }
1383 else
1384 {
1385#if 0
1386 /* FIXME: This discards ungetc() and pre-read stuff which is
1387 not right if this is just a "sync" from a layer above
1388 Suspect right design is to do _this_ but not have layer above
1389 flush this layer read-to-read
1390 */
1391 /* Not writeable - sync by attempting a seek */
1392 int err = errno;
1393 if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0)
1394 errno = err;
1395#endif
1396 }
1397 return 0;
9e353e3b
NIS
1398}
1399
1400IV
06da4f11
NIS
1401PerlIOStdio_fill(PerlIO *f)
1402{
1403 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1404 int c;
3789aae2
NIS
1405 /* fflush()ing read-only streams can cause trouble on some stdio-s */
1406 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1407 {
1408 if (fflush(stdio) != 0)
1409 return EOF;
1410 }
06da4f11
NIS
1411 c = fgetc(stdio);
1412 if (c == EOF || ungetc(c,stdio) != c)
1413 return EOF;
1414 return 0;
1415}
1416
1417IV
9e353e3b
NIS
1418PerlIOStdio_eof(PerlIO *f)
1419{
1420 return feof(PerlIOSelf(f,PerlIOStdio)->stdio);
1421}
1422
1423IV
1424PerlIOStdio_error(PerlIO *f)
1425{
1426 return ferror(PerlIOSelf(f,PerlIOStdio)->stdio);
1427}
1428
1429void
1430PerlIOStdio_clearerr(PerlIO *f)
1431{
1432 clearerr(PerlIOSelf(f,PerlIOStdio)->stdio);
1433}
1434
1435void
1436PerlIOStdio_setlinebuf(PerlIO *f)
1437{
1438#ifdef HAS_SETLINEBUF
1439 setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio);
1440#else
1441 setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0);
1442#endif
1443}
1444
1445#ifdef FILE_base
1446STDCHAR *
1447PerlIOStdio_get_base(PerlIO *f)
1448{
1449 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1450 return FILE_base(stdio);
1451}
1452
1453Size_t
1454PerlIOStdio_get_bufsiz(PerlIO *f)
1455{
1456 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1457 return FILE_bufsiz(stdio);
1458}
1459#endif
1460
1461#ifdef USE_STDIO_PTR
1462STDCHAR *
1463PerlIOStdio_get_ptr(PerlIO *f)
1464{
1465 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1466 return FILE_ptr(stdio);
1467}
1468
1469SSize_t
1470PerlIOStdio_get_cnt(PerlIO *f)
1471{
1472 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1473 return FILE_cnt(stdio);
1474}
1475
1476void
1477PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt)
1478{
1479 FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
1480 if (ptr != NULL)
1481 {
1482#ifdef STDIO_PTR_LVALUE
1483 FILE_ptr(stdio) = ptr;
1484#ifdef STDIO_PTR_LVAL_SETS_CNT
1485 if (FILE_cnt(stdio) != (cnt))
1486 {
1487 dTHX;
1488 assert(FILE_cnt(stdio) == (cnt));
1489 }
1490#endif
1491#if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
1492 /* Setting ptr _does_ change cnt - we are done */
1493 return;
1494#endif
1495#else /* STDIO_PTR_LVALUE */
1496 abort();
1497#endif /* STDIO_PTR_LVALUE */
1498 }
1499/* Now (or only) set cnt */
1500#ifdef STDIO_CNT_LVALUE
1501 FILE_cnt(stdio) = cnt;
1502#else /* STDIO_CNT_LVALUE */
1503#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
1504 FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt);
1505#else /* STDIO_PTR_LVAL_SETS_CNT */
1506 abort();
1507#endif /* STDIO_PTR_LVAL_SETS_CNT */
1508#endif /* STDIO_CNT_LVALUE */
1509}
1510
1511#endif
1512
1513PerlIO_funcs PerlIO_stdio = {
1514 "stdio",
1515 sizeof(PerlIOStdio),
1516 0,
1517 PerlIOStdio_fileno,
1518 PerlIOStdio_fdopen,
1519 PerlIOStdio_open,
1520 PerlIOStdio_reopen,
06da4f11
NIS
1521 PerlIOBase_pushed,
1522 PerlIOBase_noop_ok,
9e353e3b
NIS
1523 PerlIOStdio_read,
1524 PerlIOStdio_unread,
1525 PerlIOStdio_write,
1526 PerlIOStdio_seek,
1527 PerlIOStdio_tell,
1528 PerlIOStdio_close,
1529 PerlIOStdio_flush,
06da4f11 1530 PerlIOStdio_fill,
9e353e3b
NIS
1531 PerlIOStdio_eof,
1532 PerlIOStdio_error,
1533 PerlIOStdio_clearerr,
1534 PerlIOStdio_setlinebuf,
1535#ifdef FILE_base
1536 PerlIOStdio_get_base,
1537 PerlIOStdio_get_bufsiz,
1538#else
1539 NULL,
1540 NULL,
1541#endif
1542#ifdef USE_STDIO_PTR
1543 PerlIOStdio_get_ptr,
1544 PerlIOStdio_get_cnt,
0eb1d8a4 1545#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
9e353e3b
NIS
1546 PerlIOStdio_set_ptrcnt
1547#else /* STDIO_PTR_LVALUE */
1548 NULL
1549#endif /* STDIO_PTR_LVALUE */
1550#else /* USE_STDIO_PTR */
1551 NULL,
1552 NULL,
1553 NULL
1554#endif /* USE_STDIO_PTR */
1555};
1556
1557#undef PerlIO_exportFILE
1558FILE *
1559PerlIO_exportFILE(PerlIO *f, int fl)
1560{
1561 PerlIO_flush(f);
1562 /* Should really push stdio discipline when we have them */
1563 return fdopen(PerlIO_fileno(f),"r+");
1564}
1565
1566#undef PerlIO_findFILE
1567FILE *
1568PerlIO_findFILE(PerlIO *f)
1569{
1570 return PerlIO_exportFILE(f,0);
1571}
1572
1573#undef PerlIO_releaseFILE
1574void
1575PerlIO_releaseFILE(PerlIO *p, FILE *f)
1576{
1577}
1578
1579/*--------------------------------------------------------------------------------------*/
1580/* perlio buffer layer */
1581
9e353e3b 1582PerlIO *
06da4f11 1583PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
9e353e3b
NIS
1584{
1585 PerlIO_funcs *tab = PerlIO_default_btm();
c7fc522f
NIS
1586 int init = 0;
1587 PerlIO *f;
1588 if (*mode == 'I')
1589 {
1590 init = 1;
1591 mode++;
1592 }
06da4f11 1593 f = (*tab->Fdopen)(tab,fd,mode);
6f9d8c32
NIS
1594 if (f)
1595 {
c7fc522f
NIS
1596 /* Initial stderr is unbuffered */
1597 if (!init || fd != 2)
1598 {
06da4f11 1599 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
c7fc522f
NIS
1600 b->posn = PerlIO_tell(PerlIONext(f));
1601 }
6f9d8c32 1602 }
9e353e3b 1603 return f;
760ac839
LW
1604}
1605
9e353e3b 1606PerlIO *
06da4f11 1607PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
8c86a920 1608{
9e353e3b 1609 PerlIO_funcs *tab = PerlIO_default_btm();
06da4f11 1610 PerlIO *f = (*tab->Open)(tab,path,mode);
9e353e3b
NIS
1611 if (f)
1612 {
06da4f11 1613 PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
c3d7c7c9 1614 b->posn = PerlIO_tell(PerlIONext(f));
9e353e3b
NIS
1615 }
1616 return f;
1617}
1618
1619int
c3d7c7c9 1620PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
9e353e3b 1621{
c3d7c7c9
NIS
1622 PerlIO *next = PerlIONext(f);
1623 int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
1624 if (code = 0)
1625 code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
1626 if (code == 0)
1627 {
1628 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1629 b->posn = PerlIO_tell(PerlIONext(f));
1630 }
1631 return code;
9e353e3b
NIS
1632}
1633
9e353e3b
NIS
1634/* This "flush" is akin to sfio's sync in that it handles files in either
1635 read or write state
1636*/
1637IV
1638PerlIOBuf_flush(PerlIO *f)
6f9d8c32 1639{
9e353e3b
NIS
1640 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1641 int code = 0;
1642 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1643 {
1644 /* write() the buffer */
1645 STDCHAR *p = b->buf;
1646 int count;
3789aae2 1647 PerlIO *n = PerlIONext(f);
9e353e3b
NIS
1648 while (p < b->ptr)
1649 {
3789aae2 1650 count = PerlIO_write(n,p,b->ptr - p);
9e353e3b
NIS
1651 if (count > 0)
1652 {
1653 p += count;
1654 }
3789aae2 1655 else if (count < 0 || PerlIO_error(n))
9e353e3b
NIS
1656 {
1657 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1658 code = -1;
1659 break;
1660 }
1661 }
1662 b->posn += (p - b->buf);
1663 }
1664 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
6f9d8c32 1665 {
9e353e3b
NIS
1666 /* Note position change */
1667 b->posn += (b->ptr - b->buf);
1668 if (b->ptr < b->end)
1669 {
1670 /* We did not consume all of it */
1671 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) == 0)
1672 {
1673 b->posn = PerlIO_tell(PerlIONext(f));
1674 }
1675 }
6f9d8c32 1676 }
9e353e3b
NIS
1677 b->ptr = b->end = b->buf;
1678 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
88b61e10 1679 /* FIXME: Is this right for read case ? */
9e353e3b
NIS
1680 if (PerlIO_flush(PerlIONext(f)) != 0)
1681 code = -1;
1682 return code;
6f9d8c32
NIS
1683}
1684
06da4f11
NIS
1685IV
1686PerlIOBuf_fill(PerlIO *f)
1687{
1688 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
88b61e10 1689 PerlIO *n = PerlIONext(f);
06da4f11 1690 SSize_t avail;
88b61e10
NIS
1691 /* FIXME: doing the down-stream flush is a bad idea if it causes
1692 pre-read data in stdio buffer to be discarded
1693 but this is too simplistic - as it skips _our_ hosekeeping
1694 and breaks tell tests.
1695 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
1696 {
1697 }
1698 */
06da4f11
NIS
1699 if (PerlIO_flush(f) != 0)
1700 return -1;
88b61e10 1701
06da4f11 1702 b->ptr = b->end = b->buf;
88b61e10
NIS
1703 if (PerlIO_fast_gets(n))
1704 {
1705 /* Layer below is also buffered
1706 * We do _NOT_ want to call its ->Read() because that will loop
1707 * till it gets what we asked for which may hang on a pipe etc.
1708 * Instead take anything it has to hand, or ask it to fill _once_.
1709 */
1710 avail = PerlIO_get_cnt(n);
1711 if (avail <= 0)
1712 {
1713 avail = PerlIO_fill(n);
1714 if (avail == 0)
1715 avail = PerlIO_get_cnt(n);
1716 else
1717 {
1718 if (!PerlIO_error(n) && PerlIO_eof(n))
1719 avail = 0;
1720 }
1721 }
1722 if (avail > 0)
1723 {
1724 STDCHAR *ptr = PerlIO_get_ptr(n);
1725 SSize_t cnt = avail;
1726 if (avail > b->bufsiz)
1727 avail = b->bufsiz;
1728 Copy(ptr,b->buf,avail,STDCHAR);
1729 PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail);
1730 }
1731 }
1732 else
1733 {
1734 avail = PerlIO_read(n,b->ptr,b->bufsiz);
1735 }
06da4f11
NIS
1736 if (avail <= 0)
1737 {
1738 if (avail == 0)
1739 PerlIOBase(f)->flags |= PERLIO_F_EOF;
1740 else
1741 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
1742 return -1;
1743 }
1744 b->end = b->buf+avail;
1745 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
1746 return 0;
1747}
1748
6f9d8c32 1749SSize_t
9e353e3b 1750PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
6f9d8c32 1751{
99efab12
NIS
1752 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1753 STDCHAR *buf = (STDCHAR *) vbuf;
6f9d8c32
NIS
1754 if (f)
1755 {
9e353e3b 1756 if (!b->ptr)
06da4f11 1757 PerlIO_get_base(f);
9e353e3b 1758 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD))
f89522bf 1759 return 0;
6f9d8c32
NIS
1760 while (count > 0)
1761 {
99efab12 1762 SSize_t avail = PerlIO_get_cnt(f);
60382766 1763 SSize_t take = (count < avail) ? count : avail;
99efab12 1764 if (take > 0)
6f9d8c32 1765 {
99efab12
NIS
1766 STDCHAR *ptr = PerlIO_get_ptr(f);
1767 Copy(ptr,buf,take,STDCHAR);
1768 PerlIO_set_ptrcnt(f,ptr+take,(avail -= take));
1769 count -= take;
1770 buf += take;
6f9d8c32 1771 }
99efab12 1772 if (count > 0 && avail <= 0)
6f9d8c32 1773 {
06da4f11
NIS
1774 if (PerlIO_fill(f) != 0)
1775 break;
6f9d8c32
NIS
1776 }
1777 }
99efab12 1778 return (buf - (STDCHAR *) vbuf);
6f9d8c32
NIS
1779 }
1780 return 0;
1781}
1782
9e353e3b
NIS
1783SSize_t
1784PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1785{
9e353e3b
NIS
1786 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
1787 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1788 SSize_t unread = 0;
1789 SSize_t avail;
9e353e3b
NIS
1790 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
1791 PerlIO_flush(f);
06da4f11
NIS
1792 if (!b->buf)
1793 PerlIO_get_base(f);
9e353e3b
NIS
1794 if (b->buf)
1795 {
1796 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1797 {
1798 avail = (b->ptr - b->buf);
1799 if (avail > (SSize_t) count)
1800 avail = count;
1801 b->ptr -= avail;
1802 }
1803 else
1804 {
1805 avail = b->bufsiz;
1806 if (avail > (SSize_t) count)
1807 avail = count;
1808 b->end = b->ptr + avail;
1809 }
1810 if (avail > 0)
1811 {
1812 buf -= avail;
1813 if (buf != b->ptr)
1814 {
88b61e10 1815 Copy(buf,b->ptr,avail,STDCHAR);
9e353e3b
NIS
1816 }
1817 count -= avail;
1818 unread += avail;
1819 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
1820 }
1821 }
1822 return unread;
760ac839
LW
1823}
1824
9e353e3b
NIS
1825SSize_t
1826PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
760ac839 1827{
9e353e3b
NIS
1828 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1829 const STDCHAR *buf = (const STDCHAR *) vbuf;
1830 Size_t written = 0;
1831 if (!b->buf)
06da4f11 1832 PerlIO_get_base(f);
9e353e3b
NIS
1833 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
1834 return 0;
1835 while (count > 0)
1836 {
1837 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
1838 if ((SSize_t) count < avail)
1839 avail = count;
1840 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
1841 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
1842 {
1843 while (avail > 0)
1844 {
1845 int ch = *buf++;
1846 *(b->ptr)++ = ch;
1847 count--;
1848 avail--;
1849 written++;
1850 if (ch == '\n')
1851 {
1852 PerlIO_flush(f);
1853 break;
1854 }
1855 }
1856 }
1857 else
1858 {
1859 if (avail)
1860 {
88b61e10 1861 Copy(buf,b->ptr,avail,STDCHAR);
9e353e3b
NIS
1862 count -= avail;
1863 buf += avail;
1864 written += avail;
1865 b->ptr += avail;
1866 }
1867 }
1868 if (b->ptr >= (b->buf + b->bufsiz))
1869 PerlIO_flush(f);
1870 }
1871 return written;
1872}
1873
1874IV
1875PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
1876{
1877 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
06da4f11 1878 int code = PerlIO_flush(f);
9e353e3b
NIS
1879 if (code == 0)
1880 {
1881 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
1882 code = PerlIO_seek(PerlIONext(f),offset,whence);
1883 if (code == 0)
1884 {
1885 b->posn = PerlIO_tell(PerlIONext(f));
1886 }
1887 }
1888 return code;
1889}
1890
1891Off_t
1892PerlIOBuf_tell(PerlIO *f)
1893{
1894 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1895 Off_t posn = b->posn;
1896 if (b->buf)
1897 posn += (b->ptr - b->buf);
1898 return posn;
1899}
1900
1901IV
1902PerlIOBuf_close(PerlIO *f)
1903{
1904 IV code = PerlIOBase_close(f);
1905 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1906 if (b->buf && b->buf != (STDCHAR *) &b->oneword)
6f9d8c32 1907 {
9e353e3b 1908 Safefree(b->buf);
6f9d8c32 1909 }
9e353e3b
NIS
1910 b->buf = NULL;
1911 b->ptr = b->end = b->buf;
1912 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
1913 return code;
760ac839
LW
1914}
1915
760ac839 1916void
9e353e3b 1917PerlIOBuf_setlinebuf(PerlIO *f)
760ac839 1918{
6f9d8c32
NIS
1919 if (f)
1920 {
9e353e3b 1921 PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF;
6f9d8c32 1922 }
760ac839
LW
1923}
1924
9e353e3b
NIS
1925STDCHAR *
1926PerlIOBuf_get_ptr(PerlIO *f)
1927{
1928 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1929 if (!b->buf)
06da4f11 1930 PerlIO_get_base(f);
9e353e3b
NIS
1931 return b->ptr;
1932}
1933
05d1247b 1934SSize_t
9e353e3b
NIS
1935PerlIOBuf_get_cnt(PerlIO *f)
1936{
1937 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1938 if (!b->buf)
06da4f11 1939 PerlIO_get_base(f);
9e353e3b
NIS
1940 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
1941 return (b->end - b->ptr);
1942 return 0;
1943}
1944
1945STDCHAR *
1946PerlIOBuf_get_base(PerlIO *f)
1947{
1948 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1949 if (!b->buf)
06da4f11
NIS
1950 {
1951 if (!b->bufsiz)
1952 b->bufsiz = 4096;
1953 New('B',b->buf,b->bufsiz,STDCHAR);
1954 if (!b->buf)
1955 {
1956 b->buf = (STDCHAR *)&b->oneword;
1957 b->bufsiz = sizeof(b->oneword);
1958 }
1959 b->ptr = b->buf;
1960 b->end = b->ptr;
1961 }
9e353e3b
NIS
1962 return b->buf;
1963}
1964
1965Size_t
1966PerlIOBuf_bufsiz(PerlIO *f)
1967{
1968 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1969 if (!b->buf)
06da4f11 1970 PerlIO_get_base(f);
9e353e3b
NIS
1971 return (b->end - b->buf);
1972}
1973
1974void
05d1247b 1975PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
9e353e3b
NIS
1976{
1977 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
1978 if (!b->buf)
06da4f11 1979 PerlIO_get_base(f);
9e353e3b
NIS
1980 b->ptr = ptr;
1981 if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf)
6f9d8c32 1982 {
9e353e3b
NIS
1983 dTHX;
1984 assert(PerlIO_get_cnt(f) == cnt);
1985 assert(b->ptr >= b->buf);
6f9d8c32 1986 }
9e353e3b 1987 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
760ac839
LW
1988}
1989
9e353e3b
NIS
1990PerlIO_funcs PerlIO_perlio = {
1991 "perlio",
1992 sizeof(PerlIOBuf),
1993 0,
1994 PerlIOBase_fileno,
1995 PerlIOBuf_fdopen,
1996 PerlIOBuf_open,
c3d7c7c9 1997 PerlIOBuf_reopen,
06da4f11
NIS
1998 PerlIOBase_pushed,
1999 PerlIOBase_noop_ok,
9e353e3b
NIS
2000 PerlIOBuf_read,
2001 PerlIOBuf_unread,
2002 PerlIOBuf_write,
2003 PerlIOBuf_seek,
2004 PerlIOBuf_tell,
2005 PerlIOBuf_close,
2006 PerlIOBuf_flush,
06da4f11 2007 PerlIOBuf_fill,
9e353e3b
NIS
2008 PerlIOBase_eof,
2009 PerlIOBase_error,
2010 PerlIOBase_clearerr,
2011 PerlIOBuf_setlinebuf,
2012 PerlIOBuf_get_base,
2013 PerlIOBuf_bufsiz,
2014 PerlIOBuf_get_ptr,
2015 PerlIOBuf_get_cnt,
2016 PerlIOBuf_set_ptrcnt,
2017};
2018
66ecd56b 2019/*--------------------------------------------------------------------------------------*/
99efab12
NIS
2020/* crlf - translation
2021 On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
60382766 2022 to hand back a line at a time and keeping a record of which nl we "lied" about.
99efab12 2023 On write translate "\n" to CR,LF
66ecd56b
NIS
2024 */
2025
99efab12
NIS
2026typedef struct
2027{
2028 PerlIOBuf base; /* PerlIOBuf stuff */
60382766 2029 STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */
99efab12
NIS
2030} PerlIOCrlf;
2031
2032SSize_t
2033PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
2034{
2035 const STDCHAR *buf = (const STDCHAR *) vbuf+count;
2036 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
60382766 2037 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
99efab12
NIS
2038 SSize_t unread = 0;
2039 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2040 PerlIO_flush(f);
60382766
NIS
2041 if (c->nl)
2042 {
2043 *(c->nl) = 0xd;
2044 c->nl = NULL;
2045 }
99efab12
NIS
2046 if (!b->buf)
2047 PerlIO_get_base(f);
2048 if (b->buf)
2049 {
2050 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2051 {
2052 b->end = b->ptr = b->buf + b->bufsiz;
2053 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2054 }
2055 while (count > 0 && b->ptr > b->buf)
2056 {
2057 int ch = *--buf;
2058 if (ch == '\n')
2059 {
2060 if (b->ptr - 2 >= b->buf)
2061 {
60382766
NIS
2062 *--(b->ptr) = 0xa;
2063 *--(b->ptr) = 0xd;
99efab12
NIS
2064 unread++;
2065 count--;
2066 }
2067 else
2068 {
2069 buf++;
2070 break;
2071 }
2072 }
2073 else
2074 {
60382766 2075 *--(b->ptr) = ch;
99efab12
NIS
2076 unread++;
2077 count--;
60382766 2078 }
99efab12
NIS
2079 }
2080 }
2081 return unread;
2082}
2083
2084SSize_t
2085PerlIOCrlf_get_cnt(PerlIO *f)
2086{
2087 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2088 if (!b->buf)
2089 PerlIO_get_base(f);
2090 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
2091 {
2092 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2093 if (!c->nl)
2094 {
2095 STDCHAR *nl = b->ptr;
60382766 2096 scan:
99efab12
NIS
2097 while (nl < b->end && *nl != 0xd)
2098 nl++;
2099 if (nl < b->end && *nl == 0xd)
2100 {
60382766 2101 test:
99efab12
NIS
2102 if (nl+1 < b->end)
2103 {
2104 if (nl[1] == 0xa)
2105 {
2106 *nl = '\n';
60382766 2107 c->nl = nl;
99efab12 2108 }
60382766 2109 else
99efab12
NIS
2110 {
2111 /* Not CR,LF but just CR */
2112 nl++;
60382766 2113 goto scan;
99efab12
NIS
2114 }
2115 }
2116 else
2117 {
60382766 2118 /* Blast - found CR as last char in buffer */
99efab12
NIS
2119 if (b->ptr < nl)
2120 {
2121 /* They may not care, defer work as long as possible */
60382766 2122 return (nl - b->ptr);
99efab12
NIS
2123 }
2124 else
2125 {
2126 int code;
2127 dTHX;
99efab12
NIS
2128 b->ptr++; /* say we have read it as far as flush() is concerned */
2129 b->buf++; /* Leave space an front of buffer */
2130 b->bufsiz--; /* Buffer is thus smaller */
2131 code = PerlIO_fill(f); /* Fetch some more */
2132 b->bufsiz++; /* Restore size for next time */
2133 b->buf--; /* Point at space */
2134 b->ptr = nl = b->buf; /* Which is what we hand off */
2135 b->posn--; /* Buffer starts here */
2136 *nl = 0xd; /* Fill in the CR */
60382766 2137 if (code == 0)
99efab12
NIS
2138 goto test; /* fill() call worked */
2139 /* CR at EOF - just fall through */
2140 }
2141 }
60382766
NIS
2142 }
2143 }
99efab12
NIS
2144 return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
2145 }
2146 return 0;
2147}
2148
2149void
2150PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
2151{
2152 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2153 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2154 if (!b->buf)
2155 PerlIO_get_base(f);
2156 if (!ptr)
60382766 2157 {
63dbdb06
NIS
2158 if (c->nl)
2159 ptr = c->nl+1;
2160 else
2161 {
2162 ptr = b->end;
2163 if (ptr > b->buf && ptr[-1] == 0xd)
2164 ptr--;
2165 }
2166 ptr -= cnt;
60382766
NIS
2167 }
2168 else
2169 {
63dbdb06
NIS
2170 /* Test code - delete when it works ... */
2171 STDCHAR *chk;
2172 if (c->nl)
2173 chk = c->nl+1;
2174 else
2175 {
2176 chk = b->end;
2177 if (chk > b->buf && chk[-1] == 0xd)
2178 chk--;
2179 }
2180 chk -= cnt;
2181
2182 if (ptr != chk)
2183 {
2184 dTHX;
2185 Perl_croak(aTHX_ "ptr wrong %p != %p nl=%p e=%p for %d",
2186 ptr, chk, c->nl, b->end, cnt);
2187 }
60382766 2188 }
99efab12
NIS
2189 if (c->nl)
2190 {
2191 if (ptr > c->nl)
2192 {
2193 /* They have taken what we lied about */
2194 *(c->nl) = 0xd;
2195 c->nl = NULL;
2196 ptr++;
60382766 2197 }
99efab12
NIS
2198 }
2199 b->ptr = ptr;
2200 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
2201}
2202
2203SSize_t
2204PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
2205{
2206 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2207 const STDCHAR *buf = (const STDCHAR *) vbuf;
2208 const STDCHAR *ebuf = buf+count;
2209 if (!b->buf)
2210 PerlIO_get_base(f);
2211 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
2212 return 0;
2213 while (buf < ebuf)
2214 {
2215 STDCHAR *eptr = b->buf+b->bufsiz;
2216 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
2217 while (buf < ebuf && b->ptr < eptr)
2218 {
2219 if (*buf == '\n')
2220 {
60382766 2221 if ((b->ptr + 2) > eptr)
99efab12
NIS
2222 {
2223 /* Not room for both */
2224 PerlIO_flush(f);
2225 break;
2226 }
60382766
NIS
2227 else
2228 {
2229 *(b->ptr)++ = 0xd; /* CR */
2230 *(b->ptr)++ = 0xa; /* LF */
2231 buf++;
2232 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
2233 {
2234 PerlIO_flush(f);
2235 break;
2236 }
99efab12
NIS
2237 }
2238 }
2239 else
2240 {
2241 int ch = *buf++;
2242 *(b->ptr)++ = ch;
2243 }
2244 if (b->ptr >= eptr)
2245 {
2246 PerlIO_flush(f);
2247 break;
2248 }
2249 }
2250 }
2251 return (buf - (STDCHAR *) vbuf);
2252}
2253
2254IV
2255PerlIOCrlf_flush(PerlIO *f)
2256{
2257 PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
2258 if (c->nl)
2259 {
99efab12 2260 *(c->nl) = 0xd;
60382766 2261 c->nl = NULL;
99efab12
NIS
2262 }
2263 return PerlIOBuf_flush(f);
2264}
2265
66ecd56b
NIS
2266PerlIO_funcs PerlIO_crlf = {
2267 "crlf",
99efab12 2268 sizeof(PerlIOCrlf),
66ecd56b
NIS
2269 0,
2270 PerlIOBase_fileno,
2271 PerlIOBuf_fdopen,
2272 PerlIOBuf_open,
2273 PerlIOBuf_reopen,
2274 PerlIOBase_pushed,
99efab12
NIS
2275 PerlIOBase_noop_ok, /* popped */
2276 PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */
2277 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
2278 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
66ecd56b
NIS
2279 PerlIOBuf_seek,
2280 PerlIOBuf_tell,
2281 PerlIOBuf_close,
99efab12 2282 PerlIOCrlf_flush,
66ecd56b
NIS
2283 PerlIOBuf_fill,
2284 PerlIOBase_eof,
2285 PerlIOBase_error,
2286 PerlIOBase_clearerr,
2287 PerlIOBuf_setlinebuf,
2288 PerlIOBuf_get_base,
2289 PerlIOBuf_bufsiz,
2290 PerlIOBuf_get_ptr,
99efab12
NIS
2291 PerlIOCrlf_get_cnt,
2292 PerlIOCrlf_set_ptrcnt,
66ecd56b
NIS
2293};
2294
06da4f11
NIS
2295#ifdef HAS_MMAP
2296/*--------------------------------------------------------------------------------------*/
2297/* mmap as "buffer" layer */
2298
2299typedef struct
2300{
2301 PerlIOBuf base; /* PerlIOBuf stuff */
c3d7c7c9 2302 Mmap_t mptr; /* Mapped address */
06da4f11
NIS
2303 Size_t len; /* mapped length */
2304 STDCHAR *bbuf; /* malloced buffer if map fails */
2305} PerlIOMmap;
2306
c3d7c7c9
NIS
2307static size_t page_size = 0;
2308
06da4f11
NIS
2309IV
2310PerlIOMmap_map(PerlIO *f)
2311{
68d873c6 2312 dTHX;
06da4f11
NIS
2313 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2314 PerlIOBuf *b = &m->base;
2315 IV flags = PerlIOBase(f)->flags;
2316 IV code = 0;
2317 if (m->len)
2318 abort();
2319 if (flags & PERLIO_F_CANREAD)
2320 {
2321 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2322 int fd = PerlIO_fileno(f);
2323 struct stat st;
2324 code = fstat(fd,&st);
2325 if (code == 0 && S_ISREG(st.st_mode))
2326 {
2327 SSize_t len = st.st_size - b->posn;
2328 if (len > 0)
2329 {
c3d7c7c9 2330 Off_t posn;
68d873c6
JH
2331 if (!page_size) {
2332#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
2333 {
2334 SETERRNO(0,SS$_NORMAL);
2335# ifdef _SC_PAGESIZE
2336 page_size = sysconf(_SC_PAGESIZE);
2337# else
2338 page_size = sysconf(_SC_PAGE_SIZE);
14aaf8e8 2339# endif
68d873c6
JH
2340 if ((long)page_size < 0) {
2341 if (errno) {
2342 SV *error = ERRSV;
2343 char *msg;
2344 STRLEN n_a;
2345 (void)SvUPGRADE(error, SVt_PV);
2346 msg = SvPVx(error, n_a);
14aaf8e8 2347 Perl_croak(aTHX_ "panic: sysconf: %s", msg);
68d873c6
JH
2348 }
2349 else
14aaf8e8 2350 Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
68d873c6
JH
2351 }
2352 }
2353#else
2354# ifdef HAS_GETPAGESIZE
c3d7c7c9 2355 page_size = getpagesize();
68d873c6
JH
2356# else
2357# if defined(I_SYS_PARAM) && defined(PAGESIZE)
2358 page_size = PAGESIZE; /* compiletime, bad */
2359# endif
2360# endif
2361#endif
2362 if ((IV)page_size <= 0)
14aaf8e8 2363 Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
68d873c6 2364 }
c3d7c7c9
NIS
2365 if (b->posn < 0)
2366 {
2367 /* This is a hack - should never happen - open should have set it ! */
2368 b->posn = PerlIO_tell(PerlIONext(f));
2369 }
2370 posn = (b->posn / page_size) * page_size;
2371 len = st.st_size - posn;
2372 m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
2373 if (m->mptr && m->mptr != (Mmap_t) -1)
06da4f11
NIS
2374 {
2375#if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
c3d7c7c9 2376 madvise(m->mptr, len, MADV_SEQUENTIAL);
06da4f11 2377#endif
c3d7c7c9
NIS
2378 PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
2379 b->end = ((STDCHAR *)m->mptr) + len;
2380 b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn);
2381 b->ptr = b->buf;
2382 m->len = len;
06da4f11
NIS
2383 }
2384 else
2385 {
2386 b->buf = NULL;
2387 }
2388 }
2389 else
2390 {
2391 PerlIOBase(f)->flags = flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
2392 b->buf = NULL;
2393 b->ptr = b->end = b->ptr;
2394 code = -1;
2395 }
2396 }
2397 }
2398 return code;
2399}
2400
2401IV
2402PerlIOMmap_unmap(PerlIO *f)
2403{
2404 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2405 PerlIOBuf *b = &m->base;
2406 IV code = 0;
2407 if (m->len)
2408 {
2409 if (b->buf)
2410 {
c3d7c7c9
NIS
2411 code = munmap(m->mptr, m->len);
2412 b->buf = NULL;
2413 m->len = 0;
2414 m->mptr = NULL;
06da4f11
NIS
2415 if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
2416 code = -1;
06da4f11
NIS
2417 }
2418 b->ptr = b->end = b->buf;
2419 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
2420 }
2421 return code;
2422}
2423
2424STDCHAR *
2425PerlIOMmap_get_base(PerlIO *f)
2426{
2427 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2428 PerlIOBuf *b = &m->base;
2429 if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2430 {
2431 /* Already have a readbuffer in progress */
2432 return b->buf;
2433 }
2434 if (b->buf)
2435 {
2436 /* We have a write buffer or flushed PerlIOBuf read buffer */
2437 m->bbuf = b->buf; /* save it in case we need it again */
2438 b->buf = NULL; /* Clear to trigger below */
2439 }
2440 if (!b->buf)
2441 {
2442 PerlIOMmap_map(f); /* Try and map it */
2443 if (!b->buf)
2444 {
2445 /* Map did not work - recover PerlIOBuf buffer if we have one */
2446 b->buf = m->bbuf;
2447 }
2448 }
2449 b->ptr = b->end = b->buf;
2450 if (b->buf)
2451 return b->buf;
2452 return PerlIOBuf_get_base(f);
2453}
2454
2455SSize_t
2456PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
2457{
2458 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2459 PerlIOBuf *b = &m->base;
2460 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
2461 PerlIO_flush(f);
2462 if (b->ptr && (b->ptr - count) >= b->buf && memEQ(b->ptr - count,vbuf,count))
2463 {
2464 b->ptr -= count;
2465 PerlIOBase(f)->flags &= ~ PERLIO_F_EOF;
2466 return count;
2467 }
2468 if (m->len)
2469 {
4a4a6116 2470 /* Loose the unwritable mapped buffer */
06da4f11 2471 PerlIO_flush(f);
c3d7c7c9
NIS
2472 /* If flush took the "buffer" see if we have one from before */
2473 if (!b->buf && m->bbuf)
2474 b->buf = m->bbuf;
2475 if (!b->buf)
2476 {
2477 PerlIOBuf_get_base(f);
2478 m->bbuf = b->buf;
2479 }
06da4f11
NIS
2480 }
2481 return PerlIOBuf_unread(f,vbuf,count);
2482}
2483
2484SSize_t
2485PerlIOMmap_write(PerlIO *f, const void *vbuf, Size_t count)
2486{
2487 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2488 PerlIOBuf *b = &m->base;
2489 if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF))
2490 {
2491 /* No, or wrong sort of, buffer */
2492 if (m->len)
2493 {
2494 if (PerlIOMmap_unmap(f) != 0)
2495 return 0;
2496 }
2497 /* If unmap took the "buffer" see if we have one from before */
2498 if (!b->buf && m->bbuf)
2499 b->buf = m->bbuf;
2500 if (!b->buf)
2501 {
2502 PerlIOBuf_get_base(f);
2503 m->bbuf = b->buf;
2504 }
2505 }
2506 return PerlIOBuf_write(f,vbuf,count);
2507}
2508
2509IV
2510PerlIOMmap_flush(PerlIO *f)
2511{
2512 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2513 PerlIOBuf *b = &m->base;
2514 IV code = PerlIOBuf_flush(f);
2515 /* Now we are "synced" at PerlIOBuf level */
2516 if (b->buf)
2517 {
2518 if (m->len)
2519 {
2520 /* Unmap the buffer */
2521 if (PerlIOMmap_unmap(f) != 0)
2522 code = -1;
2523 }
2524 else
2525 {
2526 /* We seem to have a PerlIOBuf buffer which was not mapped
2527 * remember it in case we need one later
2528 */
2529 m->bbuf = b->buf;
2530 }
2531 }
06da4f11
NIS
2532 return code;
2533}
2534
2535IV
2536PerlIOMmap_fill(PerlIO *f)
2537{
2538 PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
2539 IV code = PerlIO_flush(f);
06da4f11
NIS
2540 if (code == 0 && !b->buf)
2541 {
2542 code = PerlIOMmap_map(f);
06da4f11
NIS
2543 }
2544 if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF))
2545 {
2546 code = PerlIOBuf_fill(f);
06da4f11
NIS
2547 }
2548 return code;
2549}
2550
2551IV
2552PerlIOMmap_close(PerlIO *f)
2553{
2554 PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
2555 PerlIOBuf *b = &m->base;
2556 IV code = PerlIO_flush(f);
2557 if (m->bbuf)
2558 {
2559 b->buf = m->bbuf;
2560 m->bbuf = NULL;
2561 b->ptr = b->end = b->buf;
2562 }
2563 if (PerlIOBuf_close(f) != 0)
2564 code = -1;
06da4f11
NIS
2565 return code;
2566}
2567
2568
2569PerlIO_funcs PerlIO_mmap = {
2570 "mmap",
2571 sizeof(PerlIOMmap),
2572 0,
2573 PerlIOBase_fileno,
2574 PerlIOBuf_fdopen,
2575 PerlIOBuf_open,
c3d7c7c9 2576 PerlIOBuf_reopen,
06da4f11
NIS
2577 PerlIOBase_pushed,
2578 PerlIOBase_noop_ok,
2579 PerlIOBuf_read,
2580 PerlIOMmap_unread,
2581 PerlIOMmap_write,
2582 PerlIOBuf_seek,
2583 PerlIOBuf_tell,
2584 PerlIOBuf_close,
2585 PerlIOMmap_flush,
2586 PerlIOMmap_fill,
2587 PerlIOBase_eof,
2588 PerlIOBase_error,
2589 PerlIOBase_clearerr,
2590 PerlIOBuf_setlinebuf,
2591 PerlIOMmap_get_base,
2592 PerlIOBuf_bufsiz,
2593 PerlIOBuf_get_ptr,
2594 PerlIOBuf_get_cnt,
2595 PerlIOBuf_set_ptrcnt,
2596};
2597
2598#endif /* HAS_MMAP */
2599
9e353e3b
NIS
2600void
2601PerlIO_init(void)
760ac839 2602{
9e353e3b 2603 if (!_perlio)
6f9d8c32 2604 {
9e353e3b 2605 atexit(&PerlIO_cleanup);
6f9d8c32 2606 }
760ac839
LW
2607}
2608
9e353e3b
NIS
2609#undef PerlIO_stdin
2610PerlIO *
2611PerlIO_stdin(void)
2612{
2613 if (!_perlio)
f3862f8b 2614 PerlIO_stdstreams();
05d1247b 2615 return &_perlio[1];
9e353e3b
NIS
2616}
2617
2618#undef PerlIO_stdout
2619PerlIO *
2620PerlIO_stdout(void)
2621{
2622 if (!_perlio)
f3862f8b 2623 PerlIO_stdstreams();
05d1247b 2624 return &_perlio[2];
9e353e3b
NIS
2625}
2626
2627#undef PerlIO_stderr
2628PerlIO *
2629PerlIO_stderr(void)
2630{
2631 if (!_perlio)
f3862f8b 2632 PerlIO_stdstreams();
05d1247b 2633 return &_perlio[3];
9e353e3b
NIS
2634}
2635
2636/*--------------------------------------------------------------------------------------*/
2637
2638#undef PerlIO_getname
2639char *
2640PerlIO_getname(PerlIO *f, char *buf)
2641{
2642 dTHX;
2643 Perl_croak(aTHX_ "Don't know how to get file name");
2644 return NULL;
2645}
2646
2647
2648/*--------------------------------------------------------------------------------------*/
2649/* Functions which can be called on any kind of PerlIO implemented
2650 in terms of above
2651*/
2652
2653#undef PerlIO_getc
6f9d8c32 2654int
9e353e3b 2655PerlIO_getc(PerlIO *f)
760ac839 2656{
313ca112
NIS
2657 STDCHAR buf[1];
2658 SSize_t count = PerlIO_read(f,buf,1);
9e353e3b 2659 if (count == 1)
313ca112
NIS
2660 {
2661 return (unsigned char) buf[0];
2662 }
2663 return EOF;
2664}
2665
2666#undef PerlIO_ungetc
2667int
2668PerlIO_ungetc(PerlIO *f, int ch)
2669{
2670 if (ch != EOF)
2671 {
2672 STDCHAR buf = ch;
2673 if (PerlIO_unread(f,&buf,1) == 1)
2674 return ch;
2675 }
2676 return EOF;
760ac839
LW
2677}
2678
9e353e3b
NIS
2679#undef PerlIO_putc
2680int
2681PerlIO_putc(PerlIO *f, int ch)
760ac839 2682{
9e353e3b
NIS
2683 STDCHAR buf = ch;
2684 return PerlIO_write(f,&buf,1);
760ac839
LW
2685}
2686
9e353e3b 2687#undef PerlIO_puts
760ac839 2688int
9e353e3b 2689PerlIO_puts(PerlIO *f, const char *s)
760ac839 2690{
9e353e3b
NIS
2691 STRLEN len = strlen(s);
2692 return PerlIO_write(f,s,len);
760ac839
LW
2693}
2694
2695#undef PerlIO_rewind
2696void
c78749f2 2697PerlIO_rewind(PerlIO *f)
760ac839 2698{
6f9d8c32 2699 PerlIO_seek(f,(Off_t)0,SEEK_SET);
9e353e3b 2700 PerlIO_clearerr(f);
6f9d8c32
NIS
2701}
2702
2703#undef PerlIO_vprintf
2704int
2705PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
2706{
2707 dTHX;
bb9950b7 2708 SV *sv = newSVpvn("",0);
6f9d8c32
NIS
2709 char *s;
2710 STRLEN len;
2cc61e15
DD
2711#ifdef NEED_VA_COPY
2712 va_list apc;
2713 Perl_va_copy(ap, apc);
2714 sv_vcatpvf(sv, fmt, &apc);
2715#else
6f9d8c32 2716 sv_vcatpvf(sv, fmt, &ap);
2cc61e15 2717#endif
6f9d8c32 2718 s = SvPV(sv,len);
bb9950b7 2719 return PerlIO_write(f,s,len);
760ac839
LW
2720}
2721
2722#undef PerlIO_printf
6f9d8c32 2723int
760ac839 2724PerlIO_printf(PerlIO *f,const char *fmt,...)
760ac839
LW
2725{
2726 va_list ap;
2727 int result;
760ac839 2728 va_start(ap,fmt);
6f9d8c32 2729 result = PerlIO_vprintf(f,fmt,ap);
760ac839
LW
2730 va_end(ap);
2731 return result;
2732}
2733
2734#undef PerlIO_stdoutf
6f9d8c32 2735int
760ac839 2736PerlIO_stdoutf(const char *fmt,...)
760ac839
LW
2737{
2738 va_list ap;
2739 int result;
760ac839 2740 va_start(ap,fmt);
760ac839
LW
2741 result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
2742 va_end(ap);
2743 return result;
2744}
2745
2746#undef PerlIO_tmpfile
2747PerlIO *
c78749f2 2748PerlIO_tmpfile(void)
760ac839 2749{
b1ef6e3b 2750 /* I have no idea how portable mkstemp() is ... */
83b075c3
NIS
2751#if defined(WIN32) || !defined(HAVE_MKSTEMP)
2752 PerlIO *f = NULL;
2753 FILE *stdio = tmpfile();
2754 if (stdio)
2755 {
2756 PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"w+"),PerlIOStdio);
2757 s->stdio = stdio;
2758 }
2759 return f;
2760#else
2761 dTHX;
6f9d8c32
NIS
2762 SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0);
2763 int fd = mkstemp(SvPVX(sv));
2764 PerlIO *f = NULL;
2765 if (fd >= 0)
2766 {
b1ef6e3b 2767 f = PerlIO_fdopen(fd,"w+");
6f9d8c32
NIS
2768 if (f)
2769 {
9e353e3b 2770 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
6f9d8c32 2771 }
00b02797 2772 PerlLIO_unlink(SvPVX(sv));
6f9d8c32
NIS
2773 SvREFCNT_dec(sv);
2774 }
2775 return f;
83b075c3 2776#endif
760ac839
LW
2777}
2778
6f9d8c32
NIS
2779#undef HAS_FSETPOS
2780#undef HAS_FGETPOS
2781
760ac839
LW
2782#endif /* USE_SFIO */
2783#endif /* PERLIO_IS_STDIO */
2784
9e353e3b
NIS
2785/*======================================================================================*/
2786/* Now some functions in terms of above which may be needed even if
2787 we are not in true PerlIO mode
2788 */
2789
760ac839
LW
2790#ifndef HAS_FSETPOS
2791#undef PerlIO_setpos
2792int
c78749f2 2793PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
760ac839 2794{
6f9d8c32 2795 return PerlIO_seek(f,*pos,0);
760ac839 2796}
c411622e
PP
2797#else
2798#ifndef PERLIO_IS_STDIO
2799#undef PerlIO_setpos
2800int
c78749f2 2801PerlIO_setpos(PerlIO *f, const Fpos_t *pos)
c411622e 2802{
2d4389e4 2803#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2804 return fsetpos64(f, pos);
2805#else
c411622e 2806 return fsetpos(f, pos);
d9b3e12d 2807#endif
c411622e
PP
2808}
2809#endif
760ac839
LW
2810#endif
2811
2812#ifndef HAS_FGETPOS
2813#undef PerlIO_getpos
2814int
c78749f2 2815PerlIO_getpos(PerlIO *f, Fpos_t *pos)
760ac839
LW
2816{
2817 *pos = PerlIO_tell(f);
a17c7222 2818 return *pos == -1 ? -1 : 0;
760ac839 2819}
c411622e
PP
2820#else
2821#ifndef PERLIO_IS_STDIO
2822#undef PerlIO_getpos
2823int
c78749f2 2824PerlIO_getpos(PerlIO *f, Fpos_t *pos)
c411622e 2825{
2d4389e4 2826#if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
d9b3e12d
JH
2827 return fgetpos64(f, pos);
2828#else
c411622e 2829 return fgetpos(f, pos);
d9b3e12d 2830#endif
c411622e
PP
2831}
2832#endif
760ac839
LW
2833#endif
2834
2835#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
2836
2837int
c78749f2 2838vprintf(char *pat, char *args)
662a7e3f
CS
2839{
2840 _doprnt(pat, args, stdout);
2841 return 0; /* wrong, but perl doesn't use the return value */
2842}
2843
2844int
c78749f2 2845vfprintf(FILE *fd, char *pat, char *args)
760ac839
LW
2846{
2847 _doprnt(pat, args, fd);
2848 return 0; /* wrong, but perl doesn't use the return value */
2849}
2850
2851#endif
2852
2853#ifndef PerlIO_vsprintf
6f9d8c32 2854int
8ac85365 2855PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
760ac839
LW
2856{
2857 int val = vsprintf(s, fmt, ap);
2858 if (n >= 0)
2859 {
8c86a920 2860 if (strlen(s) >= (STRLEN)n)
760ac839 2861 {
bf49b057 2862 dTHX;
fb4a9925
JH
2863 (void)PerlIO_puts(Perl_error_log,
2864 "panic: sprintf overflow - memory corrupted!\n");
bf49b057 2865 my_exit(1);
760ac839
LW
2866 }
2867 }
2868 return val;
2869}
2870#endif
2871
2872#ifndef PerlIO_sprintf
6f9d8c32 2873int
760ac839 2874PerlIO_sprintf(char *s, int n, const char *fmt,...)
760ac839
LW
2875{
2876 va_list ap;
2877 int result;
760ac839 2878 va_start(ap,fmt);
760ac839
LW
2879 result = PerlIO_vsprintf(s, n, fmt, ap);
2880 va_end(ap);
2881 return result;
2882}
2883#endif
2884
c5be433b
GS
2885#endif /* !PERL_IMPLICIT_SYS */
2886