This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase page file quota advice in README.vms
[perl5.git] / perlio.c
... / ...
CommitLineData
1/*
2 * perlio.c
3 * Copyright (c) 1996-2006, Nick Ing-Simmons
4 * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public License
7 * or the Artistic License, as specified in the README file.
8 */
9
10/*
11 * Hour after hour for nearly three weary days he had jogged up and down,
12 * over passes, and through long dales, and across many streams.
13 *
14 * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"]
15 */
16
17/* This file contains the functions needed to implement PerlIO, which
18 * is Perl's private replacement for the C stdio library. This is used
19 * by default unless you compile with -Uuseperlio or run with
20 * PERLIO=:stdio (but don't do this unless you know what you're doing)
21 */
22
23/*
24 * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get
25 * at the dispatch tables, even when we do not need it for other reasons.
26 * Invent a dSYS macro to abstract this out
27 */
28#ifdef PERL_IMPLICIT_SYS
29# define dSYS dTHX
30#else
31# define dSYS dNOOP
32#endif
33
34#define PERLIO_NOT_STDIO 0
35/*
36 * This file provides those parts of PerlIO abstraction
37 * which are not #defined in perlio.h.
38 * Which these are depends on various Configure #ifdef's
39 */
40
41#include "EXTERN.h"
42#define PERL_IN_PERLIO_C
43#include "perl.h"
44
45#ifdef PERL_IMPLICIT_CONTEXT
46# undef dSYS
47# define dSYS dTHX
48#endif
49
50#include "XSUB.h"
51
52#ifdef VMS
53# include <rms.h>
54#endif
55
56#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
57
58/* Call the callback or PerlIOBase, and return failure. */
59#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
60 if (PerlIOValid(f)) { \
61 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
62 if (tab && tab->callback) \
63 return (*tab->callback) args; \
64 else \
65 return PerlIOBase_ ## base args; \
66 } \
67 else \
68 SETERRNO(EBADF, SS_IVCHAN); \
69 return failure
70
71/* Call the callback or fail, and return failure. */
72#define Perl_PerlIO_or_fail(f, callback, failure, args) \
73 if (PerlIOValid(f)) { \
74 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
75 if (tab && tab->callback) \
76 return (*tab->callback) args; \
77 SETERRNO(EINVAL, LIB_INVARG); \
78 } \
79 else \
80 SETERRNO(EBADF, SS_IVCHAN); \
81 return failure
82
83/* Call the callback or PerlIOBase, and be void. */
84#define Perl_PerlIO_or_Base_void(f, callback, base, args) \
85 if (PerlIOValid(f)) { \
86 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
87 if (tab && tab->callback) \
88 (*tab->callback) args; \
89 else \
90 PerlIOBase_ ## base args; \
91 } \
92 else \
93 SETERRNO(EBADF, SS_IVCHAN)
94
95/* Call the callback or fail, and be void. */
96#define Perl_PerlIO_or_fail_void(f, callback, args) \
97 if (PerlIOValid(f)) { \
98 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\
99 if (tab && tab->callback) \
100 (*tab->callback) args; \
101 else \
102 SETERRNO(EINVAL, LIB_INVARG); \
103 } \
104 else \
105 SETERRNO(EBADF, SS_IVCHAN)
106
107#if defined(__osf__) && _XOPEN_SOURCE < 500
108extern int fseeko(FILE *, off_t, int);
109extern off_t ftello(FILE *);
110#endif
111
112#define NATIVE_0xd CR_NATIVE
113#define NATIVE_0xa LF_NATIVE
114
115EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
116
117int
118perlsio_binmode(FILE *fp, int iotype, int mode)
119{
120 /*
121 * This used to be contents of do_binmode in doio.c
122 */
123#ifdef DOSISH
124 dTHX;
125 PERL_UNUSED_ARG(iotype);
126# ifdef NETWARE
127 if (PerlLIO_setmode(fp, mode) != -1) {
128# else
129 if (PerlLIO_setmode(fileno(fp), mode) != -1) {
130# endif
131 return 1;
132 }
133 else
134 return 0;
135#else
136# if defined(USEMYBINMODE)
137 dTHX;
138# if defined(__CYGWIN__)
139 PERL_UNUSED_ARG(iotype);
140# endif
141 if (my_binmode(fp, iotype, mode) != FALSE)
142 return 1;
143 else
144 return 0;
145# else
146 PERL_UNUSED_ARG(fp);
147 PERL_UNUSED_ARG(iotype);
148 PERL_UNUSED_ARG(mode);
149 return 1;
150# endif
151#endif
152}
153
154#ifndef O_ACCMODE
155# define O_ACCMODE 3 /* Assume traditional implementation */
156#endif
157
158int
159PerlIO_intmode2str(int rawmode, char *mode, int *writing)
160{
161 const int result = rawmode & O_ACCMODE;
162 int ix = 0;
163 int ptype;
164 switch (result) {
165 case O_RDONLY:
166 ptype = IoTYPE_RDONLY;
167 break;
168 case O_WRONLY:
169 ptype = IoTYPE_WRONLY;
170 break;
171 case O_RDWR:
172 default:
173 ptype = IoTYPE_RDWR;
174 break;
175 }
176 if (writing)
177 *writing = (result != O_RDONLY);
178
179 if (result == O_RDONLY) {
180 mode[ix++] = 'r';
181 }
182#ifdef O_APPEND
183 else if (rawmode & O_APPEND) {
184 mode[ix++] = 'a';
185 if (result != O_WRONLY)
186 mode[ix++] = '+';
187 }
188#endif
189 else {
190 if (result == O_WRONLY)
191 mode[ix++] = 'w';
192 else {
193 mode[ix++] = 'r';
194 mode[ix++] = '+';
195 }
196 }
197#if O_BINARY != 0
198 /* Unless O_BINARY is different from zero, bit-and:ing
199 * with it won't do much good. */
200 if (rawmode & O_BINARY)
201 mode[ix++] = 'b';
202#endif
203 mode[ix] = '\0';
204 return ptype;
205}
206
207#ifndef PERLIO_LAYERS
208int
209PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
210{
211 if (!names || !*names
212 || strEQ(names, ":crlf")
213 || strEQ(names, ":raw")
214 || strEQ(names, ":bytes")
215 ) {
216 return 0;
217 }
218 Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names);
219 /*
220 * NOTREACHED
221 */
222 return -1;
223}
224
225void
226PerlIO_destruct(pTHX)
227{
228}
229
230int
231PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
232{
233 return perlsio_binmode(fp, iotype, mode);
234}
235
236PerlIO *
237PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
238{
239# if defined(PERL_MICRO)
240 return NULL;
241# elif defined(PERL_IMPLICIT_SYS)
242 return PerlSIO_fdupopen(f);
243# else
244# ifdef WIN32
245 return win32_fdupopen(f);
246# else
247 if (f) {
248 const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f));
249 if (fd >= 0) {
250 char mode[8];
251# ifdef DJGPP
252 const int omode = djgpp_get_stream_mode(f);
253# else
254 const int omode = fcntl(fd, F_GETFL);
255# endif
256 PerlIO_intmode2str(omode,mode,NULL);
257 /* the r+ is a hack */
258 return PerlIO_fdopen(fd, mode);
259 }
260 return NULL;
261 }
262 else {
263 SETERRNO(EBADF, SS_IVCHAN);
264 }
265# endif
266 return NULL;
267# endif
268}
269
270
271/*
272 * De-mux PerlIO_openn() into fdopen, freopen and fopen type entries
273 */
274
275PerlIO *
276PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
277 int imode, int perm, PerlIO *old, int narg, SV **args)
278{
279 if (narg) {
280 if (narg > 1) {
281 Perl_croak(aTHX_ "More than one argument to open");
282 }
283 if (*args == &PL_sv_undef)
284 return PerlIO_tmpfile();
285 else {
286 STRLEN len;
287 const char *name = SvPV_const(*args, len);
288 if (!IS_SAFE_PATHNAME(name, len, "open"))
289 return NULL;
290
291 if (*mode == IoTYPE_NUMERIC) {
292 fd = PerlLIO_open3_cloexec(name, imode, perm);
293 if (fd >= 0)
294 return PerlIO_fdopen(fd, mode + 1);
295 }
296 else if (old) {
297 return PerlIO_reopen(name, mode, old);
298 }
299 else {
300 return PerlIO_open(name, mode);
301 }
302 }
303 }
304 else {
305 return PerlIO_fdopen(fd, (char *) mode);
306 }
307 return NULL;
308}
309
310XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
311XS(XS_PerlIO__Layer__find)
312{
313 dXSARGS;
314 if (items < 2)
315 Perl_croak(aTHX_ "Usage class->find(name[,load])");
316 else {
317 const char * const name = SvPV_nolen_const(ST(1));
318 ST(0) = (strEQ(name, "crlf")
319 || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef;
320 XSRETURN(1);
321 }
322}
323
324
325void
326Perl_boot_core_PerlIO(pTHX)
327{
328 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
329}
330
331#endif
332
333
334/*======================================================================================*/
335/*
336 * Implement all the PerlIO interface ourselves.
337 */
338
339#include "perliol.h"
340
341void
342PerlIO_debug(const char *fmt, ...)
343{
344 va_list ap;
345 dSYS;
346
347 if (!DEBUG_i_TEST)
348 return;
349
350 va_start(ap, fmt);
351
352 if (!PL_perlio_debug_fd) {
353 if (!TAINTING_get &&
354 PerlProc_getuid() == PerlProc_geteuid() &&
355 PerlProc_getgid() == PerlProc_getegid()) {
356 const char * const s = PerlEnv_getenv("PERLIO_DEBUG");
357 if (s && *s)
358 PL_perlio_debug_fd = PerlLIO_open3_cloexec(s,
359 O_WRONLY | O_CREAT | O_APPEND, 0666);
360 else
361 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
362 } else {
363 /* tainting or set*id, so ignore the environment and send the
364 debug output to stderr, like other -D switches. */
365 PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */
366 }
367 }
368 if (PL_perlio_debug_fd > 0) {
369#ifdef USE_ITHREADS
370 const char * const s = CopFILE(PL_curcop);
371 /* Use fixed buffer as sv_catpvf etc. needs SVs */
372 char buffer[1024];
373 const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop));
374# ifdef USE_QUADMATH
375# ifdef HAS_VSNPRINTF
376 /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf()
377 should be, otherwise the system isn't likely to support quadmath.
378 Nothing should be calling PerlIO_debug() with floating point anyway.
379 */
380 const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
381# else
382 STATIC_ASSERT_STMT(0);
383# endif
384# else
385 const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap);
386# endif
387 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2));
388#else
389 const char *s = CopFILE(PL_curcop);
390 STRLEN len;
391 SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)",
392 (IV) CopLINE(PL_curcop));
393 Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap);
394
395 s = SvPV_const(sv, len);
396 PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len));
397 SvREFCNT_dec(sv);
398#endif
399 }
400 va_end(ap);
401}
402
403/*--------------------------------------------------------------------------------------*/
404
405/*
406 * Inner level routines
407 */
408
409/* check that the head field of each layer points back to the head */
410
411#ifdef DEBUGGING
412# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
413static void
414PerlIO_verify_head(pTHX_ PerlIO *f)
415{
416 PerlIOl *head, *p;
417 int seen = 0;
418# ifndef PERL_IMPLICIT_SYS
419 PERL_UNUSED_CONTEXT;
420# endif
421 if (!PerlIOValid(f))
422 return;
423 p = head = PerlIOBase(f)->head;
424 assert(p);
425 do {
426 assert(p->head == head);
427 if (p == (PerlIOl*)f)
428 seen = 1;
429 p = p->next;
430 } while (p);
431 assert(seen);
432}
433#else
434# define VERIFY_HEAD(f)
435#endif
436
437
438/*
439 * Table of pointers to the PerlIO structs (malloc'ed)
440 */
441#define PERLIO_TABLE_SIZE 64
442
443static void
444PerlIO_init_table(pTHX)
445{
446 if (PL_perlio)
447 return;
448 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
449}
450
451
452
453PerlIO *
454PerlIO_allocate(pTHX)
455{
456 /*
457 * Find a free slot in the table, allocating new table as necessary
458 */
459 PerlIOl **last;
460 PerlIOl *f;
461 last = &PL_perlio;
462 while ((f = *last)) {
463 int i;
464 last = (PerlIOl **) (f);
465 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
466 if (!((++f)->next)) {
467 goto good_exit;
468 }
469 }
470 }
471 Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
472 if (!f) {
473 return NULL;
474 }
475 *last = (PerlIOl*) f++;
476
477 good_exit:
478 f->flags = 0; /* lockcnt */
479 f->tab = NULL;
480 f->head = f;
481 return (PerlIO*) f;
482}
483
484#undef PerlIO_fdupopen
485PerlIO *
486PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
487{
488 if (PerlIOValid(f)) {
489 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
490 DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) );
491 if (tab && tab->Dup)
492 return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
493 else {
494 return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags);
495 }
496 }
497 else
498 SETERRNO(EBADF, SS_IVCHAN);
499
500 return NULL;
501}
502
503void
504PerlIO_cleantable(pTHX_ PerlIOl **tablep)
505{
506 PerlIOl * const table = *tablep;
507 if (table) {
508 int i;
509 PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
510 for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
511 PerlIOl * const f = table + i;
512 if (f->next) {
513 PerlIO_close(&(f->next));
514 }
515 }
516 Safefree(table);
517 *tablep = NULL;
518 }
519}
520
521
522PerlIO_list_t *
523PerlIO_list_alloc(pTHX)
524{
525 PerlIO_list_t *list;
526 PERL_UNUSED_CONTEXT;
527 Newxz(list, 1, PerlIO_list_t);
528 list->refcnt = 1;
529 return list;
530}
531
532void
533PerlIO_list_free(pTHX_ PerlIO_list_t *list)
534{
535 if (list) {
536 if (--list->refcnt == 0) {
537 if (list->array) {
538 IV i;
539 for (i = 0; i < list->cur; i++)
540 SvREFCNT_dec(list->array[i].arg);
541 Safefree(list->array);
542 }
543 Safefree(list);
544 }
545 }
546}
547
548void
549PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg)
550{
551 PerlIO_pair_t *p;
552 PERL_UNUSED_CONTEXT;
553
554 if (list->cur >= list->len) {
555 const IV new_len = list->len + 8;
556 if (list->array)
557 Renew(list->array, new_len, PerlIO_pair_t);
558 else
559 Newx(list->array, new_len, PerlIO_pair_t);
560 list->len = new_len;
561 }
562 p = &(list->array[list->cur++]);
563 p->funcs = funcs;
564 if ((p->arg = arg)) {
565 SvREFCNT_inc_simple_void_NN(arg);
566 }
567}
568
569PerlIO_list_t *
570PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param)
571{
572 PerlIO_list_t *list = NULL;
573 if (proto) {
574 int i;
575 list = PerlIO_list_alloc(aTHX);
576 for (i=0; i < proto->cur; i++) {
577 SV *arg = proto->array[i].arg;
578#ifdef USE_ITHREADS
579 if (arg && param)
580 arg = sv_dup(arg, param);
581#else
582 PERL_UNUSED_ARG(param);
583#endif
584 PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg);
585 }
586 }
587 return list;
588}
589
590void
591PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
592{
593#ifdef USE_ITHREADS
594 PerlIOl **table = &proto->Iperlio;
595 PerlIOl *f;
596 PL_perlio = NULL;
597 PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
598 PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
599 PerlIO_init_table(aTHX);
600 DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) );
601 while ((f = *table)) {
602 int i;
603 table = (PerlIOl **) (f++);
604 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
605 if (f->next) {
606 (void) fp_dup(&(f->next), 0, param);
607 }
608 f++;
609 }
610 }
611#else
612 PERL_UNUSED_CONTEXT;
613 PERL_UNUSED_ARG(proto);
614 PERL_UNUSED_ARG(param);
615#endif
616}
617
618void
619PerlIO_destruct(pTHX)
620{
621 PerlIOl **table = &PL_perlio;
622 PerlIOl *f;
623#ifdef USE_ITHREADS
624 DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) );
625#endif
626 while ((f = *table)) {
627 int i;
628 table = (PerlIOl **) (f++);
629 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
630 PerlIO *x = &(f->next);
631 const PerlIOl *l;
632 while ((l = *x)) {
633 if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
634 DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) );
635 PerlIO_flush(x);
636 PerlIO_pop(aTHX_ x);
637 }
638 else {
639 x = PerlIONext(x);
640 }
641 }
642 f++;
643 }
644 }
645}
646
647void
648PerlIO_pop(pTHX_ PerlIO *f)
649{
650 const PerlIOl *l = *f;
651 VERIFY_HEAD(f);
652 if (l) {
653 DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
654 l->tab ? l->tab->name : "(Null)") );
655 if (l->tab && l->tab->Popped) {
656 /*
657 * If popped returns non-zero do not free its layer structure
658 * it has either done so itself, or it is shared and still in
659 * use
660 */
661 if ((*l->tab->Popped) (aTHX_ f) != 0)
662 return;
663 }
664 if (PerlIO_lockcnt(f)) {
665 /* we're in use; defer freeing the structure */
666 PerlIOBase(f)->flags = PERLIO_F_CLEARED;
667 PerlIOBase(f)->tab = NULL;
668 }
669 else {
670 *f = l->next;
671 Safefree(l);
672 }
673
674 }
675}
676
677/* Return as an array the stack of layers on a filehandle. Note that
678 * the stack is returned top-first in the array, and there are three
679 * times as many array elements as there are layers in the stack: the
680 * first element of a layer triplet is the name, the second one is the
681 * arguments, and the third one is the flags. */
682
683AV *
684PerlIO_get_layers(pTHX_ PerlIO *f)
685{
686 AV * const av = newAV();
687
688 if (PerlIOValid(f)) {
689 PerlIOl *l = PerlIOBase(f);
690
691 while (l) {
692 /* There is some collusion in the implementation of
693 XS_PerlIO_get_layers - it knows that name and flags are
694 generated as fresh SVs here, and takes advantage of that to
695 "copy" them by taking a reference. If it changes here, it needs
696 to change there too. */
697 SV * const name = l->tab && l->tab->name ?
698 newSVpv(l->tab->name, 0) : &PL_sv_undef;
699 SV * const arg = l->tab && l->tab->Getarg ?
700 (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef;
701 av_push(av, name);
702 av_push(av, arg);
703 av_push(av, newSViv((IV)l->flags));
704 l = l->next;
705 }
706 }
707
708 return av;
709}
710
711/*--------------------------------------------------------------------------------------*/
712/*
713 * XS Interface for perl code
714 */
715
716PerlIO_funcs *
717PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
718{
719
720 IV i;
721 if ((SSize_t) len <= 0)
722 len = strlen(name);
723 for (i = 0; i < PL_known_layers->cur; i++) {
724 PerlIO_funcs * const f = PL_known_layers->array[i].funcs;
725 const STRLEN this_len = strlen(f->name);
726 if (this_len == len && memEQ(f->name, name, len)) {
727 DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) );
728 return f;
729 }
730 }
731 if (load && PL_subname && PL_def_layerlist
732 && PL_def_layerlist->cur >= 2) {
733 if (PL_in_load_module) {
734 Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
735 return NULL;
736 } else {
737 SV * const pkgsv = newSVpvs("PerlIO");
738 SV * const layer = newSVpvn(name, len);
739 CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0);
740 ENTER;
741 SAVEBOOL(PL_in_load_module);
742 if (cv) {
743 SAVEGENERICSV(PL_warnhook);
744 PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv)));
745 }
746 PL_in_load_module = TRUE;
747 /*
748 * The two SVs are magically freed by load_module
749 */
750 Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL);
751 LEAVE;
752 return PerlIO_find_layer(aTHX_ name, len, 0);
753 }
754 }
755 DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) );
756 return NULL;
757}
758
759#ifdef USE_ATTRIBUTES_FOR_PERLIO
760
761static int
762perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
763{
764 if (SvROK(sv)) {
765 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
766 PerlIO * const ifp = IoIFP(io);
767 PerlIO * const ofp = IoOFP(io);
768 Perl_warn(aTHX_ "set %" SVf " %p %p %p",
769 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
770 }
771 return 0;
772}
773
774static int
775perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
776{
777 if (SvROK(sv)) {
778 IO * const io = GvIOn(MUTABLE_GV(SvRV(sv)));
779 PerlIO * const ifp = IoIFP(io);
780 PerlIO * const ofp = IoOFP(io);
781 Perl_warn(aTHX_ "get %" SVf " %p %p %p",
782 SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp);
783 }
784 return 0;
785}
786
787static int
788perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
789{
790 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
791 return 0;
792}
793
794static int
795perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
796{
797 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
798 return 0;
799}
800
801MGVTBL perlio_vtab = {
802 perlio_mg_get,
803 perlio_mg_set,
804 NULL, /* len */
805 perlio_mg_clear,
806 perlio_mg_free
807};
808
809XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
810XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
811{
812 dXSARGS;
813 SV * const sv = SvRV(ST(1));
814 AV * const av = newAV();
815 MAGIC *mg;
816 int count = 0;
817 int i;
818 sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0);
819 SvRMAGICAL_off(sv);
820 mg = mg_find(sv, PERL_MAGIC_ext);
821 mg->mg_virtual = &perlio_vtab;
822 mg_magical(sv);
823 Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv));
824 for (i = 2; i < items; i++) {
825 STRLEN len;
826 const char * const name = SvPV_const(ST(i), len);
827 SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1);
828 if (layer) {
829 av_push(av, SvREFCNT_inc_simple_NN(layer));
830 }
831 else {
832 ST(count) = ST(i);
833 count++;
834 }
835 }
836 SvREFCNT_dec(av);
837 XSRETURN(count);
838}
839
840#endif /* USE_ATTRIBUTES_FOR_PERLIO */
841
842SV *
843PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
844{
845 HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD);
846 SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash);
847 return sv;
848}
849
850XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
851XS(XS_PerlIO__Layer__NoWarnings)
852{
853 /* This is used as a %SIG{__WARN__} handler to suppress warnings
854 during loading of layers.
855 */
856 dXSARGS;
857 PERL_UNUSED_VAR(items);
858 DEBUG_i(
859 if (items)
860 PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) );
861 XSRETURN(0);
862}
863
864XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
865XS(XS_PerlIO__Layer__find)
866{
867 dXSARGS;
868 if (items < 2)
869 Perl_croak(aTHX_ "Usage class->find(name[,load])");
870 else {
871 STRLEN len;
872 const char * const name = SvPV_const(ST(1), len);
873 const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0;
874 PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load);
875 ST(0) =
876 (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) :
877 &PL_sv_undef;
878 XSRETURN(1);
879 }
880}
881
882void
883PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
884{
885 if (!PL_known_layers)
886 PL_known_layers = PerlIO_list_alloc(aTHX);
887 PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL);
888 DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) );
889}
890
891int
892PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names)
893{
894 if (names) {
895 const char *s = names;
896 while (*s) {
897 while (isSPACE(*s) || *s == ':')
898 s++;
899 if (*s) {
900 STRLEN llen = 0;
901 const char *e = s;
902 const char *as = NULL;
903 STRLEN alen = 0;
904 if (!isIDFIRST(*s)) {
905 /*
906 * Message is consistent with how attribute lists are
907 * passed. Even though this means "foo : : bar" is
908 * seen as an invalid separator character.
909 */
910 const char q = ((*s == '\'') ? '"' : '\'');
911 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
912 "Invalid separator character %c%c%c in PerlIO layer specification %s",
913 q, *s, q, s);
914 SETERRNO(EINVAL, LIB_INVARG);
915 return -1;
916 }
917 do {
918 e++;
919 } while (isWORDCHAR(*e));
920 llen = e - s;
921 if (*e == '(') {
922 int nesting = 1;
923 as = ++e;
924 while (nesting) {
925 switch (*e++) {
926 case ')':
927 if (--nesting == 0)
928 alen = (e - 1) - as;
929 break;
930 case '(':
931 ++nesting;
932 break;
933 case '\\':
934 /*
935 * It's a nul terminated string, not allowed
936 * to \ the terminating null. Anything other
937 * character is passed over.
938 */
939 if (*e++) {
940 break;
941 }
942 /* Fall through */
943 case '\0':
944 e--;
945 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER),
946 "Argument list not closed for PerlIO layer \"%.*s\"",
947 (int) (e - s), s);
948 return -1;
949 default:
950 /*
951 * boring.
952 */
953 break;
954 }
955 }
956 }
957 if (e > s) {
958 PerlIO_funcs * const layer =
959 PerlIO_find_layer(aTHX_ s, llen, 1);
960 if (layer) {
961 SV *arg = NULL;
962 if (as)
963 arg = newSVpvn(as, alen);
964 PerlIO_list_push(aTHX_ av, layer,
965 (arg) ? arg : &PL_sv_undef);
966 SvREFCNT_dec(arg);
967 }
968 else {
969 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"",
970 (int) llen, s);
971 return -1;
972 }
973 }
974 s = e;
975 }
976 }
977 }
978 return 0;
979}
980
981void
982PerlIO_default_buffer(pTHX_ PerlIO_list_t *av)
983{
984 PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio;
985#ifdef PERLIO_USING_CRLF
986 tab = &PerlIO_crlf;
987#else
988 if (PerlIO_stdio.Set_ptrcnt)
989 tab = &PerlIO_stdio;
990#endif
991 DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) );
992 PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef);
993}
994
995SV *
996PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
997{
998 return av->array[n].arg;
999}
1000
1001PerlIO_funcs *
1002PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def)
1003{
1004 if (n >= 0 && n < av->cur) {
1005 DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n,
1006 av->array[n].funcs->name) );
1007 return av->array[n].funcs;
1008 }
1009 if (!def)
1010 Perl_croak(aTHX_ "panic: PerlIO layer array corrupt");
1011 return def;
1012}
1013
1014IV
1015PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1016{
1017 PERL_UNUSED_ARG(mode);
1018 PERL_UNUSED_ARG(arg);
1019 PERL_UNUSED_ARG(tab);
1020 if (PerlIOValid(f)) {
1021 PerlIO_flush(f);
1022 PerlIO_pop(aTHX_ f);
1023 return 0;
1024 }
1025 return -1;
1026}
1027
1028PERLIO_FUNCS_DECL(PerlIO_remove) = {
1029 sizeof(PerlIO_funcs),
1030 "pop",
1031 0,
1032 PERLIO_K_DUMMY | PERLIO_K_UTF8,
1033 PerlIOPop_pushed,
1034 NULL,
1035 PerlIOBase_open,
1036 NULL,
1037 NULL,
1038 NULL,
1039 NULL,
1040 NULL,
1041 NULL,
1042 NULL,
1043 NULL,
1044 NULL,
1045 NULL,
1046 NULL, /* flush */
1047 NULL, /* fill */
1048 NULL,
1049 NULL,
1050 NULL,
1051 NULL,
1052 NULL, /* get_base */
1053 NULL, /* get_bufsiz */
1054 NULL, /* get_ptr */
1055 NULL, /* get_cnt */
1056 NULL, /* set_ptrcnt */
1057};
1058
1059PerlIO_list_t *
1060PerlIO_default_layers(pTHX)
1061{
1062 if (!PL_def_layerlist) {
1063 const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO");
1064 PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix;
1065 PL_def_layerlist = PerlIO_list_alloc(aTHX);
1066 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix));
1067#if defined(WIN32)
1068 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32));
1069# if 0
1070 osLayer = &PerlIO_win32;
1071# endif
1072#endif
1073 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw));
1074 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio));
1075 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio));
1076 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf));
1077 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8));
1078 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove));
1079 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte));
1080 PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer,
1081 &PL_sv_undef);
1082 if (s) {
1083 PerlIO_parse_layers(aTHX_ PL_def_layerlist, s);
1084 }
1085 else {
1086 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1087 }
1088 }
1089 if (PL_def_layerlist->cur < 2) {
1090 PerlIO_default_buffer(aTHX_ PL_def_layerlist);
1091 }
1092 return PL_def_layerlist;
1093}
1094
1095void
1096Perl_boot_core_PerlIO(pTHX)
1097{
1098#ifdef USE_ATTRIBUTES_FOR_PERLIO
1099 newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES,
1100 __FILE__);
1101#endif
1102 newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
1103 newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
1104}
1105
1106PerlIO_funcs *
1107PerlIO_default_layer(pTHX_ I32 n)
1108{
1109 PerlIO_list_t * const av = PerlIO_default_layers(aTHX);
1110 if (n < 0)
1111 n += av->cur;
1112 return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio));
1113}
1114
1115#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1)
1116#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0)
1117
1118void
1119PerlIO_stdstreams(pTHX)
1120{
1121 if (!PL_perlio) {
1122 PerlIO_init_table(aTHX);
1123 PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
1124 PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
1125 PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
1126 }
1127}
1128
1129PerlIO *
1130PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
1131{
1132 VERIFY_HEAD(f);
1133 if (tab->fsize != sizeof(PerlIO_funcs)) {
1134 Perl_croak( aTHX_
1135 "%s (%" UVuf ") does not match %s (%" UVuf ")",
1136 "PerlIO layer function table size", (UV)tab->fsize,
1137 "size expected by this perl", (UV)sizeof(PerlIO_funcs) );
1138 }
1139 if (tab->size) {
1140 PerlIOl *l;
1141 if (tab->size < sizeof(PerlIOl)) {
1142 Perl_croak( aTHX_
1143 "%s (%" UVuf ") smaller than %s (%" UVuf ")",
1144 "PerlIO layer instance size", (UV)tab->size,
1145 "size expected by this perl", (UV)sizeof(PerlIOl) );
1146 }
1147 /* Real layer with a data area */
1148 if (f) {
1149 char *temp;
1150 Newxz(temp, tab->size, char);
1151 l = (PerlIOl*)temp;
1152 if (l) {
1153 l->next = *f;
1154 l->tab = (PerlIO_funcs*) tab;
1155 l->head = ((PerlIOl*)f)->head;
1156 *f = l;
1157 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
1158 (void*)f, tab->name,
1159 (mode) ? mode : "(Null)", (void*)arg) );
1160 if (*l->tab->Pushed &&
1161 (*l->tab->Pushed)
1162 (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1163 PerlIO_pop(aTHX_ f);
1164 return NULL;
1165 }
1166 }
1167 else
1168 return NULL;
1169 }
1170 }
1171 else if (f) {
1172 /* Pseudo-layer where push does its own stack adjust */
1173 DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
1174 (mode) ? mode : "(Null)", (void*)arg) );
1175 if (tab->Pushed &&
1176 (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) {
1177 return NULL;
1178 }
1179 }
1180 return f;
1181}
1182
1183PerlIO *
1184PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
1185 IV n, const char *mode, int fd, int imode, int perm,
1186 PerlIO *old, int narg, SV **args)
1187{
1188 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0));
1189 if (tab && tab->Open) {
1190 PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args);
1191 if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) {
1192 PerlIO_close(ret);
1193 return NULL;
1194 }
1195 return ret;
1196 }
1197 SETERRNO(EINVAL, LIB_INVARG);
1198 return NULL;
1199}
1200
1201IV
1202PerlIOBase_binmode(pTHX_ PerlIO *f)
1203{
1204 if (PerlIOValid(f)) {
1205 /* Is layer suitable for raw stream ? */
1206 if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
1207 /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
1208 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1209 }
1210 else {
1211 /* Not suitable - pop it */
1212 PerlIO_pop(aTHX_ f);
1213 }
1214 return 0;
1215 }
1216 return -1;
1217}
1218
1219IV
1220PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1221{
1222 PERL_UNUSED_ARG(mode);
1223 PERL_UNUSED_ARG(arg);
1224 PERL_UNUSED_ARG(tab);
1225
1226 if (PerlIOValid(f)) {
1227 PerlIO *t;
1228 const PerlIOl *l;
1229 PerlIO_flush(f);
1230 /*
1231 * Strip all layers that are not suitable for a raw stream
1232 */
1233 t = f;
1234 while (t && (l = *t)) {
1235 if (l->tab && l->tab->Binmode) {
1236 /* Has a handler - normal case */
1237 if ((*l->tab->Binmode)(aTHX_ t) == 0) {
1238 if (*t == l) {
1239 /* Layer still there - move down a layer */
1240 t = PerlIONext(t);
1241 }
1242 }
1243 else {
1244 return -1;
1245 }
1246 }
1247 else {
1248 /* No handler - pop it */
1249 PerlIO_pop(aTHX_ t);
1250 }
1251 }
1252 if (PerlIOValid(f)) {
1253 DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f,
1254 PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") );
1255 return 0;
1256 }
1257 }
1258 return -1;
1259}
1260
1261int
1262PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode,
1263 PerlIO_list_t *layers, IV n, IV max)
1264{
1265 int code = 0;
1266 while (n < max) {
1267 PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL);
1268 if (tab) {
1269 if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) {
1270 code = -1;
1271 break;
1272 }
1273 }
1274 n++;
1275 }
1276 return code;
1277}
1278
1279int
1280PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
1281{
1282 int code = 0;
1283 ENTER;
1284 save_scalar(PL_errgv);
1285 if (f && names) {
1286 PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX);
1287 code = PerlIO_parse_layers(aTHX_ layers, names);
1288 if (code == 0) {
1289 code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur);
1290 }
1291 PerlIO_list_free(aTHX_ layers);
1292 }
1293 LEAVE;
1294 return code;
1295}
1296
1297
1298/*--------------------------------------------------------------------------------------*/
1299/*
1300 * Given the abstraction above the public API functions
1301 */
1302
1303int
1304PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
1305{
1306 PERL_UNUSED_ARG(iotype);
1307 PERL_UNUSED_ARG(mode);
1308
1309 DEBUG_i(
1310 PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
1311 (PerlIOBase(f) && PerlIOBase(f)->tab) ?
1312 PerlIOBase(f)->tab->name : "(Null)",
1313 iotype, mode, (names) ? names : "(Null)") );
1314
1315 if (names) {
1316 /* Do not flush etc. if (e.g.) switching encodings.
1317 if a pushed layer knows it needs to flush lower layers
1318 (for example :unix which is never going to call them)
1319 it can do the flush when it is pushed.
1320 */
1321 return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0);
1322 }
1323 else {
1324 /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
1325#ifdef PERLIO_USING_CRLF
1326 /* Legacy binmode only has meaning if O_TEXT has a value distinct from
1327 O_BINARY so we can look for it in mode.
1328 */
1329 if (!(mode & O_BINARY)) {
1330 /* Text mode */
1331 /* FIXME?: Looking down the layer stack seems wrong,
1332 but is a way of reaching past (say) an encoding layer
1333 to flip CRLF-ness of the layer(s) below
1334 */
1335 while (*f) {
1336 /* Perhaps we should turn on bottom-most aware layer
1337 e.g. Ilya's idea that UNIX TTY could serve
1338 */
1339 if (PerlIOBase(f)->tab &&
1340 PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
1341 {
1342 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
1343 /* Not in text mode - flush any pending stuff and flip it */
1344 PerlIO_flush(f);
1345 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
1346 }
1347 /* Only need to turn it on in one layer so we are done */
1348 return TRUE;
1349 }
1350 f = PerlIONext(f);
1351 }
1352 /* Not finding a CRLF aware layer presumably means we are binary
1353 which is not what was requested - so we failed
1354 We _could_ push :crlf layer but so could caller
1355 */
1356 return FALSE;
1357 }
1358#endif
1359 /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
1360 So code that used to be here is now in PerlIORaw_pushed().
1361 */
1362 return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL));
1363 }
1364}
1365
1366int
1367PerlIO__close(pTHX_ PerlIO *f)
1368{
1369 if (PerlIOValid(f)) {
1370 PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1371 if (tab && tab->Close)
1372 return (*tab->Close)(aTHX_ f);
1373 else
1374 return PerlIOBase_close(aTHX_ f);
1375 }
1376 else {
1377 SETERRNO(EBADF, SS_IVCHAN);
1378 return -1;
1379 }
1380}
1381
1382int
1383Perl_PerlIO_close(pTHX_ PerlIO *f)
1384{
1385 const int code = PerlIO__close(aTHX_ f);
1386 while (PerlIOValid(f)) {
1387 PerlIO_pop(aTHX_ f);
1388 if (PerlIO_lockcnt(f))
1389 /* we're in use; the 'pop' deferred freeing the structure */
1390 f = PerlIONext(f);
1391 }
1392 return code;
1393}
1394
1395int
1396Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1397{
1398 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1399}
1400
1401
1402static PerlIO_funcs *
1403PerlIO_layer_from_ref(pTHX_ SV *sv)
1404{
1405 /*
1406 * For any scalar type load the handler which is bundled with perl
1407 */
1408 if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) {
1409 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
1410 /* This isn't supposed to happen, since PerlIO::scalar is core,
1411 * but could happen anyway in smaller installs or with PAR */
1412 if (!f)
1413 /* diag_listed_as: Unknown PerlIO layer "%s" */
1414 Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
1415 return f;
1416 }
1417
1418 /*
1419 * For other types allow if layer is known but don't try and load it
1420 */
1421 switch (SvTYPE(sv)) {
1422 case SVt_PVAV:
1423 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
1424 case SVt_PVHV:
1425 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
1426 case SVt_PVCV:
1427 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
1428 case SVt_PVGV:
1429 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
1430 default:
1431 return NULL;
1432 }
1433}
1434
1435PerlIO_list_t *
1436PerlIO_resolve_layers(pTHX_ const char *layers,
1437 const char *mode, int narg, SV **args)
1438{
1439 PerlIO_list_t *def = PerlIO_default_layers(aTHX);
1440 int incdef = 1;
1441 if (!PL_perlio)
1442 PerlIO_stdstreams(aTHX);
1443 if (narg) {
1444 SV * const arg = *args;
1445 /*
1446 * If it is a reference but not an object see if we have a handler
1447 * for it
1448 */
1449 if (SvROK(arg) && !SvOBJECT(SvRV(arg))) {
1450 PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg));
1451 if (handler) {
1452 def = PerlIO_list_alloc(aTHX);
1453 PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef);
1454 incdef = 0;
1455 }
1456 /*
1457 * Don't fail if handler cannot be found :via(...) etc. may do
1458 * something sensible else we will just stringfy and open
1459 * resulting string.
1460 */
1461 }
1462 }
1463 if (!layers || !*layers)
1464 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1465 if (layers && *layers) {
1466 PerlIO_list_t *av;
1467 if (incdef) {
1468 av = PerlIO_clone_list(aTHX_ def, NULL);
1469 }
1470 else {
1471 av = def;
1472 }
1473 if (PerlIO_parse_layers(aTHX_ av, layers) == 0) {
1474 return av;
1475 }
1476 else {
1477 PerlIO_list_free(aTHX_ av);
1478 return NULL;
1479 }
1480 }
1481 else {
1482 if (incdef)
1483 def->refcnt++;
1484 return def;
1485 }
1486}
1487
1488PerlIO *
1489PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
1490 int imode, int perm, PerlIO *f, int narg, SV **args)
1491{
1492 if (!f && narg == 1 && *args == &PL_sv_undef) {
1493 imode = PerlIOUnix_oflags(mode);
1494
1495 if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) {
1496 if (!layers || !*layers)
1497 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1498 if (layers && *layers)
1499 PerlIO_apply_layers(aTHX_ f, mode, layers);
1500 }
1501 }
1502 else {
1503 PerlIO_list_t *layera;
1504 IV n;
1505 PerlIO_funcs *tab = NULL;
1506 if (PerlIOValid(f)) {
1507 /*
1508 * This is "reopen" - it is not tested as perl does not use it
1509 * yet
1510 */
1511 PerlIOl *l = *f;
1512 layera = PerlIO_list_alloc(aTHX);
1513 while (l) {
1514 SV *arg = NULL;
1515 if (l->tab && l->tab->Getarg)
1516 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1517 PerlIO_list_push(aTHX_ layera, l->tab,
1518 (arg) ? arg : &PL_sv_undef);
1519 SvREFCNT_dec(arg);
1520 l = *PerlIONext(&l);
1521 }
1522 }
1523 else {
1524 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1525 if (!layera) {
1526 return NULL;
1527 }
1528 }
1529 /*
1530 * Start at "top" of layer stack
1531 */
1532 n = layera->cur - 1;
1533 while (n >= 0) {
1534 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1535 if (t && t->Open) {
1536 tab = t;
1537 break;
1538 }
1539 n--;
1540 }
1541 if (tab) {
1542 /*
1543 * Found that layer 'n' can do opens - call it
1544 */
1545 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1546 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1547 }
1548 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1549 tab->name, layers ? layers : "(Null)", mode, fd,
1550 imode, perm, (void*)f, narg, (void*)args) );
1551 if (tab->Open)
1552 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1553 f, narg, args);
1554 else {
1555 SETERRNO(EINVAL, LIB_INVARG);
1556 f = NULL;
1557 }
1558 if (f) {
1559 if (n + 1 < layera->cur) {
1560 /*
1561 * More layers above the one that we used to open -
1562 * apply them now
1563 */
1564 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1565 /* If pushing layers fails close the file */
1566 PerlIO_close(f);
1567 f = NULL;
1568 }
1569 }
1570 }
1571 }
1572 PerlIO_list_free(aTHX_ layera);
1573 }
1574 return f;
1575}
1576
1577
1578SSize_t
1579Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1580{
1581 PERL_ARGS_ASSERT_PERLIO_READ;
1582
1583 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1584}
1585
1586SSize_t
1587Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1588{
1589 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1590
1591 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1592}
1593
1594SSize_t
1595Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1596{
1597 PERL_ARGS_ASSERT_PERLIO_WRITE;
1598
1599 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1600}
1601
1602int
1603Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1604{
1605 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1606}
1607
1608Off_t
1609Perl_PerlIO_tell(pTHX_ PerlIO *f)
1610{
1611 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1612}
1613
1614int
1615Perl_PerlIO_flush(pTHX_ PerlIO *f)
1616{
1617 if (f) {
1618 if (*f) {
1619 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1620
1621 if (tab && tab->Flush)
1622 return (*tab->Flush) (aTHX_ f);
1623 else
1624 return 0; /* If no Flush defined, silently succeed. */
1625 }
1626 else {
1627 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1628 SETERRNO(EBADF, SS_IVCHAN);
1629 return -1;
1630 }
1631 }
1632 else {
1633 /*
1634 * Is it good API design to do flush-all on NULL, a potentially
1635 * erroneous input? Maybe some magical value (PerlIO*
1636 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1637 * things on fflush(NULL), but should we be bound by their design
1638 * decisions? --jhi
1639 */
1640 PerlIOl **table = &PL_perlio;
1641 PerlIOl *ff;
1642 int code = 0;
1643 while ((ff = *table)) {
1644 int i;
1645 table = (PerlIOl **) (ff++);
1646 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1647 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1648 code = -1;
1649 ff++;
1650 }
1651 }
1652 return code;
1653 }
1654}
1655
1656void
1657PerlIOBase_flush_linebuf(pTHX)
1658{
1659 PerlIOl **table = &PL_perlio;
1660 PerlIOl *f;
1661 while ((f = *table)) {
1662 int i;
1663 table = (PerlIOl **) (f++);
1664 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1665 if (f->next
1666 && (PerlIOBase(&(f->next))->
1667 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1668 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1669 PerlIO_flush(&(f->next));
1670 f++;
1671 }
1672 }
1673}
1674
1675int
1676Perl_PerlIO_fill(pTHX_ PerlIO *f)
1677{
1678 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1679}
1680
1681int
1682PerlIO_isutf8(PerlIO *f)
1683{
1684 if (PerlIOValid(f))
1685 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1686 else
1687 SETERRNO(EBADF, SS_IVCHAN);
1688
1689 return -1;
1690}
1691
1692int
1693Perl_PerlIO_eof(pTHX_ PerlIO *f)
1694{
1695 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1696}
1697
1698int
1699Perl_PerlIO_error(pTHX_ PerlIO *f)
1700{
1701 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1702}
1703
1704void
1705Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1706{
1707 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1708}
1709
1710void
1711Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1712{
1713 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1714}
1715
1716int
1717PerlIO_has_base(PerlIO *f)
1718{
1719 if (PerlIOValid(f)) {
1720 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1721
1722 if (tab)
1723 return (tab->Get_base != NULL);
1724 }
1725
1726 return 0;
1727}
1728
1729int
1730PerlIO_fast_gets(PerlIO *f)
1731{
1732 if (PerlIOValid(f)) {
1733 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1734 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1735
1736 if (tab)
1737 return (tab->Set_ptrcnt != NULL);
1738 }
1739 }
1740
1741 return 0;
1742}
1743
1744int
1745PerlIO_has_cntptr(PerlIO *f)
1746{
1747 if (PerlIOValid(f)) {
1748 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1749
1750 if (tab)
1751 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1752 }
1753
1754 return 0;
1755}
1756
1757int
1758PerlIO_canset_cnt(PerlIO *f)
1759{
1760 if (PerlIOValid(f)) {
1761 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1762
1763 if (tab)
1764 return (tab->Set_ptrcnt != NULL);
1765 }
1766
1767 return 0;
1768}
1769
1770STDCHAR *
1771Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1772{
1773 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1774}
1775
1776SSize_t
1777Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1778{
1779 /* Note that Get_bufsiz returns a Size_t */
1780 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1781}
1782
1783STDCHAR *
1784Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1785{
1786 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1787}
1788
1789SSize_t
1790Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1791{
1792 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1793}
1794
1795void
1796Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1797{
1798 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1799}
1800
1801void
1802Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1803{
1804 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1805}
1806
1807
1808/*--------------------------------------------------------------------------------------*/
1809/*
1810 * utf8 and raw dummy layers
1811 */
1812
1813IV
1814PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1815{
1816 PERL_UNUSED_CONTEXT;
1817 PERL_UNUSED_ARG(mode);
1818 PERL_UNUSED_ARG(arg);
1819 if (PerlIOValid(f)) {
1820 if (tab && tab->kind & PERLIO_K_UTF8)
1821 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1822 else
1823 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1824 return 0;
1825 }
1826 return -1;
1827}
1828
1829PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1830 sizeof(PerlIO_funcs),
1831 "utf8",
1832 0,
1833 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1834 PerlIOUtf8_pushed,
1835 NULL,
1836 PerlIOBase_open,
1837 NULL,
1838 NULL,
1839 NULL,
1840 NULL,
1841 NULL,
1842 NULL,
1843 NULL,
1844 NULL,
1845 NULL,
1846 NULL,
1847 NULL, /* flush */
1848 NULL, /* fill */
1849 NULL,
1850 NULL,
1851 NULL,
1852 NULL,
1853 NULL, /* get_base */
1854 NULL, /* get_bufsiz */
1855 NULL, /* get_ptr */
1856 NULL, /* get_cnt */
1857 NULL, /* set_ptrcnt */
1858};
1859
1860PERLIO_FUNCS_DECL(PerlIO_byte) = {
1861 sizeof(PerlIO_funcs),
1862 "bytes",
1863 0,
1864 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1865 PerlIOUtf8_pushed,
1866 NULL,
1867 PerlIOBase_open,
1868 NULL,
1869 NULL,
1870 NULL,
1871 NULL,
1872 NULL,
1873 NULL,
1874 NULL,
1875 NULL,
1876 NULL,
1877 NULL,
1878 NULL, /* flush */
1879 NULL, /* fill */
1880 NULL,
1881 NULL,
1882 NULL,
1883 NULL,
1884 NULL, /* get_base */
1885 NULL, /* get_bufsiz */
1886 NULL, /* get_ptr */
1887 NULL, /* get_cnt */
1888 NULL, /* set_ptrcnt */
1889};
1890
1891PERLIO_FUNCS_DECL(PerlIO_raw) = {
1892 sizeof(PerlIO_funcs),
1893 "raw",
1894 0,
1895 PERLIO_K_DUMMY,
1896 PerlIORaw_pushed,
1897 PerlIOBase_popped,
1898 PerlIOBase_open,
1899 NULL,
1900 NULL,
1901 NULL,
1902 NULL,
1903 NULL,
1904 NULL,
1905 NULL,
1906 NULL,
1907 NULL,
1908 NULL,
1909 NULL, /* flush */
1910 NULL, /* fill */
1911 NULL,
1912 NULL,
1913 NULL,
1914 NULL,
1915 NULL, /* get_base */
1916 NULL, /* get_bufsiz */
1917 NULL, /* get_ptr */
1918 NULL, /* get_cnt */
1919 NULL, /* set_ptrcnt */
1920};
1921/*--------------------------------------------------------------------------------------*/
1922/*--------------------------------------------------------------------------------------*/
1923/*
1924 * "Methods" of the "base class"
1925 */
1926
1927IV
1928PerlIOBase_fileno(pTHX_ PerlIO *f)
1929{
1930 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1931}
1932
1933char *
1934PerlIO_modestr(PerlIO * f, char *buf)
1935{
1936 char *s = buf;
1937 if (PerlIOValid(f)) {
1938 const IV flags = PerlIOBase(f)->flags;
1939 if (flags & PERLIO_F_APPEND) {
1940 *s++ = 'a';
1941 if (flags & PERLIO_F_CANREAD) {
1942 *s++ = '+';
1943 }
1944 }
1945 else if (flags & PERLIO_F_CANREAD) {
1946 *s++ = 'r';
1947 if (flags & PERLIO_F_CANWRITE)
1948 *s++ = '+';
1949 }
1950 else if (flags & PERLIO_F_CANWRITE) {
1951 *s++ = 'w';
1952 if (flags & PERLIO_F_CANREAD) {
1953 *s++ = '+';
1954 }
1955 }
1956#ifdef PERLIO_USING_CRLF
1957 if (!(flags & PERLIO_F_CRLF))
1958 *s++ = 'b';
1959#endif
1960 }
1961 *s = '\0';
1962 return buf;
1963}
1964
1965
1966IV
1967PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1968{
1969 PerlIOl * const l = PerlIOBase(f);
1970 PERL_UNUSED_CONTEXT;
1971 PERL_UNUSED_ARG(arg);
1972
1973 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1974 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1975 if (tab && tab->Set_ptrcnt != NULL)
1976 l->flags |= PERLIO_F_FASTGETS;
1977 if (mode) {
1978 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1979 mode++;
1980 switch (*mode++) {
1981 case 'r':
1982 l->flags |= PERLIO_F_CANREAD;
1983 break;
1984 case 'a':
1985 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1986 break;
1987 case 'w':
1988 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1989 break;
1990 default:
1991 SETERRNO(EINVAL, LIB_INVARG);
1992 return -1;
1993 }
1994#ifdef EBCDIC
1995 {
1996 /* The mode variable contains one positional parameter followed by
1997 * optional keyword parameters. The positional parameters must be
1998 * passed as lowercase characters. The keyword parameters can be
1999 * passed in mixed case. They must be separated by commas. Only one
2000 * instance of a keyword can be specified. */
2001 int comma = 0;
2002 while (*mode) {
2003 switch (*mode++) {
2004 case '+':
2005 if(!comma)
2006 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2007 break;
2008 case 'b':
2009 if(!comma)
2010 l->flags &= ~PERLIO_F_CRLF;
2011 break;
2012 case 't':
2013 if(!comma)
2014 l->flags |= PERLIO_F_CRLF;
2015 break;
2016 case ',':
2017 comma = 1;
2018 break;
2019 default:
2020 break;
2021 }
2022 }
2023 }
2024#else
2025 while (*mode) {
2026 switch (*mode++) {
2027 case '+':
2028 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2029 break;
2030 case 'b':
2031 l->flags &= ~PERLIO_F_CRLF;
2032 break;
2033 case 't':
2034 l->flags |= PERLIO_F_CRLF;
2035 break;
2036 default:
2037 SETERRNO(EINVAL, LIB_INVARG);
2038 return -1;
2039 }
2040 }
2041#endif
2042 }
2043 else {
2044 if (l->next) {
2045 l->flags |= l->next->flags &
2046 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2047 PERLIO_F_APPEND);
2048 }
2049 }
2050#if 0
2051 DEBUG_i(
2052 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2053 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2054 l->flags, PerlIO_modestr(f, temp));
2055 );
2056#endif
2057 return 0;
2058}
2059
2060IV
2061PerlIOBase_popped(pTHX_ PerlIO *f)
2062{
2063 PERL_UNUSED_CONTEXT;
2064 PERL_UNUSED_ARG(f);
2065 return 0;
2066}
2067
2068SSize_t
2069PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2070{
2071 /*
2072 * Save the position as current head considers it
2073 */
2074 const Off_t old = PerlIO_tell(f);
2075 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2076 PerlIOSelf(f, PerlIOBuf)->posn = old;
2077 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2078}
2079
2080SSize_t
2081PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2082{
2083 STDCHAR *buf = (STDCHAR *) vbuf;
2084 if (f) {
2085 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2086 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2087 SETERRNO(EBADF, SS_IVCHAN);
2088 PerlIO_save_errno(f);
2089 return 0;
2090 }
2091 while (count > 0) {
2092 get_cnt:
2093 {
2094 SSize_t avail = PerlIO_get_cnt(f);
2095 SSize_t take = 0;
2096 if (avail > 0)
2097 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2098 if (take > 0) {
2099 STDCHAR *ptr = PerlIO_get_ptr(f);
2100 Copy(ptr, buf, take, STDCHAR);
2101 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2102 count -= take;
2103 buf += take;
2104 if (avail == 0) /* set_ptrcnt could have reset avail */
2105 goto get_cnt;
2106 }
2107 if (count > 0 && avail <= 0) {
2108 if (PerlIO_fill(f) != 0)
2109 break;
2110 }
2111 }
2112 }
2113 return (buf - (STDCHAR *) vbuf);
2114 }
2115 return 0;
2116}
2117
2118IV
2119PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2120{
2121 PERL_UNUSED_CONTEXT;
2122 PERL_UNUSED_ARG(f);
2123 return 0;
2124}
2125
2126IV
2127PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2128{
2129 PERL_UNUSED_CONTEXT;
2130 PERL_UNUSED_ARG(f);
2131 return -1;
2132}
2133
2134IV
2135PerlIOBase_close(pTHX_ PerlIO *f)
2136{
2137 IV code = -1;
2138 if (PerlIOValid(f)) {
2139 PerlIO *n = PerlIONext(f);
2140 code = PerlIO_flush(f);
2141 PerlIOBase(f)->flags &=
2142 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2143 while (PerlIOValid(n)) {
2144 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2145 if (tab && tab->Close) {
2146 if ((*tab->Close)(aTHX_ n) != 0)
2147 code = -1;
2148 break;
2149 }
2150 else {
2151 PerlIOBase(n)->flags &=
2152 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2153 }
2154 n = PerlIONext(n);
2155 }
2156 }
2157 else {
2158 SETERRNO(EBADF, SS_IVCHAN);
2159 }
2160 return code;
2161}
2162
2163IV
2164PerlIOBase_eof(pTHX_ PerlIO *f)
2165{
2166 PERL_UNUSED_CONTEXT;
2167 if (PerlIOValid(f)) {
2168 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2169 }
2170 return 1;
2171}
2172
2173IV
2174PerlIOBase_error(pTHX_ PerlIO *f)
2175{
2176 PERL_UNUSED_CONTEXT;
2177 if (PerlIOValid(f)) {
2178 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2179 }
2180 return 1;
2181}
2182
2183void
2184PerlIOBase_clearerr(pTHX_ PerlIO *f)
2185{
2186 if (PerlIOValid(f)) {
2187 PerlIO * const n = PerlIONext(f);
2188 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2189 if (PerlIOValid(n))
2190 PerlIO_clearerr(n);
2191 }
2192}
2193
2194void
2195PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2196{
2197 PERL_UNUSED_CONTEXT;
2198 if (PerlIOValid(f)) {
2199 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2200 }
2201}
2202
2203SV *
2204PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2205{
2206 if (!arg)
2207 return NULL;
2208#ifdef USE_ITHREADS
2209 if (param) {
2210 arg = sv_dup(arg, param);
2211 SvREFCNT_inc_simple_void_NN(arg);
2212 return arg;
2213 }
2214 else {
2215 return newSVsv(arg);
2216 }
2217#else
2218 PERL_UNUSED_ARG(param);
2219 return newSVsv(arg);
2220#endif
2221}
2222
2223PerlIO *
2224PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2225{
2226 PerlIO * const nexto = PerlIONext(o);
2227 if (PerlIOValid(nexto)) {
2228 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2229 if (tab && tab->Dup)
2230 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2231 else
2232 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2233 }
2234 if (f) {
2235 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2236 SV *arg = NULL;
2237 char buf[8];
2238 assert(self);
2239 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2240 self->name,
2241 (void*)f, (void*)o, (void*)param) );
2242 if (self->Getarg)
2243 arg = (*self->Getarg)(aTHX_ o, param, flags);
2244 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2245 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2246 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2247 SvREFCNT_dec(arg);
2248 }
2249 return f;
2250}
2251
2252/* PL_perlio_fd_refcnt[] is in intrpvar.h */
2253
2254/* Must be called with PL_perlio_mutex locked. */
2255static void
2256S_more_refcounted_fds(pTHX_ const int new_fd)
2257 PERL_TSA_REQUIRES(PL_perlio_mutex)
2258{
2259 const int old_max = PL_perlio_fd_refcnt_size;
2260 const int new_max = 16 + (new_fd & ~15);
2261 int *new_array;
2262
2263#ifndef PERL_IMPLICIT_SYS
2264 PERL_UNUSED_CONTEXT;
2265#endif
2266
2267 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2268 old_max, new_fd, new_max) );
2269
2270 if (new_fd < old_max) {
2271 return;
2272 }
2273
2274 assert (new_max > new_fd);
2275
2276 /* Use plain realloc() since we need this memory to be really
2277 * global and visible to all the interpreters and/or threads. */
2278 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2279
2280 if (!new_array) {
2281 MUTEX_UNLOCK(&PL_perlio_mutex);
2282 croak_no_mem();
2283 }
2284
2285 PL_perlio_fd_refcnt_size = new_max;
2286 PL_perlio_fd_refcnt = new_array;
2287
2288 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2289 (void*)(new_array + old_max),
2290 new_max - old_max) );
2291
2292 Zero(new_array + old_max, new_max - old_max, int);
2293}
2294
2295
2296void
2297PerlIO_init(pTHX)
2298{
2299 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2300 PERL_UNUSED_CONTEXT;
2301}
2302
2303void
2304PerlIOUnix_refcnt_inc(int fd)
2305{
2306 dTHX;
2307 if (fd >= 0) {
2308
2309 MUTEX_LOCK(&PL_perlio_mutex);
2310 if (fd >= PL_perlio_fd_refcnt_size)
2311 S_more_refcounted_fds(aTHX_ fd);
2312
2313 PL_perlio_fd_refcnt[fd]++;
2314 if (PL_perlio_fd_refcnt[fd] <= 0) {
2315 /* diag_listed_as: refcnt_inc: fd %d%s */
2316 Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n",
2317 fd, PL_perlio_fd_refcnt[fd]);
2318 }
2319 DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n",
2320 fd, PL_perlio_fd_refcnt[fd]) );
2321
2322 MUTEX_UNLOCK(&PL_perlio_mutex);
2323 } else {
2324 /* diag_listed_as: refcnt_inc: fd %d%s */
2325 Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd);
2326 }
2327}
2328
2329int
2330PerlIOUnix_refcnt_dec(int fd)
2331{
2332 int cnt = 0;
2333 if (fd >= 0) {
2334#ifdef DEBUGGING
2335 dTHX;
2336#endif
2337 MUTEX_LOCK(&PL_perlio_mutex);
2338 if (fd >= PL_perlio_fd_refcnt_size) {
2339 /* diag_listed_as: refcnt_dec: fd %d%s */
2340 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2341 fd, PL_perlio_fd_refcnt_size);
2342 }
2343 if (PL_perlio_fd_refcnt[fd] <= 0) {
2344 /* diag_listed_as: refcnt_dec: fd %d%s */
2345 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2346 fd, PL_perlio_fd_refcnt[fd]);
2347 }
2348 cnt = --PL_perlio_fd_refcnt[fd];
2349 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2350 MUTEX_UNLOCK(&PL_perlio_mutex);
2351 } else {
2352 /* diag_listed_as: refcnt_dec: fd %d%s */
2353 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2354 }
2355 return cnt;
2356}
2357
2358int
2359PerlIOUnix_refcnt(int fd)
2360{
2361 dTHX;
2362 int cnt = 0;
2363 if (fd >= 0) {
2364 MUTEX_LOCK(&PL_perlio_mutex);
2365 if (fd >= PL_perlio_fd_refcnt_size) {
2366 /* diag_listed_as: refcnt: fd %d%s */
2367 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2368 fd, PL_perlio_fd_refcnt_size);
2369 }
2370 if (PL_perlio_fd_refcnt[fd] <= 0) {
2371 /* diag_listed_as: refcnt: fd %d%s */
2372 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2373 fd, PL_perlio_fd_refcnt[fd]);
2374 }
2375 cnt = PL_perlio_fd_refcnt[fd];
2376 MUTEX_UNLOCK(&PL_perlio_mutex);
2377 } else {
2378 /* diag_listed_as: refcnt: fd %d%s */
2379 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2380 }
2381 return cnt;
2382}
2383
2384void
2385PerlIO_cleanup(pTHX)
2386{
2387 int i;
2388#ifdef USE_ITHREADS
2389 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2390#else
2391 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2392#endif
2393
2394 /* Raise STDIN..STDERR refcount so we don't close them */
2395 for (i=0; i < 3; i++)
2396 PerlIOUnix_refcnt_inc(i);
2397 PerlIO_cleantable(aTHX_ &PL_perlio);
2398 /* Restore STDIN..STDERR refcount */
2399 for (i=0; i < 3; i++)
2400 PerlIOUnix_refcnt_dec(i);
2401
2402 if (PL_known_layers) {
2403 PerlIO_list_free(aTHX_ PL_known_layers);
2404 PL_known_layers = NULL;
2405 }
2406 if (PL_def_layerlist) {
2407 PerlIO_list_free(aTHX_ PL_def_layerlist);
2408 PL_def_layerlist = NULL;
2409 }
2410}
2411
2412void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2413{
2414#if 0
2415/* XXX we can't rely on an interpreter being present at this late stage,
2416 XXX so we can't use a function like PerlLIO_write that relies on one
2417 being present (at least in win32) :-(.
2418 Disable for now.
2419*/
2420# ifdef DEBUGGING
2421 {
2422 /* By now all filehandles should have been closed, so any
2423 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2424 * errors. */
2425#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2426#define PERLIO_TEARDOWN_MESSAGE_FD 2
2427 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2428 int i;
2429 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2430 if (PL_perlio_fd_refcnt[i]) {
2431 const STRLEN len =
2432 my_snprintf(buf, sizeof(buf),
2433 "PerlIO_teardown: fd %d refcnt=%d\n",
2434 i, PL_perlio_fd_refcnt[i]);
2435 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2436 }
2437 }
2438 }
2439# endif
2440#endif
2441 /* Not bothering with PL_perlio_mutex since by now
2442 * all the interpreters are gone. */
2443 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2444 && PL_perlio_fd_refcnt) {
2445 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2446 PL_perlio_fd_refcnt = NULL;
2447 PL_perlio_fd_refcnt_size = 0;
2448 }
2449}
2450
2451/*--------------------------------------------------------------------------------------*/
2452/*
2453 * Bottom-most level for UNIX-like case
2454 */
2455
2456typedef struct {
2457 struct _PerlIO base; /* The generic part */
2458 int fd; /* UNIX like file descriptor */
2459 int oflags; /* open/fcntl flags */
2460} PerlIOUnix;
2461
2462static void
2463S_lockcnt_dec(pTHX_ const void* f)
2464{
2465#ifndef PERL_IMPLICIT_SYS
2466 PERL_UNUSED_CONTEXT;
2467#endif
2468 PerlIO_lockcnt((PerlIO*)f)--;
2469}
2470
2471
2472/* call the signal handler, and if that handler happens to clear
2473 * this handle, free what we can and return true */
2474
2475static bool
2476S_perlio_async_run(pTHX_ PerlIO* f) {
2477 ENTER;
2478 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2479 PerlIO_lockcnt(f)++;
2480 PERL_ASYNC_CHECK();
2481 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2482 LEAVE;
2483 return 0;
2484 }
2485 /* we've just run some perl-level code that could have done
2486 * anything, including closing the file or clearing this layer.
2487 * If so, free any lower layers that have already been
2488 * cleared, then return an error. */
2489 while (PerlIOValid(f) &&
2490 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2491 {
2492 const PerlIOl *l = *f;
2493 *f = l->next;
2494 Safefree(l);
2495 }
2496 LEAVE;
2497 return 1;
2498}
2499
2500int
2501PerlIOUnix_oflags(const char *mode)
2502{
2503 int oflags = -1;
2504 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2505 mode++;
2506 switch (*mode) {
2507 case 'r':
2508 oflags = O_RDONLY;
2509 if (*++mode == '+') {
2510 oflags = O_RDWR;
2511 mode++;
2512 }
2513 break;
2514
2515 case 'w':
2516 oflags = O_CREAT | O_TRUNC;
2517 if (*++mode == '+') {
2518 oflags |= O_RDWR;
2519 mode++;
2520 }
2521 else
2522 oflags |= O_WRONLY;
2523 break;
2524
2525 case 'a':
2526 oflags = O_CREAT | O_APPEND;
2527 if (*++mode == '+') {
2528 oflags |= O_RDWR;
2529 mode++;
2530 }
2531 else
2532 oflags |= O_WRONLY;
2533 break;
2534 }
2535
2536 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2537
2538 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2539 * of them in, and then bit-and-masking the other them away, won't
2540 * have much of an effect. */
2541 switch (*mode) {
2542 case 'b':
2543#if O_TEXT != O_BINARY
2544 oflags |= O_BINARY;
2545 oflags &= ~O_TEXT;
2546#endif
2547 mode++;
2548 break;
2549 case 't':
2550#if O_TEXT != O_BINARY
2551 oflags |= O_TEXT;
2552 oflags &= ~O_BINARY;
2553#endif
2554 mode++;
2555 break;
2556 default:
2557#if O_BINARY != 0
2558 /* bit-or:ing with zero O_BINARY would be useless. */
2559 /*
2560 * If neither "t" nor "b" was specified, open the file
2561 * in O_BINARY mode.
2562 *
2563 * Note that if something else than the zero byte was seen
2564 * here (e.g. bogus mode "rx"), just few lines later we will
2565 * set the errno and invalidate the flags.
2566 */
2567 oflags |= O_BINARY;
2568#endif
2569 break;
2570 }
2571 if (*mode || oflags == -1) {
2572 SETERRNO(EINVAL, LIB_INVARG);
2573 oflags = -1;
2574 }
2575 return oflags;
2576}
2577
2578IV
2579PerlIOUnix_fileno(pTHX_ PerlIO *f)
2580{
2581 PERL_UNUSED_CONTEXT;
2582 return PerlIOSelf(f, PerlIOUnix)->fd;
2583}
2584
2585static void
2586PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2587{
2588 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2589#if defined(WIN32)
2590 Stat_t st;
2591 if (PerlLIO_fstat(fd, &st) == 0) {
2592 if (!S_ISREG(st.st_mode)) {
2593 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2594 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2595 }
2596 else {
2597 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2598 }
2599 }
2600#endif
2601 s->fd = fd;
2602 s->oflags = imode;
2603 PerlIOUnix_refcnt_inc(fd);
2604 PERL_UNUSED_CONTEXT;
2605}
2606
2607IV
2608PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2609{
2610 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2611 if (*PerlIONext(f)) {
2612 /* We never call down so do any pending stuff now */
2613 PerlIO_flush(PerlIONext(f));
2614 /*
2615 * XXX could (or should) we retrieve the oflags from the open file
2616 * handle rather than believing the "mode" we are passed in? XXX
2617 * Should the value on NULL mode be 0 or -1?
2618 */
2619 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2620 mode ? PerlIOUnix_oflags(mode) : -1);
2621 }
2622 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2623
2624 return code;
2625}
2626
2627IV
2628PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2629{
2630 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2631 Off_t new_loc;
2632 PERL_UNUSED_CONTEXT;
2633 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2634#ifdef ESPIPE
2635 SETERRNO(ESPIPE, LIB_INVARG);
2636#else
2637 SETERRNO(EINVAL, LIB_INVARG);
2638#endif
2639 return -1;
2640 }
2641 new_loc = PerlLIO_lseek(fd, offset, whence);
2642 if (new_loc == (Off_t) - 1)
2643 return -1;
2644 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2645 return 0;
2646}
2647
2648PerlIO *
2649PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2650 IV n, const char *mode, int fd, int imode,
2651 int perm, PerlIO *f, int narg, SV **args)
2652{
2653 bool known_cloexec = 0;
2654 if (PerlIOValid(f)) {
2655 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2656 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2657 }
2658 if (narg > 0) {
2659 if (*mode == IoTYPE_NUMERIC)
2660 mode++;
2661 else {
2662 imode = PerlIOUnix_oflags(mode);
2663#ifdef VMS
2664 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2665#else
2666 perm = 0666;
2667#endif
2668 }
2669 if (imode != -1) {
2670 STRLEN len;
2671 const char *path = SvPV_const(*args, len);
2672 if (!IS_SAFE_PATHNAME(path, len, "open"))
2673 return NULL;
2674 fd = PerlLIO_open3_cloexec(path, imode, perm);
2675 known_cloexec = 1;
2676 }
2677 }
2678 if (fd >= 0) {
2679 if (known_cloexec)
2680 setfd_inhexec_for_sysfd(fd);
2681 else
2682 setfd_cloexec_or_inhexec_by_sysfdness(fd);
2683 if (*mode == IoTYPE_IMPLICIT)
2684 mode++;
2685 if (!f) {
2686 f = PerlIO_allocate(aTHX);
2687 }
2688 if (!PerlIOValid(f)) {
2689 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2690 PerlLIO_close(fd);
2691 return NULL;
2692 }
2693 }
2694 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2695 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2696 if (*mode == IoTYPE_APPEND)
2697 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2698 return f;
2699 }
2700 else {
2701 if (f) {
2702 NOOP;
2703 /*
2704 * FIXME: pop layers ???
2705 */
2706 }
2707 return NULL;
2708 }
2709}
2710
2711PerlIO *
2712PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2713{
2714 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2715 int fd = os->fd;
2716 if (flags & PERLIO_DUP_FD) {
2717 fd = PerlLIO_dup_cloexec(fd);
2718 if (fd >= 0)
2719 setfd_inhexec_for_sysfd(fd);
2720 }
2721 if (fd >= 0) {
2722 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2723 if (f) {
2724 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2725 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2726 return f;
2727 }
2728 PerlLIO_close(fd);
2729 }
2730 return NULL;
2731}
2732
2733
2734SSize_t
2735PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2736{
2737 int fd;
2738 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2739 return -1;
2740 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2741 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2742 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2743 return 0;
2744 }
2745 while (1) {
2746 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2747 if (len >= 0 || errno != EINTR) {
2748 if (len < 0) {
2749 if (errno != EAGAIN) {
2750 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2751 PerlIO_save_errno(f);
2752 }
2753 }
2754 else if (len == 0 && count != 0) {
2755 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2756 SETERRNO(0,0);
2757 }
2758 return len;
2759 }
2760 /* EINTR */
2761 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2762 return -1;
2763 }
2764 NOT_REACHED; /*NOTREACHED*/
2765}
2766
2767SSize_t
2768PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2769{
2770 int fd;
2771 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2772 return -1;
2773 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2774 while (1) {
2775 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2776 if (len >= 0 || errno != EINTR) {
2777 if (len < 0) {
2778 if (errno != EAGAIN) {
2779 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2780 PerlIO_save_errno(f);
2781 }
2782 }
2783 return len;
2784 }
2785 /* EINTR */
2786 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2787 return -1;
2788 }
2789 NOT_REACHED; /*NOTREACHED*/
2790}
2791
2792Off_t
2793PerlIOUnix_tell(pTHX_ PerlIO *f)
2794{
2795 PERL_UNUSED_CONTEXT;
2796
2797 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2798}
2799
2800
2801IV
2802PerlIOUnix_close(pTHX_ PerlIO *f)
2803{
2804 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2805 int code = 0;
2806 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2807 code = PerlIOBase_close(aTHX_ f);
2808 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2809 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2810 return 0;
2811 }
2812 }
2813 else {
2814 SETERRNO(EBADF,SS_IVCHAN);
2815 return -1;
2816 }
2817 while (PerlLIO_close(fd) != 0) {
2818 if (errno != EINTR) {
2819 code = -1;
2820 break;
2821 }
2822 /* EINTR */
2823 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2824 return -1;
2825 }
2826 if (code == 0) {
2827 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2828 }
2829 return code;
2830}
2831
2832PERLIO_FUNCS_DECL(PerlIO_unix) = {
2833 sizeof(PerlIO_funcs),
2834 "unix",
2835 sizeof(PerlIOUnix),
2836 PERLIO_K_RAW,
2837 PerlIOUnix_pushed,
2838 PerlIOBase_popped,
2839 PerlIOUnix_open,
2840 PerlIOBase_binmode, /* binmode */
2841 NULL,
2842 PerlIOUnix_fileno,
2843 PerlIOUnix_dup,
2844 PerlIOUnix_read,
2845 PerlIOBase_unread,
2846 PerlIOUnix_write,
2847 PerlIOUnix_seek,
2848 PerlIOUnix_tell,
2849 PerlIOUnix_close,
2850 PerlIOBase_noop_ok, /* flush */
2851 PerlIOBase_noop_fail, /* fill */
2852 PerlIOBase_eof,
2853 PerlIOBase_error,
2854 PerlIOBase_clearerr,
2855 PerlIOBase_setlinebuf,
2856 NULL, /* get_base */
2857 NULL, /* get_bufsiz */
2858 NULL, /* get_ptr */
2859 NULL, /* get_cnt */
2860 NULL, /* set_ptrcnt */
2861};
2862
2863/*--------------------------------------------------------------------------------------*/
2864/*
2865 * stdio as a layer
2866 */
2867
2868#if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2869/* perl5.8 - This ensures the last minute VMS ungetc fix is not
2870 broken by the last second glibc 2.3 fix
2871 */
2872# define STDIO_BUFFER_WRITABLE
2873#endif
2874
2875
2876typedef struct {
2877 struct _PerlIO base;
2878 FILE *stdio; /* The stream */
2879} PerlIOStdio;
2880
2881IV
2882PerlIOStdio_fileno(pTHX_ PerlIO *f)
2883{
2884 PERL_UNUSED_CONTEXT;
2885
2886 if (PerlIOValid(f)) {
2887 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2888 if (s)
2889 return PerlSIO_fileno(s);
2890 }
2891 errno = EBADF;
2892 return -1;
2893}
2894
2895char *
2896PerlIOStdio_mode(const char *mode, char *tmode)
2897{
2898 char * const ret = tmode;
2899 if (mode) {
2900 while (*mode) {
2901 *tmode++ = *mode++;
2902 }
2903 }
2904#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2905 *tmode++ = 'b';
2906#endif
2907 *tmode = '\0';
2908 return ret;
2909}
2910
2911IV
2912PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2913{
2914 PerlIO *n;
2915 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2916 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2917 if (toptab == tab) {
2918 /* Top is already stdio - pop self (duplicate) and use original */
2919 PerlIO_pop(aTHX_ f);
2920 return 0;
2921 } else {
2922 const int fd = PerlIO_fileno(n);
2923 char tmode[8];
2924 FILE *stdio;
2925 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2926 mode = PerlIOStdio_mode(mode, tmode)))) {
2927 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2928 /* We never call down so do any pending stuff now */
2929 PerlIO_flush(PerlIONext(f));
2930 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2931 }
2932 else {
2933 return -1;
2934 }
2935 }
2936 }
2937 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2938}
2939
2940
2941PerlIO *
2942PerlIO_importFILE(FILE *stdio, const char *mode)
2943{
2944 dTHX;
2945 PerlIO *f = NULL;
2946#ifdef EBCDIC
2947 int rc;
2948 char filename[FILENAME_MAX];
2949 fldata_t fileinfo;
2950#endif
2951 if (stdio) {
2952 PerlIOStdio *s;
2953 int fd0 = fileno(stdio);
2954 if (fd0 < 0) {
2955#ifdef EBCDIC
2956 rc = fldata(stdio,filename,&fileinfo);
2957 if(rc != 0){
2958 return NULL;
2959 }
2960 if(fileinfo.__dsorgHFS){
2961 return NULL;
2962 }
2963 /*This MVS dataset , OK!*/
2964#else
2965 return NULL;
2966#endif
2967 }
2968 if (!mode || !*mode) {
2969 /* We need to probe to see how we can open the stream
2970 so start with read/write and then try write and read
2971 we dup() so that we can fclose without loosing the fd.
2972
2973 Note that the errno value set by a failing fdopen
2974 varies between stdio implementations.
2975 */
2976 const int fd = PerlLIO_dup_cloexec(fd0);
2977 FILE *f2;
2978 if (fd < 0) {
2979 return f;
2980 }
2981 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2982 if (!f2) {
2983 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2984 }
2985 if (!f2) {
2986 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2987 }
2988 if (!f2) {
2989 /* Don't seem to be able to open */
2990 PerlLIO_close(fd);
2991 return f;
2992 }
2993 fclose(f2);
2994 }
2995 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
2996 s = PerlIOSelf(f, PerlIOStdio);
2997 s->stdio = stdio;
2998 fd0 = fileno(stdio);
2999 if(fd0 != -1){
3000 PerlIOUnix_refcnt_inc(fd0);
3001 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3002 }
3003#ifdef EBCDIC
3004 else{
3005 rc = fldata(stdio,filename,&fileinfo);
3006 if(rc != 0){
3007 PerlIOUnix_refcnt_inc(fd0);
3008 }
3009 if(fileinfo.__dsorgHFS){
3010 PerlIOUnix_refcnt_inc(fd0);
3011 }
3012 /*This MVS dataset , OK!*/
3013 }
3014#endif
3015 }
3016 }
3017 return f;
3018}
3019
3020PerlIO *
3021PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3022 IV n, const char *mode, int fd, int imode,
3023 int perm, PerlIO *f, int narg, SV **args)
3024{
3025 char tmode[8];
3026 if (PerlIOValid(f)) {
3027 STRLEN len;
3028 const char * const path = SvPV_const(*args, len);
3029 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3030 FILE *stdio;
3031 if (!IS_SAFE_PATHNAME(path, len, "open"))
3032 return NULL;
3033 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3034 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3035 s->stdio);
3036 if (!s->stdio)
3037 return NULL;
3038 s->stdio = stdio;
3039 fd = fileno(stdio);
3040 PerlIOUnix_refcnt_inc(fd);
3041 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3042 return f;
3043 }
3044 else {
3045 if (narg > 0) {
3046 STRLEN len;
3047 const char * const path = SvPV_const(*args, len);
3048 if (!IS_SAFE_PATHNAME(path, len, "open"))
3049 return NULL;
3050 if (*mode == IoTYPE_NUMERIC) {
3051 mode++;
3052 fd = PerlLIO_open3_cloexec(path, imode, perm);
3053 }
3054 else {
3055 FILE *stdio;
3056 bool appended = FALSE;
3057#ifdef __CYGWIN__
3058 /* Cygwin wants its 'b' early. */
3059 appended = TRUE;
3060 mode = PerlIOStdio_mode(mode, tmode);
3061#endif
3062 stdio = PerlSIO_fopen(path, mode);
3063 if (stdio) {
3064 if (!f) {
3065 f = PerlIO_allocate(aTHX);
3066 }
3067 if (!appended)
3068 mode = PerlIOStdio_mode(mode, tmode);
3069 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3070 if (f) {
3071 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3072 fd = fileno(stdio);
3073 PerlIOUnix_refcnt_inc(fd);
3074 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3075 } else {
3076 PerlSIO_fclose(stdio);
3077 }
3078 return f;
3079 }
3080 else {
3081 return NULL;
3082 }
3083 }
3084 }
3085 if (fd >= 0) {
3086 FILE *stdio = NULL;
3087 int init = 0;
3088 if (*mode == IoTYPE_IMPLICIT) {
3089 init = 1;
3090 mode++;
3091 }
3092 if (init) {
3093 switch (fd) {
3094 case 0:
3095 stdio = PerlSIO_stdin;
3096 break;
3097 case 1:
3098 stdio = PerlSIO_stdout;
3099 break;
3100 case 2:
3101 stdio = PerlSIO_stderr;
3102 break;
3103 }
3104 }
3105 else {
3106 stdio = PerlSIO_fdopen(fd, mode =
3107 PerlIOStdio_mode(mode, tmode));
3108 }
3109 if (stdio) {
3110 if (!f) {
3111 f = PerlIO_allocate(aTHX);
3112 }
3113 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3114 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3115 fd = fileno(stdio);
3116 PerlIOUnix_refcnt_inc(fd);
3117 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3118 }
3119 return f;
3120 }
3121 PerlLIO_close(fd);
3122 }
3123 }
3124 return NULL;
3125}
3126
3127PerlIO *
3128PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3129{
3130 /* This assumes no layers underneath - which is what
3131 happens, but is not how I remember it. NI-S 2001/10/16
3132 */
3133 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3134 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3135 const int fd = fileno(stdio);
3136 char mode[8];
3137 if (flags & PERLIO_DUP_FD) {
3138 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
3139 if (dfd >= 0) {
3140 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3141 goto set_this;
3142 }
3143 else {
3144 NOOP;
3145 /* FIXME: To avoid messy error recovery if dup fails
3146 re-use the existing stdio as though flag was not set
3147 */
3148 }
3149 }
3150 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3151 set_this:
3152 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3153 if(stdio) {
3154 int fd = fileno(stdio);
3155 PerlIOUnix_refcnt_inc(fd);
3156 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3157 }
3158 }
3159 return f;
3160}
3161
3162static int
3163PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3164{
3165 PERL_UNUSED_CONTEXT;
3166
3167 /* XXX this could use PerlIO_canset_fileno() and
3168 * PerlIO_set_fileno() support from Configure
3169 */
3170#if defined(HAS_FDCLOSE)
3171 return fdclose(f, NULL) == 0 ? 1 : 0;
3172#elif defined(__UCLIBC__)
3173 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3174 f->__filedes = -1;
3175 return 1;
3176#elif defined(__GLIBC__)
3177 /* There may be a better way for GLIBC:
3178 - libio.h defines a flag to not close() on cleanup
3179 */
3180 f->_fileno = -1;
3181 return 1;
3182#elif defined(__sun)
3183 PERL_UNUSED_ARG(f);
3184 return 0;
3185#elif defined(__hpux)
3186 f->__fileH = 0xff;
3187 f->__fileL = 0xff;
3188 return 1;
3189 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3190 your platform does not have special entry try this one.
3191 [For OSF only have confirmation for Tru64 (alpha)
3192 but assume other OSFs will be similar.]
3193 */
3194#elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3195 f->_file = -1;
3196 return 1;
3197#elif defined(__FreeBSD__)
3198 /* There may be a better way on FreeBSD:
3199 - we could insert a dummy func in the _close function entry
3200 f->_close = (int (*)(void *)) dummy_close;
3201 */
3202 f->_file = -1;
3203 return 1;
3204#elif defined(__OpenBSD__)
3205 /* There may be a better way on OpenBSD:
3206 - we could insert a dummy func in the _close function entry
3207 f->_close = (int (*)(void *)) dummy_close;
3208 */
3209 f->_file = -1;
3210 return 1;
3211#elif defined(__EMX__)
3212 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3213 f->_handle = -1;
3214 return 1;
3215#elif defined(__CYGWIN__)
3216 /* There may be a better way on CYGWIN:
3217 - we could insert a dummy func in the _close function entry
3218 f->_close = (int (*)(void *)) dummy_close;
3219 */
3220 f->_file = -1;
3221 return 1;
3222#elif defined(WIN32)
3223 PERLIO_FILE_file(f) = -1;
3224 return 1;
3225#else
3226# if 0
3227 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3228 (which isn't thread safe) instead
3229 */
3230# error "Don't know how to set FILE.fileno on your platform"
3231# endif
3232 PERL_UNUSED_ARG(f);
3233 return 0;
3234#endif
3235}
3236
3237IV
3238PerlIOStdio_close(pTHX_ PerlIO *f)
3239{
3240 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3241 if (!stdio) {
3242 errno = EBADF;
3243 return -1;
3244 }
3245 else {
3246 const int fd = fileno(stdio);
3247 int invalidate = 0;
3248 IV result = 0;
3249 int dupfd = -1;
3250 dSAVEDERRNO;
3251#ifdef SOCKS5_VERSION_NAME
3252 /* Socks lib overrides close() but stdio isn't linked to
3253 that library (though we are) - so we must call close()
3254 on sockets on stdio's behalf.
3255 */
3256 int optval;
3257 Sock_size_t optlen = sizeof(int);
3258 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3259 invalidate = 1;
3260#endif
3261 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3262 that a subsequent fileno() on it returns -1. Don't want to croak()
3263 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3264 trying to close an already closed handle which somehow it still has
3265 a reference to. (via.xs, I'm looking at you). */
3266 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3267 /* File descriptor still in use */
3268 invalidate = 1;
3269 }
3270 if (invalidate) {
3271 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3272 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3273 return 0;
3274 if (stdio == stdout || stdio == stderr)
3275 return PerlIO_flush(f);
3276 }
3277 MUTEX_LOCK(&PL_perlio_mutex);
3278 /* Right. We need a mutex here because for a brief while we
3279 will have the situation that fd is actually closed. Hence if
3280 a second thread were to get into this block, its dup() would
3281 likely return our fd as its dupfd. (after all, it is closed)
3282 Then if we get to the dup2() first, we blat the fd back
3283 (messing up its temporary as a side effect) only for it to
3284 then close its dupfd (== our fd) in its close(dupfd) */
3285
3286 /* There is, of course, a race condition, that any other thread
3287 trying to input/output/whatever on this fd will be stuffed
3288 for the duration of this little manoeuvrer. Perhaps we
3289 should hold an IO mutex for the duration of every IO
3290 operation if we know that invalidate doesn't work on this
3291 platform, but that would suck, and could kill performance.
3292
3293 Except that correctness trumps speed.
3294 Advice from klortho #11912. */
3295 if (invalidate) {
3296 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3297 Use Sarathy's trick from maint-5.6 to invalidate the
3298 fileno slot of the FILE *
3299 */
3300 result = PerlIO_flush(f);
3301 SAVE_ERRNO;
3302 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3303 if (!invalidate) {
3304 dupfd = PerlLIO_dup_cloexec(fd);
3305#ifdef USE_ITHREADS
3306 if (dupfd < 0) {
3307 /* Oh cXap. This isn't going to go well. Not sure if we can
3308 recover from here, or if closing this particular FILE *
3309 is a good idea now. */
3310 }
3311#endif
3312 }
3313 } else {
3314 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3315 }
3316 result = PerlSIO_fclose(stdio);
3317 /* We treat error from stdio as success if we invalidated
3318 errno may NOT be expected EBADF
3319 */
3320 if (invalidate && result != 0) {
3321 RESTORE_ERRNO;
3322 result = 0;
3323 }
3324#ifdef SOCKS5_VERSION_NAME
3325 /* in SOCKS' case, let close() determine return value */
3326 result = close(fd);
3327#endif
3328 if (dupfd >= 0) {
3329 PerlLIO_dup2_cloexec(dupfd, fd);
3330 setfd_inhexec_for_sysfd(fd);
3331 PerlLIO_close(dupfd);
3332 }
3333 MUTEX_UNLOCK(&PL_perlio_mutex);
3334 return result;
3335 }
3336}
3337
3338SSize_t
3339PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3340{
3341 FILE * s;
3342 SSize_t got = 0;
3343 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3344 return -1;
3345 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3346 for (;;) {
3347 if (count == 1) {
3348 STDCHAR *buf = (STDCHAR *) vbuf;
3349 /*
3350 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3351 * stdio does not do that for fread()
3352 */
3353 const int ch = PerlSIO_fgetc(s);
3354 if (ch != EOF) {
3355 *buf = ch;
3356 got = 1;
3357 }
3358 }
3359 else
3360 got = PerlSIO_fread(vbuf, 1, count, s);
3361 if (got == 0 && PerlSIO_ferror(s))
3362 got = -1;
3363 if (got >= 0 || errno != EINTR)
3364 break;
3365 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3366 return -1;
3367 SETERRNO(0,0); /* just in case */
3368 }
3369#ifdef __sgi
3370 /* Under some circumstances IRIX stdio fgetc() and fread()
3371 * set the errno to ENOENT, which makes no sense according
3372 * to either IRIX or POSIX. [rt.perl.org #123977] */
3373 if (errno == ENOENT) SETERRNO(0,0);
3374#endif
3375 return got;
3376}
3377
3378SSize_t
3379PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3380{
3381 SSize_t unread = 0;
3382 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3383
3384#ifdef STDIO_BUFFER_WRITABLE
3385 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3386 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3387 STDCHAR *base = PerlIO_get_base(f);
3388 SSize_t cnt = PerlIO_get_cnt(f);
3389 STDCHAR *ptr = PerlIO_get_ptr(f);
3390 SSize_t avail = ptr - base;
3391 if (avail > 0) {
3392 if (avail > count) {
3393 avail = count;
3394 }
3395 ptr -= avail;
3396 Move(buf-avail,ptr,avail,STDCHAR);
3397 count -= avail;
3398 unread += avail;
3399 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3400 if (PerlSIO_feof(s) && unread >= 0)
3401 PerlSIO_clearerr(s);
3402 }
3403 }
3404 else
3405#endif
3406 if (PerlIO_has_cntptr(f)) {
3407 /* We can get pointer to buffer but not its base
3408 Do ungetc() but check chars are ending up in the
3409 buffer
3410 */
3411 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3412 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3413 while (count > 0) {
3414 const int ch = *--buf & 0xFF;
3415 if (ungetc(ch,s) != ch) {
3416 /* ungetc did not work */
3417 break;
3418 }
3419 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3420 /* Did not change pointer as expected */
3421 if (fgetc(s) != EOF) /* get char back again */
3422 break;
3423 }
3424 /* It worked ! */
3425 count--;
3426 unread++;
3427 }
3428 }
3429
3430 if (count > 0) {
3431 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3432 }
3433 return unread;
3434}
3435
3436SSize_t
3437PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3438{
3439 SSize_t got;
3440 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3441 return -1;
3442 for (;;) {
3443 got = PerlSIO_fwrite(vbuf, 1, count,
3444 PerlIOSelf(f, PerlIOStdio)->stdio);
3445 if (got >= 0 || errno != EINTR)
3446 break;
3447 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3448 return -1;
3449 SETERRNO(0,0); /* just in case */
3450 }
3451 return got;
3452}
3453
3454IV
3455PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3456{
3457 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3458 PERL_UNUSED_CONTEXT;
3459
3460 return PerlSIO_fseek(stdio, offset, whence);
3461}
3462
3463Off_t
3464PerlIOStdio_tell(pTHX_ PerlIO *f)
3465{
3466 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3467 PERL_UNUSED_CONTEXT;
3468
3469 return PerlSIO_ftell(stdio);
3470}
3471
3472IV
3473PerlIOStdio_flush(pTHX_ PerlIO *f)
3474{
3475 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3476 PERL_UNUSED_CONTEXT;
3477
3478 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3479 return PerlSIO_fflush(stdio);
3480 }
3481 else {
3482 NOOP;
3483#if 0
3484 /*
3485 * FIXME: This discards ungetc() and pre-read stuff which is not
3486 * right if this is just a "sync" from a layer above Suspect right
3487 * design is to do _this_ but not have layer above flush this
3488 * layer read-to-read
3489 */
3490 /*
3491 * Not writeable - sync by attempting a seek
3492 */
3493 dSAVE_ERRNO;
3494 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3495 RESTORE_ERRNO;
3496#endif
3497 }
3498 return 0;
3499}
3500
3501IV
3502PerlIOStdio_eof(pTHX_ PerlIO *f)
3503{
3504 PERL_UNUSED_CONTEXT;
3505
3506 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3507}
3508
3509IV
3510PerlIOStdio_error(pTHX_ PerlIO *f)
3511{
3512 PERL_UNUSED_CONTEXT;
3513
3514 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3515}
3516
3517void
3518PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3519{
3520 PERL_UNUSED_CONTEXT;
3521
3522 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3523}
3524
3525void
3526PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3527{
3528 PERL_UNUSED_CONTEXT;
3529
3530#ifdef HAS_SETLINEBUF
3531 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3532#else
3533 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3534#endif
3535}
3536
3537#ifdef FILE_base
3538STDCHAR *
3539PerlIOStdio_get_base(pTHX_ PerlIO *f)
3540{
3541 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3542 PERL_UNUSED_CONTEXT;
3543 return (STDCHAR*)PerlSIO_get_base(stdio);
3544}
3545
3546Size_t
3547PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3548{
3549 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3550 PERL_UNUSED_CONTEXT;
3551 return PerlSIO_get_bufsiz(stdio);
3552}
3553#endif
3554
3555#ifdef USE_STDIO_PTR
3556STDCHAR *
3557PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3558{
3559 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3560 PERL_UNUSED_CONTEXT;
3561 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3562}
3563
3564SSize_t
3565PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3566{
3567 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3568 PERL_UNUSED_CONTEXT;
3569 return PerlSIO_get_cnt(stdio);
3570}
3571
3572void
3573PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3574{
3575 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3576 PERL_UNUSED_CONTEXT;
3577 if (ptr != NULL) {
3578# ifdef STDIO_PTR_LVALUE
3579 /* This is a long-standing infamous mess. The root of the
3580 * problem is that one cannot know the signedness of char, and
3581 * more precisely the signedness of FILE._ptr. The following
3582 * things have been tried, and they have all failed (across
3583 * different compilers (remember that core needs to to build
3584 * also with c++) and compiler options:
3585 *
3586 * - casting the RHS to (void*) -- works in *some* places
3587 * - casting the LHS to (void*) -- totally unportable
3588 *
3589 * So let's try silencing the warning at least for gcc. */
3590 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
3591 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3592 GCC_DIAG_RESTORE_STMT;
3593# ifdef STDIO_PTR_LVAL_SETS_CNT
3594 assert(PerlSIO_get_cnt(stdio) == (cnt));
3595# endif
3596# if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3597 /*
3598 * Setting ptr _does_ change cnt - we are done
3599 */
3600 return;
3601# endif
3602# else /* STDIO_PTR_LVALUE */
3603 PerlProc_abort();
3604# endif /* STDIO_PTR_LVALUE */
3605 }
3606 /*
3607 * Now (or only) set cnt
3608 */
3609# ifdef STDIO_CNT_LVALUE
3610 PerlSIO_set_cnt(stdio, cnt);
3611# elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3612 PerlSIO_set_ptr(stdio,
3613 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3614 cnt));
3615# else /* STDIO_PTR_LVAL_SETS_CNT */
3616 PerlProc_abort();
3617# endif /* STDIO_CNT_LVALUE */
3618}
3619
3620
3621#endif
3622
3623IV
3624PerlIOStdio_fill(pTHX_ PerlIO *f)
3625{
3626 FILE * stdio;
3627 int c;
3628 PERL_UNUSED_CONTEXT;
3629 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3630 return -1;
3631 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3632
3633 /*
3634 * fflush()ing read-only streams can cause trouble on some stdio-s
3635 */
3636 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3637 if (PerlSIO_fflush(stdio) != 0)
3638 return EOF;
3639 }
3640 for (;;) {
3641 c = PerlSIO_fgetc(stdio);
3642 if (c != EOF)
3643 break;
3644 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3645 return EOF;
3646 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3647 return -1;
3648 SETERRNO(0,0);
3649 }
3650
3651#if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3652
3653# ifdef STDIO_BUFFER_WRITABLE
3654 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3655 /* Fake ungetc() to the real buffer in case system's ungetc
3656 goes elsewhere
3657 */
3658 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3659 SSize_t cnt = PerlSIO_get_cnt(stdio);
3660 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3661 if (ptr == base+1) {
3662 *--ptr = (STDCHAR) c;
3663 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3664 if (PerlSIO_feof(stdio))
3665 PerlSIO_clearerr(stdio);
3666 return 0;
3667 }
3668 }
3669 else
3670# endif
3671 if (PerlIO_has_cntptr(f)) {
3672 STDCHAR ch = c;
3673 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3674 return 0;
3675 }
3676 }
3677#endif
3678
3679 /* If buffer snoop scheme above fails fall back to
3680 using ungetc().
3681 */
3682 if (PerlSIO_ungetc(c, stdio) != c)
3683 return EOF;
3684
3685 return 0;
3686}
3687
3688
3689
3690PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3691 sizeof(PerlIO_funcs),
3692 "stdio",
3693 sizeof(PerlIOStdio),
3694 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3695 PerlIOStdio_pushed,
3696 PerlIOBase_popped,
3697 PerlIOStdio_open,
3698 PerlIOBase_binmode, /* binmode */
3699 NULL,
3700 PerlIOStdio_fileno,
3701 PerlIOStdio_dup,
3702 PerlIOStdio_read,
3703 PerlIOStdio_unread,
3704 PerlIOStdio_write,
3705 PerlIOStdio_seek,
3706 PerlIOStdio_tell,
3707 PerlIOStdio_close,
3708 PerlIOStdio_flush,
3709 PerlIOStdio_fill,
3710 PerlIOStdio_eof,
3711 PerlIOStdio_error,
3712 PerlIOStdio_clearerr,
3713 PerlIOStdio_setlinebuf,
3714#ifdef FILE_base
3715 PerlIOStdio_get_base,
3716 PerlIOStdio_get_bufsiz,
3717#else
3718 NULL,
3719 NULL,
3720#endif
3721#ifdef USE_STDIO_PTR
3722 PerlIOStdio_get_ptr,
3723 PerlIOStdio_get_cnt,
3724# if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3725 PerlIOStdio_set_ptrcnt,
3726# else
3727 NULL,
3728# endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3729#else
3730 NULL,
3731 NULL,
3732 NULL,
3733#endif /* USE_STDIO_PTR */
3734};
3735
3736/* Note that calls to PerlIO_exportFILE() are reversed using
3737 * PerlIO_releaseFILE(), not importFILE. */
3738FILE *
3739PerlIO_exportFILE(PerlIO * f, const char *mode)
3740{
3741 dTHX;
3742 FILE *stdio = NULL;
3743 if (PerlIOValid(f)) {
3744 char buf[8];
3745 int fd = PerlIO_fileno(f);
3746 if (fd < 0) {
3747 return NULL;
3748 }
3749 PerlIO_flush(f);
3750 if (!mode || !*mode) {
3751 mode = PerlIO_modestr(f, buf);
3752 }
3753 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3754 if (stdio) {
3755 PerlIOl *l = *f;
3756 PerlIO *f2;
3757 /* De-link any lower layers so new :stdio sticks */
3758 *f = NULL;
3759 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3760 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3761 s->stdio = stdio;
3762 PerlIOUnix_refcnt_inc(fileno(stdio));
3763 /* Link previous lower layers under new one */
3764 *PerlIONext(f) = l;
3765 }
3766 else {
3767 /* restore layers list */
3768 *f = l;
3769 }
3770 }
3771 }
3772 return stdio;
3773}
3774
3775
3776FILE *
3777PerlIO_findFILE(PerlIO *f)
3778{
3779 PerlIOl *l = *f;
3780 FILE *stdio;
3781 while (l) {
3782 if (l->tab == &PerlIO_stdio) {
3783 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3784 return s->stdio;
3785 }
3786 l = *PerlIONext(&l);
3787 }
3788 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3789 /* However, we're not really exporting a FILE * to someone else (who
3790 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3791 So we need to undo its reference count increase on the underlying file
3792 descriptor. We have to do this, because if the loop above returns you
3793 the FILE *, then *it* didn't increase any reference count. So there's
3794 only one way to be consistent. */
3795 stdio = PerlIO_exportFILE(f, NULL);
3796 if (stdio) {
3797 const int fd = fileno(stdio);
3798 if (fd >= 0)
3799 PerlIOUnix_refcnt_dec(fd);
3800 }
3801 return stdio;
3802}
3803
3804/* Use this to reverse PerlIO_exportFILE calls. */
3805void
3806PerlIO_releaseFILE(PerlIO *p, FILE *f)
3807{
3808 PerlIOl *l;
3809 while ((l = *p)) {
3810 if (l->tab == &PerlIO_stdio) {
3811 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3812 if (s->stdio == f) { /* not in a loop */
3813 const int fd = fileno(f);
3814 if (fd >= 0)
3815 PerlIOUnix_refcnt_dec(fd);
3816 {
3817 dTHX;
3818 PerlIO_pop(aTHX_ p);
3819 }
3820 return;
3821 }
3822 }
3823 p = PerlIONext(p);
3824 }
3825 return;
3826}
3827
3828/*--------------------------------------------------------------------------------------*/
3829/*
3830 * perlio buffer layer
3831 */
3832
3833IV
3834PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3835{
3836 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3837 const int fd = PerlIO_fileno(f);
3838 if (fd >= 0 && PerlLIO_isatty(fd)) {
3839 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3840 }
3841 if (*PerlIONext(f)) {
3842 const Off_t posn = PerlIO_tell(PerlIONext(f));
3843 if (posn != (Off_t) - 1) {
3844 b->posn = posn;
3845 }
3846 }
3847 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3848}
3849
3850PerlIO *
3851PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3852 IV n, const char *mode, int fd, int imode, int perm,
3853 PerlIO *f, int narg, SV **args)
3854{
3855 if (PerlIOValid(f)) {
3856 PerlIO *next = PerlIONext(f);
3857 PerlIO_funcs *tab =
3858 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3859 if (tab && tab->Open)
3860 next =
3861 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3862 next, narg, args);
3863 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3864 return NULL;
3865 }
3866 }
3867 else {
3868 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3869 int init = 0;
3870 if (*mode == IoTYPE_IMPLICIT) {
3871 init = 1;
3872 /*
3873 * mode++;
3874 */
3875 }
3876 if (tab && tab->Open)
3877 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3878 f, narg, args);
3879 else
3880 SETERRNO(EINVAL, LIB_INVARG);
3881 if (f) {
3882 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3883 /*
3884 * if push fails during open, open fails. close will pop us.
3885 */
3886 PerlIO_close (f);
3887 return NULL;
3888 } else {
3889 fd = PerlIO_fileno(f);
3890 if (init && fd == 2) {
3891 /*
3892 * Initial stderr is unbuffered
3893 */
3894 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3895 }
3896#ifdef PERLIO_USING_CRLF
3897# ifdef PERLIO_IS_BINMODE_FD
3898 if (PERLIO_IS_BINMODE_FD(fd))
3899 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3900 else
3901# endif
3902 /*
3903 * do something about failing setmode()? --jhi
3904 */
3905 PerlLIO_setmode(fd, O_BINARY);
3906#endif
3907#ifdef VMS
3908 /* Enable line buffering with record-oriented regular files
3909 * so we don't introduce an extraneous record boundary when
3910 * the buffer fills up.
3911 */
3912 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3913 Stat_t st;
3914 if (PerlLIO_fstat(fd, &st) == 0
3915 && S_ISREG(st.st_mode)
3916 && (st.st_fab_rfm == FAB$C_VAR
3917 || st.st_fab_rfm == FAB$C_VFC)) {
3918 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3919 }
3920 }
3921#endif
3922 }
3923 }
3924 }
3925 return f;
3926}
3927
3928/*
3929 * This "flush" is akin to sfio's sync in that it handles files in either
3930 * read or write state. For write state, we put the postponed data through
3931 * the next layers. For read state, we seek() the next layers to the
3932 * offset given by current position in the buffer, and discard the buffer
3933 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3934 * in any case?). Then the pass the stick further in chain.
3935 */
3936IV
3937PerlIOBuf_flush(pTHX_ PerlIO *f)
3938{
3939 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3940 int code = 0;
3941 PerlIO *n = PerlIONext(f);
3942 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3943 /*
3944 * write() the buffer
3945 */
3946 const STDCHAR *buf = b->buf;
3947 const STDCHAR *p = buf;
3948 while (p < b->ptr) {
3949 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3950 if (count > 0) {
3951 p += count;
3952 }
3953 else if (count < 0 || PerlIO_error(n)) {
3954 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3955 PerlIO_save_errno(f);
3956 code = -1;
3957 break;
3958 }
3959 }
3960 b->posn += (p - buf);
3961 }
3962 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3963 STDCHAR *buf = PerlIO_get_base(f);
3964 /*
3965 * Note position change
3966 */
3967 b->posn += (b->ptr - buf);
3968 if (b->ptr < b->end) {
3969 /* We did not consume all of it - try and seek downstream to
3970 our logical position
3971 */
3972 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3973 /* Reload n as some layers may pop themselves on seek */
3974 b->posn = PerlIO_tell(n = PerlIONext(f));
3975 }
3976 else {
3977 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3978 data is lost for good - so return saying "ok" having undone
3979 the position adjust
3980 */
3981 b->posn -= (b->ptr - buf);
3982 return code;
3983 }
3984 }
3985 }
3986 b->ptr = b->end = b->buf;
3987 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
3988 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
3989 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
3990 code = -1;
3991 return code;
3992}
3993
3994/* This discards the content of the buffer after b->ptr, and rereads
3995 * the buffer from the position off in the layer downstream; here off
3996 * is at offset corresponding to b->ptr - b->buf.
3997 */
3998IV
3999PerlIOBuf_fill(pTHX_ PerlIO *f)
4000{
4001 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4002 PerlIO *n = PerlIONext(f);
4003 SSize_t avail;
4004 /*
4005 * Down-stream flush is defined not to loose read data so is harmless.
4006 * we would not normally be fill'ing if there was data left in anycase.
4007 */
4008 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4009 return -1;
4010 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4011 PerlIOBase_flush_linebuf(aTHX);
4012
4013 if (!b->buf)
4014 PerlIO_get_base(f); /* allocate via vtable */
4015
4016 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4017
4018 b->ptr = b->end = b->buf;
4019
4020 if (!PerlIOValid(n)) {
4021 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4022 return -1;
4023 }
4024
4025 if (PerlIO_fast_gets(n)) {
4026 /*
4027 * Layer below is also buffered. We do _NOT_ want to call its
4028 * ->Read() because that will loop till it gets what we asked for
4029 * which may hang on a pipe etc. Instead take anything it has to
4030 * hand, or ask it to fill _once_.
4031 */
4032 avail = PerlIO_get_cnt(n);
4033 if (avail <= 0) {
4034 avail = PerlIO_fill(n);
4035 if (avail == 0)
4036 avail = PerlIO_get_cnt(n);
4037 else {
4038 if (!PerlIO_error(n) && PerlIO_eof(n))
4039 avail = 0;
4040 }
4041 }
4042 if (avail > 0) {
4043 STDCHAR *ptr = PerlIO_get_ptr(n);
4044 const SSize_t cnt = avail;
4045 if (avail > (SSize_t)b->bufsiz)
4046 avail = b->bufsiz;
4047 Copy(ptr, b->buf, avail, STDCHAR);
4048 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4049 }
4050 }
4051 else {
4052 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4053 }
4054 if (avail <= 0) {
4055 if (avail == 0)
4056 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4057 else
4058 {
4059 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4060 PerlIO_save_errno(f);
4061 }
4062 return -1;
4063 }
4064 b->end = b->buf + avail;
4065 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4066 return 0;
4067}
4068
4069SSize_t
4070PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4071{
4072 if (PerlIOValid(f)) {
4073 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4074 if (!b->ptr)
4075 PerlIO_get_base(f);
4076 return PerlIOBase_read(aTHX_ f, vbuf, count);
4077 }
4078 return 0;
4079}
4080
4081SSize_t
4082PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4083{
4084 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4085 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4086 SSize_t unread = 0;
4087 SSize_t avail;
4088 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4089 PerlIO_flush(f);
4090 if (!b->buf)
4091 PerlIO_get_base(f);
4092 if (b->buf) {
4093 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4094 /*
4095 * Buffer is already a read buffer, we can overwrite any chars
4096 * which have been read back to buffer start
4097 */
4098 avail = (b->ptr - b->buf);
4099 }
4100 else {
4101 /*
4102 * Buffer is idle, set it up so whole buffer is available for
4103 * unread
4104 */
4105 avail = b->bufsiz;
4106 b->end = b->buf + avail;
4107 b->ptr = b->end;
4108 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4109 /*
4110 * Buffer extends _back_ from where we are now
4111 */
4112 b->posn -= b->bufsiz;
4113 }
4114 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4115 /*
4116 * If we have space for more than count, just move count
4117 */
4118 avail = count;
4119 }
4120 if (avail > 0) {
4121 b->ptr -= avail;
4122 buf -= avail;
4123 /*
4124 * In simple stdio-like ungetc() case chars will be already
4125 * there
4126 */
4127 if (buf != b->ptr) {
4128 Copy(buf, b->ptr, avail, STDCHAR);
4129 }
4130 count -= avail;
4131 unread += avail;
4132 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4133 }
4134 }
4135 if (count > 0) {
4136 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4137 }
4138 return unread;
4139}
4140
4141SSize_t
4142PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4143{
4144 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4145 const STDCHAR *buf = (const STDCHAR *) vbuf;
4146 const STDCHAR *flushptr = buf;
4147 Size_t written = 0;
4148 if (!b->buf)
4149 PerlIO_get_base(f);
4150 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4151 return 0;
4152 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4153 if (PerlIO_flush(f) != 0) {
4154 return 0;
4155 }
4156 }
4157 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4158 flushptr = buf + count;
4159 while (flushptr > buf && *(flushptr - 1) != '\n')
4160 --flushptr;
4161 }
4162 while (count > 0) {
4163 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4164 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4165 avail = count;
4166 if (flushptr > buf && flushptr <= buf + avail)
4167 avail = flushptr - buf;
4168 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4169 if (avail) {
4170 Copy(buf, b->ptr, avail, STDCHAR);
4171 count -= avail;
4172 buf += avail;
4173 written += avail;
4174 b->ptr += avail;
4175 if (buf == flushptr)
4176 PerlIO_flush(f);
4177 }
4178 if (b->ptr >= (b->buf + b->bufsiz))
4179 if (PerlIO_flush(f) == -1)
4180 return -1;
4181 }
4182 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4183 PerlIO_flush(f);
4184 return written;
4185}
4186
4187IV
4188PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4189{
4190 IV code;
4191 if ((code = PerlIO_flush(f)) == 0) {
4192 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4193 code = PerlIO_seek(PerlIONext(f), offset, whence);
4194 if (code == 0) {
4195 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4196 b->posn = PerlIO_tell(PerlIONext(f));
4197 }
4198 }
4199 return code;
4200}
4201
4202Off_t
4203PerlIOBuf_tell(pTHX_ PerlIO *f)
4204{
4205 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4206 /*
4207 * b->posn is file position where b->buf was read, or will be written
4208 */
4209 Off_t posn = b->posn;
4210 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4211 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4212#if 1
4213 /* As O_APPEND files are normally shared in some sense it is better
4214 to flush :
4215 */
4216 PerlIO_flush(f);
4217#else
4218 /* when file is NOT shared then this is sufficient */
4219 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4220#endif
4221 posn = b->posn = PerlIO_tell(PerlIONext(f));
4222 }
4223 if (b->buf) {
4224 /*
4225 * If buffer is valid adjust position by amount in buffer
4226 */
4227 posn += (b->ptr - b->buf);
4228 }
4229 return posn;
4230}
4231
4232IV
4233PerlIOBuf_popped(pTHX_ PerlIO *f)
4234{
4235 const IV code = PerlIOBase_popped(aTHX_ f);
4236 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4237 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4238 Safefree(b->buf);
4239 }
4240 b->ptr = b->end = b->buf = NULL;
4241 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4242 return code;
4243}
4244
4245IV
4246PerlIOBuf_close(pTHX_ PerlIO *f)
4247{
4248 const IV code = PerlIOBase_close(aTHX_ f);
4249 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4250 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4251 Safefree(b->buf);
4252 }
4253 b->ptr = b->end = b->buf = NULL;
4254 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4255 return code;
4256}
4257
4258STDCHAR *
4259PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4260{
4261 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4262 if (!b->buf)
4263 PerlIO_get_base(f);
4264 return b->ptr;
4265}
4266
4267SSize_t
4268PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4269{
4270 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4271 if (!b->buf)
4272 PerlIO_get_base(f);
4273 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4274 return (b->end - b->ptr);
4275 return 0;
4276}
4277
4278STDCHAR *
4279PerlIOBuf_get_base(pTHX_ PerlIO *f)
4280{
4281 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4282 PERL_UNUSED_CONTEXT;
4283
4284 if (!b->buf) {
4285 if (!b->bufsiz)
4286 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4287 Newx(b->buf,b->bufsiz, STDCHAR);
4288 if (!b->buf) {
4289 b->buf = (STDCHAR *) & b->oneword;
4290 b->bufsiz = sizeof(b->oneword);
4291 }
4292 b->end = b->ptr = b->buf;
4293 }
4294 return b->buf;
4295}
4296
4297Size_t
4298PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4299{
4300 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4301 if (!b->buf)
4302 PerlIO_get_base(f);
4303 return (b->end - b->buf);
4304}
4305
4306void
4307PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4308{
4309 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4310#ifndef DEBUGGING
4311 PERL_UNUSED_ARG(cnt);
4312#endif
4313 if (!b->buf)
4314 PerlIO_get_base(f);
4315 b->ptr = ptr;
4316 assert(PerlIO_get_cnt(f) == cnt);
4317 assert(b->ptr >= b->buf);
4318 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4319}
4320
4321PerlIO *
4322PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4323{
4324 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4325}
4326
4327
4328
4329PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4330 sizeof(PerlIO_funcs),
4331 "perlio",
4332 sizeof(PerlIOBuf),
4333 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4334 PerlIOBuf_pushed,
4335 PerlIOBuf_popped,
4336 PerlIOBuf_open,
4337 PerlIOBase_binmode, /* binmode */
4338 NULL,
4339 PerlIOBase_fileno,
4340 PerlIOBuf_dup,
4341 PerlIOBuf_read,
4342 PerlIOBuf_unread,
4343 PerlIOBuf_write,
4344 PerlIOBuf_seek,
4345 PerlIOBuf_tell,
4346 PerlIOBuf_close,
4347 PerlIOBuf_flush,
4348 PerlIOBuf_fill,
4349 PerlIOBase_eof,
4350 PerlIOBase_error,
4351 PerlIOBase_clearerr,
4352 PerlIOBase_setlinebuf,
4353 PerlIOBuf_get_base,
4354 PerlIOBuf_bufsiz,
4355 PerlIOBuf_get_ptr,
4356 PerlIOBuf_get_cnt,
4357 PerlIOBuf_set_ptrcnt,
4358};
4359
4360/*--------------------------------------------------------------------------------------*/
4361/*
4362 * Temp layer to hold unread chars when cannot do it any other way
4363 */
4364
4365IV
4366PerlIOPending_fill(pTHX_ PerlIO *f)
4367{
4368 /*
4369 * Should never happen
4370 */
4371 PerlIO_flush(f);
4372 return 0;
4373}
4374
4375IV
4376PerlIOPending_close(pTHX_ PerlIO *f)
4377{
4378 /*
4379 * A tad tricky - flush pops us, then we close new top
4380 */
4381 PerlIO_flush(f);
4382 return PerlIO_close(f);
4383}
4384
4385IV
4386PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4387{
4388 /*
4389 * A tad tricky - flush pops us, then we seek new top
4390 */
4391 PerlIO_flush(f);
4392 return PerlIO_seek(f, offset, whence);
4393}
4394
4395
4396IV
4397PerlIOPending_flush(pTHX_ PerlIO *f)
4398{
4399 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4400 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4401 Safefree(b->buf);
4402 b->buf = NULL;
4403 }
4404 PerlIO_pop(aTHX_ f);
4405 return 0;
4406}
4407
4408void
4409PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4410{
4411 if (cnt <= 0) {
4412 PerlIO_flush(f);
4413 }
4414 else {
4415 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4416 }
4417}
4418
4419IV
4420PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4421{
4422 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4423 PerlIOl * const l = PerlIOBase(f);
4424 /*
4425 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4426 * etc. get muddled when it changes mid-string when we auto-pop.
4427 */
4428 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4429 (PerlIOBase(PerlIONext(f))->
4430 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4431 return code;
4432}
4433
4434SSize_t
4435PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4436{
4437 SSize_t avail = PerlIO_get_cnt(f);
4438 SSize_t got = 0;
4439 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4440 avail = count;
4441 if (avail > 0)
4442 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4443 if (got >= 0 && got < (SSize_t)count) {
4444 const SSize_t more =
4445 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4446 if (more >= 0 || got == 0)
4447 got += more;
4448 }
4449 return got;
4450}
4451
4452PERLIO_FUNCS_DECL(PerlIO_pending) = {
4453 sizeof(PerlIO_funcs),
4454 "pending",
4455 sizeof(PerlIOBuf),
4456 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4457 PerlIOPending_pushed,
4458 PerlIOBuf_popped,
4459 NULL,
4460 PerlIOBase_binmode, /* binmode */
4461 NULL,
4462 PerlIOBase_fileno,
4463 PerlIOBuf_dup,
4464 PerlIOPending_read,
4465 PerlIOBuf_unread,
4466 PerlIOBuf_write,
4467 PerlIOPending_seek,
4468 PerlIOBuf_tell,
4469 PerlIOPending_close,
4470 PerlIOPending_flush,
4471 PerlIOPending_fill,
4472 PerlIOBase_eof,
4473 PerlIOBase_error,
4474 PerlIOBase_clearerr,
4475 PerlIOBase_setlinebuf,
4476 PerlIOBuf_get_base,
4477 PerlIOBuf_bufsiz,
4478 PerlIOBuf_get_ptr,
4479 PerlIOBuf_get_cnt,
4480 PerlIOPending_set_ptrcnt,
4481};
4482
4483
4484
4485/*--------------------------------------------------------------------------------------*/
4486/*
4487 * crlf - translation On read translate CR,LF to "\n" we do this by
4488 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4489 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4490 *
4491 * c->nl points on the first byte of CR LF pair when it is temporarily
4492 * replaced by LF, or to the last CR of the buffer. In the former case
4493 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4494 * that it ends at c->nl; these two cases can be distinguished by
4495 * *c->nl. c->nl is set during _getcnt() call, and unset during
4496 * _unread() and _flush() calls.
4497 * It only matters for read operations.
4498 */
4499
4500typedef struct {
4501 PerlIOBuf base; /* PerlIOBuf stuff */
4502 STDCHAR *nl; /* Position of crlf we "lied" about in the
4503 * buffer */
4504} PerlIOCrlf;
4505
4506/* Inherit the PERLIO_F_UTF8 flag from previous layer.
4507 * Otherwise the :crlf layer would always revert back to
4508 * raw mode.
4509 */
4510static void
4511S_inherit_utf8_flag(PerlIO *f)
4512{
4513 PerlIO *g = PerlIONext(f);
4514 if (PerlIOValid(g)) {
4515 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4516 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4517 }
4518 }
4519}
4520
4521IV
4522PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4523{
4524 IV code;
4525 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4526 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4527#if 0
4528 DEBUG_i(
4529 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4530 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4531 PerlIOBase(f)->flags);
4532 );
4533#endif
4534 {
4535 /* If the old top layer is a CRLF layer, reactivate it (if
4536 * necessary) and remove this new layer from the stack */
4537 PerlIO *g = PerlIONext(f);
4538 if (PerlIOValid(g)) {
4539 PerlIOl *b = PerlIOBase(g);
4540 if (b && b->tab == &PerlIO_crlf) {
4541 if (!(b->flags & PERLIO_F_CRLF))
4542 b->flags |= PERLIO_F_CRLF;
4543 S_inherit_utf8_flag(g);
4544 PerlIO_pop(aTHX_ f);
4545 return code;
4546 }
4547 }
4548 }
4549 S_inherit_utf8_flag(f);
4550 return code;
4551}
4552
4553
4554SSize_t
4555PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4556{
4557 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4558 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4559 *(c->nl) = NATIVE_0xd;
4560 c->nl = NULL;
4561 }
4562 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4563 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4564 else {
4565 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4566 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4567 SSize_t unread = 0;
4568 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4569 PerlIO_flush(f);
4570 if (!b->buf)
4571 PerlIO_get_base(f);
4572 if (b->buf) {
4573 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4574 b->end = b->ptr = b->buf + b->bufsiz;
4575 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4576 b->posn -= b->bufsiz;
4577 }
4578 while (count > 0 && b->ptr > b->buf) {
4579 const int ch = *--buf;
4580 if (ch == '\n') {
4581 if (b->ptr - 2 >= b->buf) {
4582 *--(b->ptr) = NATIVE_0xa;
4583 *--(b->ptr) = NATIVE_0xd;
4584 unread++;
4585 count--;
4586 }
4587 else {
4588 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4589 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4590 '\r' */
4591 unread++;
4592 count--;
4593 }
4594 }
4595 else {
4596 *--(b->ptr) = ch;
4597 unread++;
4598 count--;
4599 }
4600 }
4601 }
4602 if (count > 0)
4603 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4604 return unread;
4605 }
4606}
4607
4608/* XXXX This code assumes that buffer size >=2, but does not check it... */
4609SSize_t
4610PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4611{
4612 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4613 if (!b->buf)
4614 PerlIO_get_base(f);
4615 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4616 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4617 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4618 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4619 scan:
4620 while (nl < b->end && *nl != NATIVE_0xd)
4621 nl++;
4622 if (nl < b->end && *nl == NATIVE_0xd) {
4623 test:
4624 if (nl + 1 < b->end) {
4625 if (nl[1] == NATIVE_0xa) {
4626 *nl = '\n';
4627 c->nl = nl;
4628 }
4629 else {
4630 /*
4631 * Not CR,LF but just CR
4632 */
4633 nl++;
4634 goto scan;
4635 }
4636 }
4637 else {
4638 /*
4639 * Blast - found CR as last char in buffer
4640 */
4641
4642 if (b->ptr < nl) {
4643 /*
4644 * They may not care, defer work as long as
4645 * possible
4646 */
4647 c->nl = nl;
4648 return (nl - b->ptr);
4649 }
4650 else {
4651 int code;
4652 b->ptr++; /* say we have read it as far as
4653 * flush() is concerned */
4654 b->buf++; /* Leave space in front of buffer */
4655 /* Note as we have moved buf up flush's
4656 posn += ptr-buf
4657 will naturally make posn point at CR
4658 */
4659 b->bufsiz--; /* Buffer is thus smaller */
4660 code = PerlIO_fill(f); /* Fetch some more */
4661 b->bufsiz++; /* Restore size for next time */
4662 b->buf--; /* Point at space */
4663 b->ptr = nl = b->buf; /* Which is what we hand
4664 * off */
4665 *nl = NATIVE_0xd; /* Fill in the CR */
4666 if (code == 0)
4667 goto test; /* fill() call worked */
4668 /*
4669 * CR at EOF - just fall through
4670 */
4671 /* Should we clear EOF though ??? */
4672 }
4673 }
4674 }
4675 }
4676 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4677 }
4678 return 0;
4679}
4680
4681void
4682PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4683{
4684 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4685 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4686 if (!b->buf)
4687 PerlIO_get_base(f);
4688 if (!ptr) {
4689 if (c->nl) {
4690 ptr = c->nl + 1;
4691 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4692 /* Deferred CR at end of buffer case - we lied about count */
4693 ptr--;
4694 }
4695 }
4696 else {
4697 ptr = b->end;
4698 }
4699 ptr -= cnt;
4700 }
4701 else {
4702 NOOP;
4703#if 0
4704 /*
4705 * Test code - delete when it works ...
4706 */
4707 IV flags = PerlIOBase(f)->flags;
4708 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4709 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4710 /* Deferred CR at end of buffer case - we lied about count */
4711 chk--;
4712 }
4713 chk -= cnt;
4714
4715 if (ptr != chk ) {
4716 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4717 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4718 flags, c->nl, b->end, cnt);
4719 }
4720#endif
4721 }
4722 if (c->nl) {
4723 if (ptr > c->nl) {
4724 /*
4725 * They have taken what we lied about
4726 */
4727 *(c->nl) = NATIVE_0xd;
4728 c->nl = NULL;
4729 ptr++;
4730 }
4731 }
4732 b->ptr = ptr;
4733 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4734}
4735
4736SSize_t
4737PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4738{
4739 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4740 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4741 else {
4742 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4743 const STDCHAR *buf = (const STDCHAR *) vbuf;
4744 const STDCHAR * const ebuf = buf + count;
4745 if (!b->buf)
4746 PerlIO_get_base(f);
4747 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4748 return 0;
4749 while (buf < ebuf) {
4750 const STDCHAR * const eptr = b->buf + b->bufsiz;
4751 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4752 while (buf < ebuf && b->ptr < eptr) {
4753 if (*buf == '\n') {
4754 if ((b->ptr + 2) > eptr) {
4755 /*
4756 * Not room for both
4757 */
4758 PerlIO_flush(f);
4759 break;
4760 }
4761 else {
4762 *(b->ptr)++ = NATIVE_0xd; /* CR */
4763 *(b->ptr)++ = NATIVE_0xa; /* LF */
4764 buf++;
4765 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4766 PerlIO_flush(f);
4767 break;
4768 }
4769 }
4770 }
4771 else {
4772 *(b->ptr)++ = *buf++;
4773 }
4774 if (b->ptr >= eptr) {
4775 PerlIO_flush(f);
4776 break;
4777 }
4778 }
4779 }
4780 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4781 PerlIO_flush(f);
4782 return (buf - (STDCHAR *) vbuf);
4783 }
4784}
4785
4786IV
4787PerlIOCrlf_flush(pTHX_ PerlIO *f)
4788{
4789 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4790 if (c->nl) {
4791 *(c->nl) = NATIVE_0xd;
4792 c->nl = NULL;
4793 }
4794 return PerlIOBuf_flush(aTHX_ f);
4795}
4796
4797IV
4798PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4799{
4800 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4801 /* In text mode - flush any pending stuff and flip it */
4802 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4803#ifndef PERLIO_USING_CRLF
4804 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4805 PerlIO_pop(aTHX_ f);
4806#endif
4807 }
4808 return PerlIOBase_binmode(aTHX_ f);
4809}
4810
4811PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4812 sizeof(PerlIO_funcs),
4813 "crlf",
4814 sizeof(PerlIOCrlf),
4815 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4816 PerlIOCrlf_pushed,
4817 PerlIOBuf_popped, /* popped */
4818 PerlIOBuf_open,
4819 PerlIOCrlf_binmode, /* binmode */
4820 NULL,
4821 PerlIOBase_fileno,
4822 PerlIOBuf_dup,
4823 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4824 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4825 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4826 PerlIOBuf_seek,
4827 PerlIOBuf_tell,
4828 PerlIOBuf_close,
4829 PerlIOCrlf_flush,
4830 PerlIOBuf_fill,
4831 PerlIOBase_eof,
4832 PerlIOBase_error,
4833 PerlIOBase_clearerr,
4834 PerlIOBase_setlinebuf,
4835 PerlIOBuf_get_base,
4836 PerlIOBuf_bufsiz,
4837 PerlIOBuf_get_ptr,
4838 PerlIOCrlf_get_cnt,
4839 PerlIOCrlf_set_ptrcnt,
4840};
4841
4842PerlIO *
4843Perl_PerlIO_stdin(pTHX)
4844{
4845 if (!PL_perlio) {
4846 PerlIO_stdstreams(aTHX);
4847 }
4848 return (PerlIO*)&PL_perlio[1];
4849}
4850
4851PerlIO *
4852Perl_PerlIO_stdout(pTHX)
4853{
4854 if (!PL_perlio) {
4855 PerlIO_stdstreams(aTHX);
4856 }
4857 return (PerlIO*)&PL_perlio[2];
4858}
4859
4860PerlIO *
4861Perl_PerlIO_stderr(pTHX)
4862{
4863 if (!PL_perlio) {
4864 PerlIO_stdstreams(aTHX);
4865 }
4866 return (PerlIO*)&PL_perlio[3];
4867}
4868
4869/*--------------------------------------------------------------------------------------*/
4870
4871char *
4872PerlIO_getname(PerlIO *f, char *buf)
4873{
4874#ifdef VMS
4875 dTHX;
4876 char *name = NULL;
4877 bool exported = FALSE;
4878 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4879 if (!stdio) {
4880 stdio = PerlIO_exportFILE(f,0);
4881 exported = TRUE;
4882 }
4883 if (stdio) {
4884 name = fgetname(stdio, buf);
4885 if (exported) PerlIO_releaseFILE(f,stdio);
4886 }
4887 return name;
4888#else
4889 PERL_UNUSED_ARG(f);
4890 PERL_UNUSED_ARG(buf);
4891 Perl_croak_nocontext("Don't know how to get file name");
4892 return NULL;
4893#endif
4894}
4895
4896
4897/*--------------------------------------------------------------------------------------*/
4898/*
4899 * Functions which can be called on any kind of PerlIO implemented in
4900 * terms of above
4901 */
4902
4903#undef PerlIO_fdopen
4904PerlIO *
4905PerlIO_fdopen(int fd, const char *mode)
4906{
4907 dTHX;
4908 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4909}
4910
4911#undef PerlIO_open
4912PerlIO *
4913PerlIO_open(const char *path, const char *mode)
4914{
4915 dTHX;
4916 SV *name = sv_2mortal(newSVpv(path, 0));
4917 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4918}
4919
4920#undef Perlio_reopen
4921PerlIO *
4922PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4923{
4924 dTHX;
4925 SV *name = sv_2mortal(newSVpv(path,0));
4926 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4927}
4928
4929#undef PerlIO_getc
4930int
4931PerlIO_getc(PerlIO *f)
4932{
4933 dTHX;
4934 STDCHAR buf[1];
4935 if ( 1 == PerlIO_read(f, buf, 1) ) {
4936 return (unsigned char) buf[0];
4937 }
4938 return EOF;
4939}
4940
4941#undef PerlIO_ungetc
4942int
4943PerlIO_ungetc(PerlIO *f, int ch)
4944{
4945 dTHX;
4946 if (ch != EOF) {
4947 STDCHAR buf = ch;
4948 if (PerlIO_unread(f, &buf, 1) == 1)
4949 return ch;
4950 }
4951 return EOF;
4952}
4953
4954#undef PerlIO_putc
4955int
4956PerlIO_putc(PerlIO *f, int ch)
4957{
4958 dTHX;
4959 STDCHAR buf = ch;
4960 return PerlIO_write(f, &buf, 1);
4961}
4962
4963#undef PerlIO_puts
4964int
4965PerlIO_puts(PerlIO *f, const char *s)
4966{
4967 dTHX;
4968 return PerlIO_write(f, s, strlen(s));
4969}
4970
4971#undef PerlIO_rewind
4972void
4973PerlIO_rewind(PerlIO *f)
4974{
4975 dTHX;
4976 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4977 PerlIO_clearerr(f);
4978}
4979
4980#undef PerlIO_vprintf
4981int
4982PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
4983{
4984 dTHX;
4985 SV * sv;
4986 const char *s;
4987 STRLEN len;
4988 SSize_t wrote;
4989#ifdef NEED_VA_COPY
4990 va_list apc;
4991 Perl_va_copy(ap, apc);
4992 sv = vnewSVpvf(fmt, &apc);
4993 va_end(apc);
4994#else
4995 sv = vnewSVpvf(fmt, &ap);
4996#endif
4997 s = SvPV_const(sv, len);
4998 wrote = PerlIO_write(f, s, len);
4999 SvREFCNT_dec(sv);
5000 return wrote;
5001}
5002
5003#undef PerlIO_printf
5004int
5005PerlIO_printf(PerlIO *f, const char *fmt, ...)
5006{
5007 va_list ap;
5008 int result;
5009 va_start(ap, fmt);
5010 result = PerlIO_vprintf(f, fmt, ap);
5011 va_end(ap);
5012 return result;
5013}
5014
5015#undef PerlIO_stdoutf
5016int
5017PerlIO_stdoutf(const char *fmt, ...)
5018{
5019 dTHX;
5020 va_list ap;
5021 int result;
5022 va_start(ap, fmt);
5023 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5024 va_end(ap);
5025 return result;
5026}
5027
5028#undef PerlIO_tmpfile
5029PerlIO *
5030PerlIO_tmpfile(void)
5031{
5032 return PerlIO_tmpfile_flags(0);
5033}
5034
5035#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL )
5036#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC )
5037
5038PerlIO *
5039PerlIO_tmpfile_flags(int imode)
5040{
5041#ifndef WIN32
5042 dTHX;
5043#endif
5044 PerlIO *f = NULL;
5045#ifdef WIN32
5046 const int fd = win32_tmpfd_mode(imode);
5047 if (fd >= 0)
5048 f = PerlIO_fdopen(fd, "w+b");
5049#elif ! defined(OS2)
5050 int fd = -1;
5051 char tempname[] = "/tmp/PerlIO_XXXXXX";
5052 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5053 SV * sv = NULL;
5054 int old_umask = umask(0177);
5055 imode &= ~MKOSTEMP_MODE_MASK;
5056 if (tmpdir && *tmpdir) {
5057 /* if TMPDIR is set and not empty, we try that first */
5058 sv = newSVpv(tmpdir, 0);
5059 sv_catpv(sv, tempname + 4);
5060 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
5061 }
5062 if (fd < 0) {
5063 SvREFCNT_dec(sv);
5064 sv = NULL;
5065 /* else we try /tmp */
5066 fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE);
5067 }
5068 if (fd < 0) {
5069 /* Try cwd */
5070 sv = newSVpvs(".");
5071 sv_catpv(sv, tempname + 4);
5072 fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE);
5073 }
5074 umask(old_umask);
5075 if (fd >= 0) {
5076 /* fdopen() with a numeric mode */
5077 char mode[8];
5078 int writing = 1;
5079 (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing);
5080 f = PerlIO_fdopen(fd, mode);
5081 if (f)
5082 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5083# ifndef VMS
5084 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5085# endif
5086 }
5087 SvREFCNT_dec(sv);
5088#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5089 FILE * const stdio = PerlSIO_tmpfile();
5090
5091 if (stdio)
5092 f = PerlIO_fdopen(fileno(stdio), "w+");
5093
5094#endif /* else WIN32 */
5095 return f;
5096}
5097
5098void
5099Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5100{
5101 PERL_UNUSED_CONTEXT;
5102 if (!PerlIOValid(f))
5103 return;
5104 PerlIOBase(f)->err = errno;
5105#ifdef VMS
5106 PerlIOBase(f)->os_err = vaxc$errno;
5107#elif defined(OS2)
5108 PerlIOBase(f)->os_err = Perl_rc;
5109#elif defined(WIN32)
5110 PerlIOBase(f)->os_err = GetLastError();
5111#endif
5112}
5113
5114void
5115Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5116{
5117 PERL_UNUSED_CONTEXT;
5118 if (!PerlIOValid(f))
5119 return;
5120 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5121#ifdef OS2
5122 Perl_rc = PerlIOBase(f)->os_err);
5123#elif defined(WIN32)
5124 SetLastError(PerlIOBase(f)->os_err);
5125#endif
5126}
5127
5128#undef HAS_FSETPOS
5129#undef HAS_FGETPOS
5130
5131
5132/*======================================================================================*/
5133/*
5134 * Now some functions in terms of above which may be needed even if we are
5135 * not in true PerlIO mode
5136 */
5137const char *
5138Perl_PerlIO_context_layers(pTHX_ const char *mode)
5139{
5140 const char *direction = NULL;
5141 SV *layers;
5142 /*
5143 * Need to supply default layer info from open.pm
5144 */
5145
5146 if (!PL_curcop)
5147 return NULL;
5148
5149 if (mode && mode[0] != 'r') {
5150 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5151 direction = "open>";
5152 } else {
5153 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5154 direction = "open<";
5155 }
5156 if (!direction)
5157 return NULL;
5158
5159 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5160
5161 assert(layers);
5162 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5163}
5164
5165
5166#ifndef HAS_FSETPOS
5167# undef PerlIO_setpos
5168int
5169PerlIO_setpos(PerlIO *f, SV *pos)
5170{
5171 if (SvOK(pos)) {
5172 if (f) {
5173 dTHX;
5174 STRLEN len;
5175 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5176 if(len == sizeof(Off_t))
5177 return PerlIO_seek(f, *posn, SEEK_SET);
5178 }
5179 }
5180 SETERRNO(EINVAL, SS_IVCHAN);
5181 return -1;
5182}
5183#else
5184# undef PerlIO_setpos
5185int
5186PerlIO_setpos(PerlIO *f, SV *pos)
5187{
5188 if (SvOK(pos)) {
5189 if (f) {
5190 dTHX;
5191 STRLEN len;
5192 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5193 if(len == sizeof(Fpos_t))
5194# if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5195 return fsetpos64(f, fpos);
5196# else
5197 return fsetpos(f, fpos);
5198# endif
5199 }
5200 }
5201 SETERRNO(EINVAL, SS_IVCHAN);
5202 return -1;
5203}
5204#endif
5205
5206#ifndef HAS_FGETPOS
5207# undef PerlIO_getpos
5208int
5209PerlIO_getpos(PerlIO *f, SV *pos)
5210{
5211 dTHX;
5212 Off_t posn = PerlIO_tell(f);
5213 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5214 return (posn == (Off_t) - 1) ? -1 : 0;
5215}
5216#else
5217# undef PerlIO_getpos
5218int
5219PerlIO_getpos(PerlIO *f, SV *pos)
5220{
5221 dTHX;
5222 Fpos_t fpos;
5223 int code;
5224# if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5225 code = fgetpos64(f, &fpos);
5226# else
5227 code = fgetpos(f, &fpos);
5228# endif
5229 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5230 return code;
5231}
5232#endif
5233
5234/* print a failure format string message to stderr and fail exit the process
5235 using only libc without depending on any perl data structures being
5236 initialized.
5237*/
5238
5239void
5240Perl_noperl_die(const char* pat, ...)
5241{
5242 va_list arglist;
5243 PERL_ARGS_ASSERT_NOPERL_DIE;
5244 va_start(arglist, pat);
5245 vfprintf(stderr, pat, arglist);
5246 va_end(arglist);
5247 exit(1);
5248}
5249
5250/*
5251 * ex: set ts=8 sts=4 sw=4 et:
5252 */