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