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