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