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