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
108 extern int fseeko(FILE *, off_t, int);
109 extern off_t ftello(FILE *);
110 #endif
111
112 #define NATIVE_0xd CR_NATIVE
113 #define NATIVE_0xa LF_NATIVE
114
115 EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode);
116
117 int
perlsio_binmode(FILE * fp,int iotype,int mode)118 perlsio_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
158 int
159 PerlIO_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
208 int
209 PerlIO_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
225 void
226 PerlIO_destruct(pTHX)
227 {
228 }
229
230 int
231 PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
232 {
233 return perlsio_binmode(fp, iotype, mode);
234 }
235
236 PerlIO *
237 PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
238 {
239 #if defined(PERL_MICRO) || defined(__SYMBIAN32__)
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
275 PerlIO *
276 PerlIO_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
310 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
311 XS(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
325 void
326 Perl_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
341 void
342 PerlIO_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)
413 static void
414 PerlIO_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
443 static void
444 PerlIO_init_table(pTHX)
445 {
446 if (PL_perlio)
447 return;
448 Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
449 }
450
451
452
453 PerlIO *
454 PerlIO_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
485 PerlIO *
486 PerlIO_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
503 void
504 PerlIO_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
522 PerlIO_list_t *
523 PerlIO_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
532 void
533 PerlIO_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
548 void
549 PerlIO_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
569 PerlIO_list_t *
570 PerlIO_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
590 void
591 PerlIO_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
618 void
619 PerlIO_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
647 void
648 PerlIO_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
683 AV *
684 PerlIO_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
716 PerlIO_funcs *
717 PerlIO_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
761 static int
762 perlio_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
774 static int
775 perlio_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
787 static int
788 perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
789 {
790 Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv));
791 return 0;
792 }
793
794 static int
795 perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
796 {
797 Perl_warn(aTHX_ "free %" SVf, SVfARG(sv));
798 return 0;
799 }
800
801 MGVTBL perlio_vtab = {
802 perlio_mg_get,
803 perlio_mg_set,
804 NULL, /* len */
805 perlio_mg_clear,
806 perlio_mg_free
807 };
808
809 XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */
810 XS(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
842 SV *
843 PerlIO_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
850 XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */
851 XS(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
864 XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */
865 XS(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
882 void
883 PerlIO_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
891 int
892 PerlIO_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
981 void
982 PerlIO_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
995 SV *
996 PerlIO_arg_fetch(PerlIO_list_t *av, IV n)
997 {
998 return av->array[n].arg;
999 }
1000
1001 PerlIO_funcs *
1002 PerlIO_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
1014 IV
1015 PerlIOPop_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
1028 PERLIO_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
1059 PerlIO_list_t *
1060 PerlIO_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
1095 void
1096 Perl_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
1106 PerlIO_funcs *
1107 PerlIO_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
1118 void
1119 PerlIO_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
1129 PerlIO *
1130 PerlIO_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
1183 PerlIO *
1184 PerlIOBase_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
1201 IV
1202 PerlIOBase_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
1219 IV
1220 PerlIORaw_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
1261 int
1262 PerlIO_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
1279 int
1280 PerlIO_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
1303 int
1304 PerlIO_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
1366 int
1367 PerlIO__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
1382 int
1383 Perl_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
1395 int
1396 Perl_PerlIO_fileno(pTHX_ PerlIO *f)
1397 {
1398 Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f));
1399 }
1400
1401
1402 static PerlIO_funcs *
1403 PerlIO_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
1435 PerlIO_list_t *
1436 PerlIO_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
1488 PerlIO *
1489 PerlIO_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 if ((f = PerlIO_tmpfile())) {
1494 if (!layers || !*layers)
1495 layers = Perl_PerlIO_context_layers(aTHX_ mode);
1496 if (layers && *layers)
1497 PerlIO_apply_layers(aTHX_ f, mode, layers);
1498 }
1499 }
1500 else {
1501 PerlIO_list_t *layera;
1502 IV n;
1503 PerlIO_funcs *tab = NULL;
1504 if (PerlIOValid(f)) {
1505 /*
1506 * This is "reopen" - it is not tested as perl does not use it
1507 * yet
1508 */
1509 PerlIOl *l = *f;
1510 layera = PerlIO_list_alloc(aTHX);
1511 while (l) {
1512 SV *arg = NULL;
1513 if (l->tab && l->tab->Getarg)
1514 arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
1515 PerlIO_list_push(aTHX_ layera, l->tab,
1516 (arg) ? arg : &PL_sv_undef);
1517 SvREFCNT_dec(arg);
1518 l = *PerlIONext(&l);
1519 }
1520 }
1521 else {
1522 layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args);
1523 if (!layera) {
1524 return NULL;
1525 }
1526 }
1527 /*
1528 * Start at "top" of layer stack
1529 */
1530 n = layera->cur - 1;
1531 while (n >= 0) {
1532 PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL);
1533 if (t && t->Open) {
1534 tab = t;
1535 break;
1536 }
1537 n--;
1538 }
1539 if (tab) {
1540 /*
1541 * Found that layer 'n' can do opens - call it
1542 */
1543 if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) {
1544 Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name);
1545 }
1546 DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n",
1547 tab->name, layers ? layers : "(Null)", mode, fd,
1548 imode, perm, (void*)f, narg, (void*)args) );
1549 if (tab->Open)
1550 f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm,
1551 f, narg, args);
1552 else {
1553 SETERRNO(EINVAL, LIB_INVARG);
1554 f = NULL;
1555 }
1556 if (f) {
1557 if (n + 1 < layera->cur) {
1558 /*
1559 * More layers above the one that we used to open -
1560 * apply them now
1561 */
1562 if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) {
1563 /* If pushing layers fails close the file */
1564 PerlIO_close(f);
1565 f = NULL;
1566 }
1567 }
1568 }
1569 }
1570 PerlIO_list_free(aTHX_ layera);
1571 }
1572 return f;
1573 }
1574
1575
1576 SSize_t
1577 Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
1578 {
1579 PERL_ARGS_ASSERT_PERLIO_READ;
1580
1581 Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count));
1582 }
1583
1584 SSize_t
1585 Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1586 {
1587 PERL_ARGS_ASSERT_PERLIO_UNREAD;
1588
1589 Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count));
1590 }
1591
1592 SSize_t
1593 Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1594 {
1595 PERL_ARGS_ASSERT_PERLIO_WRITE;
1596
1597 Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count));
1598 }
1599
1600 int
1601 Perl_PerlIO_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
1602 {
1603 Perl_PerlIO_or_fail(f, Seek, -1, (aTHX_ f, offset, whence));
1604 }
1605
1606 Off_t
1607 Perl_PerlIO_tell(pTHX_ PerlIO *f)
1608 {
1609 Perl_PerlIO_or_fail(f, Tell, -1, (aTHX_ f));
1610 }
1611
1612 int
1613 Perl_PerlIO_flush(pTHX_ PerlIO *f)
1614 {
1615 if (f) {
1616 if (*f) {
1617 const PerlIO_funcs *tab = PerlIOBase(f)->tab;
1618
1619 if (tab && tab->Flush)
1620 return (*tab->Flush) (aTHX_ f);
1621 else
1622 return 0; /* If no Flush defined, silently succeed. */
1623 }
1624 else {
1625 DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) );
1626 SETERRNO(EBADF, SS_IVCHAN);
1627 return -1;
1628 }
1629 }
1630 else {
1631 /*
1632 * Is it good API design to do flush-all on NULL, a potentially
1633 * erroneous input? Maybe some magical value (PerlIO*
1634 * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar
1635 * things on fflush(NULL), but should we be bound by their design
1636 * decisions? --jhi
1637 */
1638 PerlIOl **table = &PL_perlio;
1639 PerlIOl *ff;
1640 int code = 0;
1641 while ((ff = *table)) {
1642 int i;
1643 table = (PerlIOl **) (ff++);
1644 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1645 if (ff->next && PerlIO_flush(&(ff->next)) != 0)
1646 code = -1;
1647 ff++;
1648 }
1649 }
1650 return code;
1651 }
1652 }
1653
1654 void
1655 PerlIOBase_flush_linebuf(pTHX)
1656 {
1657 PerlIOl **table = &PL_perlio;
1658 PerlIOl *f;
1659 while ((f = *table)) {
1660 int i;
1661 table = (PerlIOl **) (f++);
1662 for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
1663 if (f->next
1664 && (PerlIOBase(&(f->next))->
1665 flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1666 == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
1667 PerlIO_flush(&(f->next));
1668 f++;
1669 }
1670 }
1671 }
1672
1673 int
1674 Perl_PerlIO_fill(pTHX_ PerlIO *f)
1675 {
1676 Perl_PerlIO_or_fail(f, Fill, -1, (aTHX_ f));
1677 }
1678
1679 int
1680 PerlIO_isutf8(PerlIO *f)
1681 {
1682 if (PerlIOValid(f))
1683 return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0;
1684 else
1685 SETERRNO(EBADF, SS_IVCHAN);
1686
1687 return -1;
1688 }
1689
1690 int
1691 Perl_PerlIO_eof(pTHX_ PerlIO *f)
1692 {
1693 Perl_PerlIO_or_Base(f, Eof, eof, -1, (aTHX_ f));
1694 }
1695
1696 int
1697 Perl_PerlIO_error(pTHX_ PerlIO *f)
1698 {
1699 Perl_PerlIO_or_Base(f, Error, error, -1, (aTHX_ f));
1700 }
1701
1702 void
1703 Perl_PerlIO_clearerr(pTHX_ PerlIO *f)
1704 {
1705 Perl_PerlIO_or_Base_void(f, Clearerr, clearerr, (aTHX_ f));
1706 }
1707
1708 void
1709 Perl_PerlIO_setlinebuf(pTHX_ PerlIO *f)
1710 {
1711 Perl_PerlIO_or_Base_void(f, Setlinebuf, setlinebuf, (aTHX_ f));
1712 }
1713
1714 int
1715 PerlIO_has_base(PerlIO *f)
1716 {
1717 if (PerlIOValid(f)) {
1718 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1719
1720 if (tab)
1721 return (tab->Get_base != NULL);
1722 }
1723
1724 return 0;
1725 }
1726
1727 int
1728 PerlIO_fast_gets(PerlIO *f)
1729 {
1730 if (PerlIOValid(f)) {
1731 if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) {
1732 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1733
1734 if (tab)
1735 return (tab->Set_ptrcnt != NULL);
1736 }
1737 }
1738
1739 return 0;
1740 }
1741
1742 int
1743 PerlIO_has_cntptr(PerlIO *f)
1744 {
1745 if (PerlIOValid(f)) {
1746 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1747
1748 if (tab)
1749 return (tab->Get_ptr != NULL && tab->Get_cnt != NULL);
1750 }
1751
1752 return 0;
1753 }
1754
1755 int
1756 PerlIO_canset_cnt(PerlIO *f)
1757 {
1758 if (PerlIOValid(f)) {
1759 const PerlIO_funcs * const tab = PerlIOBase(f)->tab;
1760
1761 if (tab)
1762 return (tab->Set_ptrcnt != NULL);
1763 }
1764
1765 return 0;
1766 }
1767
1768 STDCHAR *
1769 Perl_PerlIO_get_base(pTHX_ PerlIO *f)
1770 {
1771 Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f));
1772 }
1773
1774 SSize_t
1775 Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f)
1776 {
1777 /* Note that Get_bufsiz returns a Size_t */
1778 Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f));
1779 }
1780
1781 STDCHAR *
1782 Perl_PerlIO_get_ptr(pTHX_ PerlIO *f)
1783 {
1784 Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f));
1785 }
1786
1787 SSize_t
1788 Perl_PerlIO_get_cnt(pTHX_ PerlIO *f)
1789 {
1790 Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f));
1791 }
1792
1793 void
1794 Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt)
1795 {
1796 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt));
1797 }
1798
1799 void
1800 Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
1801 {
1802 Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt));
1803 }
1804
1805
1806 /*--------------------------------------------------------------------------------------*/
1807 /*
1808 * utf8 and raw dummy layers
1809 */
1810
1811 IV
1812 PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1813 {
1814 PERL_UNUSED_CONTEXT;
1815 PERL_UNUSED_ARG(mode);
1816 PERL_UNUSED_ARG(arg);
1817 if (PerlIOValid(f)) {
1818 if (tab && tab->kind & PERLIO_K_UTF8)
1819 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
1820 else
1821 PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
1822 return 0;
1823 }
1824 return -1;
1825 }
1826
1827 PERLIO_FUNCS_DECL(PerlIO_utf8) = {
1828 sizeof(PerlIO_funcs),
1829 "utf8",
1830 0,
1831 PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG,
1832 PerlIOUtf8_pushed,
1833 NULL,
1834 PerlIOBase_open,
1835 NULL,
1836 NULL,
1837 NULL,
1838 NULL,
1839 NULL,
1840 NULL,
1841 NULL,
1842 NULL,
1843 NULL,
1844 NULL,
1845 NULL, /* flush */
1846 NULL, /* fill */
1847 NULL,
1848 NULL,
1849 NULL,
1850 NULL,
1851 NULL, /* get_base */
1852 NULL, /* get_bufsiz */
1853 NULL, /* get_ptr */
1854 NULL, /* get_cnt */
1855 NULL, /* set_ptrcnt */
1856 };
1857
1858 PERLIO_FUNCS_DECL(PerlIO_byte) = {
1859 sizeof(PerlIO_funcs),
1860 "bytes",
1861 0,
1862 PERLIO_K_DUMMY | PERLIO_K_MULTIARG,
1863 PerlIOUtf8_pushed,
1864 NULL,
1865 PerlIOBase_open,
1866 NULL,
1867 NULL,
1868 NULL,
1869 NULL,
1870 NULL,
1871 NULL,
1872 NULL,
1873 NULL,
1874 NULL,
1875 NULL,
1876 NULL, /* flush */
1877 NULL, /* fill */
1878 NULL,
1879 NULL,
1880 NULL,
1881 NULL,
1882 NULL, /* get_base */
1883 NULL, /* get_bufsiz */
1884 NULL, /* get_ptr */
1885 NULL, /* get_cnt */
1886 NULL, /* set_ptrcnt */
1887 };
1888
1889 PERLIO_FUNCS_DECL(PerlIO_raw) = {
1890 sizeof(PerlIO_funcs),
1891 "raw",
1892 0,
1893 PERLIO_K_DUMMY,
1894 PerlIORaw_pushed,
1895 PerlIOBase_popped,
1896 PerlIOBase_open,
1897 NULL,
1898 NULL,
1899 NULL,
1900 NULL,
1901 NULL,
1902 NULL,
1903 NULL,
1904 NULL,
1905 NULL,
1906 NULL,
1907 NULL, /* flush */
1908 NULL, /* fill */
1909 NULL,
1910 NULL,
1911 NULL,
1912 NULL,
1913 NULL, /* get_base */
1914 NULL, /* get_bufsiz */
1915 NULL, /* get_ptr */
1916 NULL, /* get_cnt */
1917 NULL, /* set_ptrcnt */
1918 };
1919 /*--------------------------------------------------------------------------------------*/
1920 /*--------------------------------------------------------------------------------------*/
1921 /*
1922 * "Methods" of the "base class"
1923 */
1924
1925 IV
1926 PerlIOBase_fileno(pTHX_ PerlIO *f)
1927 {
1928 return PerlIOValid(f) ? PerlIO_fileno(PerlIONext(f)) : -1;
1929 }
1930
1931 char *
1932 PerlIO_modestr(PerlIO * f, char *buf)
1933 {
1934 char *s = buf;
1935 if (PerlIOValid(f)) {
1936 const IV flags = PerlIOBase(f)->flags;
1937 if (flags & PERLIO_F_APPEND) {
1938 *s++ = 'a';
1939 if (flags & PERLIO_F_CANREAD) {
1940 *s++ = '+';
1941 }
1942 }
1943 else if (flags & PERLIO_F_CANREAD) {
1944 *s++ = 'r';
1945 if (flags & PERLIO_F_CANWRITE)
1946 *s++ = '+';
1947 }
1948 else if (flags & PERLIO_F_CANWRITE) {
1949 *s++ = 'w';
1950 if (flags & PERLIO_F_CANREAD) {
1951 *s++ = '+';
1952 }
1953 }
1954 #ifdef PERLIO_USING_CRLF
1955 if (!(flags & PERLIO_F_CRLF))
1956 *s++ = 'b';
1957 #endif
1958 }
1959 *s = '\0';
1960 return buf;
1961 }
1962
1963
1964 IV
1965 PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
1966 {
1967 PerlIOl * const l = PerlIOBase(f);
1968 PERL_UNUSED_CONTEXT;
1969 PERL_UNUSED_ARG(arg);
1970
1971 l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
1972 PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
1973 if (tab && tab->Set_ptrcnt != NULL)
1974 l->flags |= PERLIO_F_FASTGETS;
1975 if (mode) {
1976 if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
1977 mode++;
1978 switch (*mode++) {
1979 case 'r':
1980 l->flags |= PERLIO_F_CANREAD;
1981 break;
1982 case 'a':
1983 l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE;
1984 break;
1985 case 'w':
1986 l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE;
1987 break;
1988 default:
1989 SETERRNO(EINVAL, LIB_INVARG);
1990 return -1;
1991 }
1992 #ifdef EBCDIC
1993 {
1994 /* The mode variable contains one positional parameter followed by
1995 * optional keyword parameters. The positional parameters must be
1996 * passed as lowercase characters. The keyword parameters can be
1997 * passed in mixed case. They must be separated by commas. Only one
1998 * instance of a keyword can be specified. */
1999 int comma = 0;
2000 while (*mode) {
2001 switch (*mode++) {
2002 case '+':
2003 if(!comma)
2004 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2005 break;
2006 case 'b':
2007 if(!comma)
2008 l->flags &= ~PERLIO_F_CRLF;
2009 break;
2010 case 't':
2011 if(!comma)
2012 l->flags |= PERLIO_F_CRLF;
2013 break;
2014 case ',':
2015 comma = 1;
2016 break;
2017 default:
2018 break;
2019 }
2020 }
2021 }
2022 #else
2023 while (*mode) {
2024 switch (*mode++) {
2025 case '+':
2026 l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE;
2027 break;
2028 case 'b':
2029 l->flags &= ~PERLIO_F_CRLF;
2030 break;
2031 case 't':
2032 l->flags |= PERLIO_F_CRLF;
2033 break;
2034 default:
2035 SETERRNO(EINVAL, LIB_INVARG);
2036 return -1;
2037 }
2038 }
2039 #endif
2040 }
2041 else {
2042 if (l->next) {
2043 l->flags |= l->next->flags &
2044 (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE |
2045 PERLIO_F_APPEND);
2046 }
2047 }
2048 #if 0
2049 DEBUG_i(
2050 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n",
2051 (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)",
2052 l->flags, PerlIO_modestr(f, temp));
2053 );
2054 #endif
2055 return 0;
2056 }
2057
2058 IV
2059 PerlIOBase_popped(pTHX_ PerlIO *f)
2060 {
2061 PERL_UNUSED_CONTEXT;
2062 PERL_UNUSED_ARG(f);
2063 return 0;
2064 }
2065
2066 SSize_t
2067 PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2068 {
2069 /*
2070 * Save the position as current head considers it
2071 */
2072 const Off_t old = PerlIO_tell(f);
2073 PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_pending), "r", NULL);
2074 PerlIOSelf(f, PerlIOBuf)->posn = old;
2075 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
2076 }
2077
2078 SSize_t
2079 PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2080 {
2081 STDCHAR *buf = (STDCHAR *) vbuf;
2082 if (f) {
2083 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
2084 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2085 SETERRNO(EBADF, SS_IVCHAN);
2086 PerlIO_save_errno(f);
2087 return 0;
2088 }
2089 while (count > 0) {
2090 get_cnt:
2091 {
2092 SSize_t avail = PerlIO_get_cnt(f);
2093 SSize_t take = 0;
2094 if (avail > 0)
2095 take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail;
2096 if (take > 0) {
2097 STDCHAR *ptr = PerlIO_get_ptr(f);
2098 Copy(ptr, buf, take, STDCHAR);
2099 PerlIO_set_ptrcnt(f, ptr + take, (avail -= take));
2100 count -= take;
2101 buf += take;
2102 if (avail == 0) /* set_ptrcnt could have reset avail */
2103 goto get_cnt;
2104 }
2105 if (count > 0 && avail <= 0) {
2106 if (PerlIO_fill(f) != 0)
2107 break;
2108 }
2109 }
2110 }
2111 return (buf - (STDCHAR *) vbuf);
2112 }
2113 return 0;
2114 }
2115
2116 IV
2117 PerlIOBase_noop_ok(pTHX_ PerlIO *f)
2118 {
2119 PERL_UNUSED_CONTEXT;
2120 PERL_UNUSED_ARG(f);
2121 return 0;
2122 }
2123
2124 IV
2125 PerlIOBase_noop_fail(pTHX_ PerlIO *f)
2126 {
2127 PERL_UNUSED_CONTEXT;
2128 PERL_UNUSED_ARG(f);
2129 return -1;
2130 }
2131
2132 IV
2133 PerlIOBase_close(pTHX_ PerlIO *f)
2134 {
2135 IV code = -1;
2136 if (PerlIOValid(f)) {
2137 PerlIO *n = PerlIONext(f);
2138 code = PerlIO_flush(f);
2139 PerlIOBase(f)->flags &=
2140 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2141 while (PerlIOValid(n)) {
2142 const PerlIO_funcs * const tab = PerlIOBase(n)->tab;
2143 if (tab && tab->Close) {
2144 if ((*tab->Close)(aTHX_ n) != 0)
2145 code = -1;
2146 break;
2147 }
2148 else {
2149 PerlIOBase(n)->flags &=
2150 ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN);
2151 }
2152 n = PerlIONext(n);
2153 }
2154 }
2155 else {
2156 SETERRNO(EBADF, SS_IVCHAN);
2157 }
2158 return code;
2159 }
2160
2161 IV
2162 PerlIOBase_eof(pTHX_ PerlIO *f)
2163 {
2164 PERL_UNUSED_CONTEXT;
2165 if (PerlIOValid(f)) {
2166 return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0;
2167 }
2168 return 1;
2169 }
2170
2171 IV
2172 PerlIOBase_error(pTHX_ PerlIO *f)
2173 {
2174 PERL_UNUSED_CONTEXT;
2175 if (PerlIOValid(f)) {
2176 return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0;
2177 }
2178 return 1;
2179 }
2180
2181 void
2182 PerlIOBase_clearerr(pTHX_ PerlIO *f)
2183 {
2184 if (PerlIOValid(f)) {
2185 PerlIO * const n = PerlIONext(f);
2186 PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF);
2187 if (PerlIOValid(n))
2188 PerlIO_clearerr(n);
2189 }
2190 }
2191
2192 void
2193 PerlIOBase_setlinebuf(pTHX_ PerlIO *f)
2194 {
2195 PERL_UNUSED_CONTEXT;
2196 if (PerlIOValid(f)) {
2197 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
2198 }
2199 }
2200
2201 SV *
2202 PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param)
2203 {
2204 if (!arg)
2205 return NULL;
2206 #ifdef USE_ITHREADS
2207 if (param) {
2208 arg = sv_dup(arg, param);
2209 SvREFCNT_inc_simple_void_NN(arg);
2210 return arg;
2211 }
2212 else {
2213 return newSVsv(arg);
2214 }
2215 #else
2216 PERL_UNUSED_ARG(param);
2217 return newSVsv(arg);
2218 #endif
2219 }
2220
2221 PerlIO *
2222 PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2223 {
2224 PerlIO * const nexto = PerlIONext(o);
2225 if (PerlIOValid(nexto)) {
2226 const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab;
2227 if (tab && tab->Dup)
2228 f = (*tab->Dup)(aTHX_ f, nexto, param, flags);
2229 else
2230 f = PerlIOBase_dup(aTHX_ f, nexto, param, flags);
2231 }
2232 if (f) {
2233 PerlIO_funcs * const self = PerlIOBase(o)->tab;
2234 SV *arg = NULL;
2235 char buf[8];
2236 assert(self);
2237 DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
2238 self->name,
2239 (void*)f, (void*)o, (void*)param) );
2240 if (self->Getarg)
2241 arg = (*self->Getarg)(aTHX_ o, param, flags);
2242 f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
2243 if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8)
2244 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
2245 SvREFCNT_dec(arg);
2246 }
2247 return f;
2248 }
2249
2250 /* PL_perlio_fd_refcnt[] is in intrpvar.h */
2251
2252 /* Must be called with PL_perlio_mutex locked. */
2253 static void
2254 S_more_refcounted_fds(pTHX_ const int new_fd)
2255 PERL_TSA_REQUIRES(PL_perlio_mutex)
2256 {
2257 dVAR;
2258 const int old_max = PL_perlio_fd_refcnt_size;
2259 const int new_max = 16 + (new_fd & ~15);
2260 int *new_array;
2261
2262 #ifndef PERL_IMPLICIT_SYS
2263 PERL_UNUSED_CONTEXT;
2264 #endif
2265
2266 DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n",
2267 old_max, new_fd, new_max) );
2268
2269 if (new_fd < old_max) {
2270 return;
2271 }
2272
2273 assert (new_max > new_fd);
2274
2275 /* Use plain realloc() since we need this memory to be really
2276 * global and visible to all the interpreters and/or threads. */
2277 new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int));
2278
2279 if (!new_array) {
2280 MUTEX_UNLOCK(&PL_perlio_mutex);
2281 croak_no_mem();
2282 }
2283
2284 PL_perlio_fd_refcnt_size = new_max;
2285 PL_perlio_fd_refcnt = new_array;
2286
2287 DEBUG_i( PerlIO_debug("Zeroing %p, %d\n",
2288 (void*)(new_array + old_max),
2289 new_max - old_max) );
2290
2291 Zero(new_array + old_max, new_max - old_max, int);
2292 }
2293
2294
2295 void
2296 PerlIO_init(pTHX)
2297 {
2298 /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */
2299 PERL_UNUSED_CONTEXT;
2300 }
2301
2302 void
2303 PerlIOUnix_refcnt_inc(int fd)
2304 {
2305 dTHX;
2306 if (fd >= 0) {
2307 dVAR;
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
2329 int
2330 PerlIOUnix_refcnt_dec(int fd)
2331 {
2332 int cnt = 0;
2333 if (fd >= 0) {
2334 #ifdef DEBUGGING
2335 dTHX;
2336 #else
2337 dVAR;
2338 #endif
2339 MUTEX_LOCK(&PL_perlio_mutex);
2340 if (fd >= PL_perlio_fd_refcnt_size) {
2341 /* diag_listed_as: refcnt_dec: fd %d%s */
2342 Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n",
2343 fd, PL_perlio_fd_refcnt_size);
2344 }
2345 if (PL_perlio_fd_refcnt[fd] <= 0) {
2346 /* diag_listed_as: refcnt_dec: fd %d%s */
2347 Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n",
2348 fd, PL_perlio_fd_refcnt[fd]);
2349 }
2350 cnt = --PL_perlio_fd_refcnt[fd];
2351 DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) );
2352 MUTEX_UNLOCK(&PL_perlio_mutex);
2353 } else {
2354 /* diag_listed_as: refcnt_dec: fd %d%s */
2355 Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd);
2356 }
2357 return cnt;
2358 }
2359
2360 int
2361 PerlIOUnix_refcnt(int fd)
2362 {
2363 dTHX;
2364 int cnt = 0;
2365 if (fd >= 0) {
2366 dVAR;
2367 MUTEX_LOCK(&PL_perlio_mutex);
2368 if (fd >= PL_perlio_fd_refcnt_size) {
2369 /* diag_listed_as: refcnt: fd %d%s */
2370 Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n",
2371 fd, PL_perlio_fd_refcnt_size);
2372 }
2373 if (PL_perlio_fd_refcnt[fd] <= 0) {
2374 /* diag_listed_as: refcnt: fd %d%s */
2375 Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n",
2376 fd, PL_perlio_fd_refcnt[fd]);
2377 }
2378 cnt = PL_perlio_fd_refcnt[fd];
2379 MUTEX_UNLOCK(&PL_perlio_mutex);
2380 } else {
2381 /* diag_listed_as: refcnt: fd %d%s */
2382 Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd);
2383 }
2384 return cnt;
2385 }
2386
2387 void
2388 PerlIO_cleanup(pTHX)
2389 {
2390 int i;
2391 #ifdef USE_ITHREADS
2392 DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) );
2393 #else
2394 DEBUG_i( PerlIO_debug("Cleanup layers\n") );
2395 #endif
2396
2397 /* Raise STDIN..STDERR refcount so we don't close them */
2398 for (i=0; i < 3; i++)
2399 PerlIOUnix_refcnt_inc(i);
2400 PerlIO_cleantable(aTHX_ &PL_perlio);
2401 /* Restore STDIN..STDERR refcount */
2402 for (i=0; i < 3; i++)
2403 PerlIOUnix_refcnt_dec(i);
2404
2405 if (PL_known_layers) {
2406 PerlIO_list_free(aTHX_ PL_known_layers);
2407 PL_known_layers = NULL;
2408 }
2409 if (PL_def_layerlist) {
2410 PerlIO_list_free(aTHX_ PL_def_layerlist);
2411 PL_def_layerlist = NULL;
2412 }
2413 }
2414
2415 void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */
2416 {
2417 dVAR;
2418 #if 0
2419 /* XXX we can't rely on an interpreter being present at this late stage,
2420 XXX so we can't use a function like PerlLIO_write that relies on one
2421 being present (at least in win32) :-(.
2422 Disable for now.
2423 */
2424 #ifdef DEBUGGING
2425 {
2426 /* By now all filehandles should have been closed, so any
2427 * stray (non-STD-)filehandles indicate *possible* (PerlIO)
2428 * errors. */
2429 #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64
2430 #define PERLIO_TEARDOWN_MESSAGE_FD 2
2431 char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE];
2432 int i;
2433 for (i = 3; i < PL_perlio_fd_refcnt_size; i++) {
2434 if (PL_perlio_fd_refcnt[i]) {
2435 const STRLEN len =
2436 my_snprintf(buf, sizeof(buf),
2437 "PerlIO_teardown: fd %d refcnt=%d\n",
2438 i, PL_perlio_fd_refcnt[i]);
2439 PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len);
2440 }
2441 }
2442 }
2443 #endif
2444 #endif
2445 /* Not bothering with PL_perlio_mutex since by now
2446 * all the interpreters are gone. */
2447 if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */
2448 && PL_perlio_fd_refcnt) {
2449 free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */
2450 PL_perlio_fd_refcnt = NULL;
2451 PL_perlio_fd_refcnt_size = 0;
2452 }
2453 }
2454
2455 /*--------------------------------------------------------------------------------------*/
2456 /*
2457 * Bottom-most level for UNIX-like case
2458 */
2459
2460 typedef struct {
2461 struct _PerlIO base; /* The generic part */
2462 int fd; /* UNIX like file descriptor */
2463 int oflags; /* open/fcntl flags */
2464 } PerlIOUnix;
2465
2466 static void
2467 S_lockcnt_dec(pTHX_ const void* f)
2468 {
2469 #ifndef PERL_IMPLICIT_SYS
2470 PERL_UNUSED_CONTEXT;
2471 #endif
2472 PerlIO_lockcnt((PerlIO*)f)--;
2473 }
2474
2475
2476 /* call the signal handler, and if that handler happens to clear
2477 * this handle, free what we can and return true */
2478
2479 static bool
2480 S_perlio_async_run(pTHX_ PerlIO* f) {
2481 ENTER;
2482 SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
2483 PerlIO_lockcnt(f)++;
2484 PERL_ASYNC_CHECK();
2485 if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) {
2486 LEAVE;
2487 return 0;
2488 }
2489 /* we've just run some perl-level code that could have done
2490 * anything, including closing the file or clearing this layer.
2491 * If so, free any lower layers that have already been
2492 * cleared, then return an error. */
2493 while (PerlIOValid(f) &&
2494 (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
2495 {
2496 const PerlIOl *l = *f;
2497 *f = l->next;
2498 Safefree(l);
2499 }
2500 LEAVE;
2501 return 1;
2502 }
2503
2504 int
2505 PerlIOUnix_oflags(const char *mode)
2506 {
2507 int oflags = -1;
2508 if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC)
2509 mode++;
2510 switch (*mode) {
2511 case 'r':
2512 oflags = O_RDONLY;
2513 if (*++mode == '+') {
2514 oflags = O_RDWR;
2515 mode++;
2516 }
2517 break;
2518
2519 case 'w':
2520 oflags = O_CREAT | O_TRUNC;
2521 if (*++mode == '+') {
2522 oflags |= O_RDWR;
2523 mode++;
2524 }
2525 else
2526 oflags |= O_WRONLY;
2527 break;
2528
2529 case 'a':
2530 oflags = O_CREAT | O_APPEND;
2531 if (*++mode == '+') {
2532 oflags |= O_RDWR;
2533 mode++;
2534 }
2535 else
2536 oflags |= O_WRONLY;
2537 break;
2538 }
2539
2540 /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */
2541
2542 /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one
2543 * of them in, and then bit-and-masking the other them away, won't
2544 * have much of an effect. */
2545 switch (*mode) {
2546 case 'b':
2547 #if O_TEXT != O_BINARY
2548 oflags |= O_BINARY;
2549 oflags &= ~O_TEXT;
2550 #endif
2551 mode++;
2552 break;
2553 case 't':
2554 #if O_TEXT != O_BINARY
2555 oflags |= O_TEXT;
2556 oflags &= ~O_BINARY;
2557 #endif
2558 mode++;
2559 break;
2560 default:
2561 # if O_BINARY != 0
2562 /* bit-or:ing with zero O_BINARY would be useless. */
2563 /*
2564 * If neither "t" nor "b" was specified, open the file
2565 * in O_BINARY mode.
2566 *
2567 * Note that if something else than the zero byte was seen
2568 * here (e.g. bogus mode "rx"), just few lines later we will
2569 * set the errno and invalidate the flags.
2570 */
2571 oflags |= O_BINARY;
2572 # endif
2573 break;
2574 }
2575 if (*mode || oflags == -1) {
2576 SETERRNO(EINVAL, LIB_INVARG);
2577 oflags = -1;
2578 }
2579 return oflags;
2580 }
2581
2582 IV
2583 PerlIOUnix_fileno(pTHX_ PerlIO *f)
2584 {
2585 PERL_UNUSED_CONTEXT;
2586 return PerlIOSelf(f, PerlIOUnix)->fd;
2587 }
2588
2589 static void
2590 PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode)
2591 {
2592 PerlIOUnix * const s = PerlIOSelf(f, PerlIOUnix);
2593 #if defined(WIN32)
2594 Stat_t st;
2595 if (PerlLIO_fstat(fd, &st) == 0) {
2596 if (!S_ISREG(st.st_mode)) {
2597 DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) );
2598 PerlIOBase(f)->flags |= PERLIO_F_NOTREG;
2599 }
2600 else {
2601 DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) );
2602 }
2603 }
2604 #endif
2605 s->fd = fd;
2606 s->oflags = imode;
2607 PerlIOUnix_refcnt_inc(fd);
2608 PERL_UNUSED_CONTEXT;
2609 }
2610
2611 IV
2612 PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2613 {
2614 IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2615 if (*PerlIONext(f)) {
2616 /* We never call down so do any pending stuff now */
2617 PerlIO_flush(PerlIONext(f));
2618 /*
2619 * XXX could (or should) we retrieve the oflags from the open file
2620 * handle rather than believing the "mode" we are passed in? XXX
2621 * Should the value on NULL mode be 0 or -1?
2622 */
2623 PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)),
2624 mode ? PerlIOUnix_oflags(mode) : -1);
2625 }
2626 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2627
2628 return code;
2629 }
2630
2631 IV
2632 PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
2633 {
2634 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2635 Off_t new_loc;
2636 PERL_UNUSED_CONTEXT;
2637 if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) {
2638 #ifdef ESPIPE
2639 SETERRNO(ESPIPE, LIB_INVARG);
2640 #else
2641 SETERRNO(EINVAL, LIB_INVARG);
2642 #endif
2643 return -1;
2644 }
2645 new_loc = PerlLIO_lseek(fd, offset, whence);
2646 if (new_loc == (Off_t) - 1)
2647 return -1;
2648 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
2649 return 0;
2650 }
2651
2652 PerlIO *
2653 PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
2654 IV n, const char *mode, int fd, int imode,
2655 int perm, PerlIO *f, int narg, SV **args)
2656 {
2657 bool known_cloexec = 0;
2658 if (PerlIOValid(f)) {
2659 if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
2660 (*PerlIOBase(f)->tab->Close)(aTHX_ f);
2661 }
2662 if (narg > 0) {
2663 if (*mode == IoTYPE_NUMERIC)
2664 mode++;
2665 else {
2666 imode = PerlIOUnix_oflags(mode);
2667 #ifdef VMS
2668 perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */
2669 #else
2670 perm = 0666;
2671 #endif
2672 }
2673 if (imode != -1) {
2674 STRLEN len;
2675 const char *path = SvPV_const(*args, len);
2676 if (!IS_SAFE_PATHNAME(path, len, "open"))
2677 return NULL;
2678 fd = PerlLIO_open3_cloexec(path, imode, perm);
2679 known_cloexec = 1;
2680 }
2681 }
2682 if (fd >= 0) {
2683 if (known_cloexec)
2684 setfd_inhexec_for_sysfd(fd);
2685 else
2686 setfd_cloexec_or_inhexec_by_sysfdness(fd);
2687 if (*mode == IoTYPE_IMPLICIT)
2688 mode++;
2689 if (!f) {
2690 f = PerlIO_allocate(aTHX);
2691 }
2692 if (!PerlIOValid(f)) {
2693 if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
2694 PerlLIO_close(fd);
2695 return NULL;
2696 }
2697 }
2698 PerlIOUnix_setfd(aTHX_ f, fd, imode);
2699 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
2700 if (*mode == IoTYPE_APPEND)
2701 PerlIOUnix_seek(aTHX_ f, 0, SEEK_END);
2702 return f;
2703 }
2704 else {
2705 if (f) {
2706 NOOP;
2707 /*
2708 * FIXME: pop layers ???
2709 */
2710 }
2711 return NULL;
2712 }
2713 }
2714
2715 PerlIO *
2716 PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
2717 {
2718 const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix);
2719 int fd = os->fd;
2720 if (flags & PERLIO_DUP_FD) {
2721 fd = PerlLIO_dup_cloexec(fd);
2722 if (fd >= 0)
2723 setfd_inhexec_for_sysfd(fd);
2724 }
2725 if (fd >= 0) {
2726 f = PerlIOBase_dup(aTHX_ f, o, param, flags);
2727 if (f) {
2728 /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */
2729 PerlIOUnix_setfd(aTHX_ f, fd, os->oflags);
2730 return f;
2731 }
2732 PerlLIO_close(fd);
2733 }
2734 return NULL;
2735 }
2736
2737
2738 SSize_t
2739 PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
2740 {
2741 int fd;
2742 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2743 return -1;
2744 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2745 #ifdef PERLIO_STD_SPECIAL
2746 if (fd == 0)
2747 return PERLIO_STD_IN(fd, vbuf, count);
2748 #endif
2749 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
2750 PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
2751 return 0;
2752 }
2753 while (1) {
2754 const SSize_t len = PerlLIO_read(fd, vbuf, count);
2755 if (len >= 0 || errno != EINTR) {
2756 if (len < 0) {
2757 if (errno != EAGAIN) {
2758 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2759 PerlIO_save_errno(f);
2760 }
2761 }
2762 else if (len == 0 && count != 0) {
2763 PerlIOBase(f)->flags |= PERLIO_F_EOF;
2764 SETERRNO(0,0);
2765 }
2766 return len;
2767 }
2768 /* EINTR */
2769 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2770 return -1;
2771 }
2772 NOT_REACHED; /*NOTREACHED*/
2773 }
2774
2775 SSize_t
2776 PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
2777 {
2778 int fd;
2779 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
2780 return -1;
2781 fd = PerlIOSelf(f, PerlIOUnix)->fd;
2782 #ifdef PERLIO_STD_SPECIAL
2783 if (fd == 1 || fd == 2)
2784 return PERLIO_STD_OUT(fd, vbuf, count);
2785 #endif
2786 while (1) {
2787 const SSize_t len = PerlLIO_write(fd, vbuf, count);
2788 if (len >= 0 || errno != EINTR) {
2789 if (len < 0) {
2790 if (errno != EAGAIN) {
2791 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
2792 PerlIO_save_errno(f);
2793 }
2794 }
2795 return len;
2796 }
2797 /* EINTR */
2798 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2799 return -1;
2800 }
2801 NOT_REACHED; /*NOTREACHED*/
2802 }
2803
2804 Off_t
2805 PerlIOUnix_tell(pTHX_ PerlIO *f)
2806 {
2807 PERL_UNUSED_CONTEXT;
2808
2809 return PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, 0, SEEK_CUR);
2810 }
2811
2812
2813 IV
2814 PerlIOUnix_close(pTHX_ PerlIO *f)
2815 {
2816 const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
2817 int code = 0;
2818 if (PerlIOBase(f)->flags & PERLIO_F_OPEN) {
2819 if (PerlIOUnix_refcnt_dec(fd) > 0) {
2820 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2821 return 0;
2822 }
2823 }
2824 else {
2825 SETERRNO(EBADF,SS_IVCHAN);
2826 return -1;
2827 }
2828 while (PerlLIO_close(fd) != 0) {
2829 if (errno != EINTR) {
2830 code = -1;
2831 break;
2832 }
2833 /* EINTR */
2834 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
2835 return -1;
2836 }
2837 if (code == 0) {
2838 PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
2839 }
2840 return code;
2841 }
2842
2843 PERLIO_FUNCS_DECL(PerlIO_unix) = {
2844 sizeof(PerlIO_funcs),
2845 "unix",
2846 sizeof(PerlIOUnix),
2847 PERLIO_K_RAW,
2848 PerlIOUnix_pushed,
2849 PerlIOBase_popped,
2850 PerlIOUnix_open,
2851 PerlIOBase_binmode, /* binmode */
2852 NULL,
2853 PerlIOUnix_fileno,
2854 PerlIOUnix_dup,
2855 PerlIOUnix_read,
2856 PerlIOBase_unread,
2857 PerlIOUnix_write,
2858 PerlIOUnix_seek,
2859 PerlIOUnix_tell,
2860 PerlIOUnix_close,
2861 PerlIOBase_noop_ok, /* flush */
2862 PerlIOBase_noop_fail, /* fill */
2863 PerlIOBase_eof,
2864 PerlIOBase_error,
2865 PerlIOBase_clearerr,
2866 PerlIOBase_setlinebuf,
2867 NULL, /* get_base */
2868 NULL, /* get_bufsiz */
2869 NULL, /* get_ptr */
2870 NULL, /* get_cnt */
2871 NULL, /* set_ptrcnt */
2872 };
2873
2874 /*--------------------------------------------------------------------------------------*/
2875 /*
2876 * stdio as a layer
2877 */
2878
2879 #if defined(VMS) && !defined(STDIO_BUFFER_WRITABLE)
2880 /* perl5.8 - This ensures the last minute VMS ungetc fix is not
2881 broken by the last second glibc 2.3 fix
2882 */
2883 #define STDIO_BUFFER_WRITABLE
2884 #endif
2885
2886
2887 typedef struct {
2888 struct _PerlIO base;
2889 FILE *stdio; /* The stream */
2890 } PerlIOStdio;
2891
2892 IV
2893 PerlIOStdio_fileno(pTHX_ PerlIO *f)
2894 {
2895 PERL_UNUSED_CONTEXT;
2896
2897 if (PerlIOValid(f)) {
2898 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
2899 if (s)
2900 return PerlSIO_fileno(s);
2901 }
2902 errno = EBADF;
2903 return -1;
2904 }
2905
2906 char *
2907 PerlIOStdio_mode(const char *mode, char *tmode)
2908 {
2909 char * const ret = tmode;
2910 if (mode) {
2911 while (*mode) {
2912 *tmode++ = *mode++;
2913 }
2914 }
2915 #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__)
2916 *tmode++ = 'b';
2917 #endif
2918 *tmode = '\0';
2919 return ret;
2920 }
2921
2922 IV
2923 PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
2924 {
2925 PerlIO *n;
2926 if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) {
2927 PerlIO_funcs * const toptab = PerlIOBase(n)->tab;
2928 if (toptab == tab) {
2929 /* Top is already stdio - pop self (duplicate) and use original */
2930 PerlIO_pop(aTHX_ f);
2931 return 0;
2932 } else {
2933 const int fd = PerlIO_fileno(n);
2934 char tmode[8];
2935 FILE *stdio;
2936 if (fd >= 0 && (stdio = PerlSIO_fdopen(fd,
2937 mode = PerlIOStdio_mode(mode, tmode)))) {
2938 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
2939 /* We never call down so do any pending stuff now */
2940 PerlIO_flush(PerlIONext(f));
2941 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2942 }
2943 else {
2944 return -1;
2945 }
2946 }
2947 }
2948 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
2949 }
2950
2951
2952 PerlIO *
2953 PerlIO_importFILE(FILE *stdio, const char *mode)
2954 {
2955 dTHX;
2956 PerlIO *f = NULL;
2957 #ifdef EBCDIC
2958 int rc;
2959 char filename[FILENAME_MAX];
2960 fldata_t fileinfo;
2961 #endif
2962 if (stdio) {
2963 PerlIOStdio *s;
2964 int fd0 = fileno(stdio);
2965 if (fd0 < 0) {
2966 #ifdef EBCDIC
2967 rc = fldata(stdio,filename,&fileinfo);
2968 if(rc != 0){
2969 return NULL;
2970 }
2971 if(fileinfo.__dsorgHFS){
2972 return NULL;
2973 }
2974 /*This MVS dataset , OK!*/
2975 #else
2976 return NULL;
2977 #endif
2978 }
2979 if (!mode || !*mode) {
2980 /* We need to probe to see how we can open the stream
2981 so start with read/write and then try write and read
2982 we dup() so that we can fclose without loosing the fd.
2983
2984 Note that the errno value set by a failing fdopen
2985 varies between stdio implementations.
2986 */
2987 const int fd = PerlLIO_dup_cloexec(fd0);
2988 FILE *f2;
2989 if (fd < 0) {
2990 return f;
2991 }
2992 f2 = PerlSIO_fdopen(fd, (mode = "r+"));
2993 if (!f2) {
2994 f2 = PerlSIO_fdopen(fd, (mode = "w"));
2995 }
2996 if (!f2) {
2997 f2 = PerlSIO_fdopen(fd, (mode = "r"));
2998 }
2999 if (!f2) {
3000 /* Don't seem to be able to open */
3001 PerlLIO_close(fd);
3002 return f;
3003 }
3004 fclose(f2);
3005 }
3006 if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) {
3007 s = PerlIOSelf(f, PerlIOStdio);
3008 s->stdio = stdio;
3009 fd0 = fileno(stdio);
3010 if(fd0 != -1){
3011 PerlIOUnix_refcnt_inc(fd0);
3012 setfd_cloexec_or_inhexec_by_sysfdness(fd0);
3013 }
3014 #ifdef EBCDIC
3015 else{
3016 rc = fldata(stdio,filename,&fileinfo);
3017 if(rc != 0){
3018 PerlIOUnix_refcnt_inc(fd0);
3019 }
3020 if(fileinfo.__dsorgHFS){
3021 PerlIOUnix_refcnt_inc(fd0);
3022 }
3023 /*This MVS dataset , OK!*/
3024 }
3025 #endif
3026 }
3027 }
3028 return f;
3029 }
3030
3031 PerlIO *
3032 PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3033 IV n, const char *mode, int fd, int imode,
3034 int perm, PerlIO *f, int narg, SV **args)
3035 {
3036 char tmode[8];
3037 if (PerlIOValid(f)) {
3038 STRLEN len;
3039 const char * const path = SvPV_const(*args, len);
3040 PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
3041 FILE *stdio;
3042 if (!IS_SAFE_PATHNAME(path, len, "open"))
3043 return NULL;
3044 PerlIOUnix_refcnt_dec(fileno(s->stdio));
3045 stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode),
3046 s->stdio);
3047 if (!s->stdio)
3048 return NULL;
3049 s->stdio = stdio;
3050 fd = fileno(stdio);
3051 PerlIOUnix_refcnt_inc(fd);
3052 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3053 return f;
3054 }
3055 else {
3056 if (narg > 0) {
3057 STRLEN len;
3058 const char * const path = SvPV_const(*args, len);
3059 if (!IS_SAFE_PATHNAME(path, len, "open"))
3060 return NULL;
3061 if (*mode == IoTYPE_NUMERIC) {
3062 mode++;
3063 fd = PerlLIO_open3_cloexec(path, imode, perm);
3064 }
3065 else {
3066 FILE *stdio;
3067 bool appended = FALSE;
3068 #ifdef __CYGWIN__
3069 /* Cygwin wants its 'b' early. */
3070 appended = TRUE;
3071 mode = PerlIOStdio_mode(mode, tmode);
3072 #endif
3073 stdio = PerlSIO_fopen(path, mode);
3074 if (stdio) {
3075 if (!f) {
3076 f = PerlIO_allocate(aTHX);
3077 }
3078 if (!appended)
3079 mode = PerlIOStdio_mode(mode, tmode);
3080 f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg);
3081 if (f) {
3082 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3083 fd = fileno(stdio);
3084 PerlIOUnix_refcnt_inc(fd);
3085 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3086 } else {
3087 PerlSIO_fclose(stdio);
3088 }
3089 return f;
3090 }
3091 else {
3092 return NULL;
3093 }
3094 }
3095 }
3096 if (fd >= 0) {
3097 FILE *stdio = NULL;
3098 int init = 0;
3099 if (*mode == IoTYPE_IMPLICIT) {
3100 init = 1;
3101 mode++;
3102 }
3103 if (init) {
3104 switch (fd) {
3105 case 0:
3106 stdio = PerlSIO_stdin;
3107 break;
3108 case 1:
3109 stdio = PerlSIO_stdout;
3110 break;
3111 case 2:
3112 stdio = PerlSIO_stderr;
3113 break;
3114 }
3115 }
3116 else {
3117 stdio = PerlSIO_fdopen(fd, mode =
3118 PerlIOStdio_mode(mode, tmode));
3119 }
3120 if (stdio) {
3121 if (!f) {
3122 f = PerlIO_allocate(aTHX);
3123 }
3124 if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) {
3125 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3126 fd = fileno(stdio);
3127 PerlIOUnix_refcnt_inc(fd);
3128 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3129 }
3130 return f;
3131 }
3132 PerlLIO_close(fd);
3133 }
3134 }
3135 return NULL;
3136 }
3137
3138 PerlIO *
3139 PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
3140 {
3141 /* This assumes no layers underneath - which is what
3142 happens, but is not how I remember it. NI-S 2001/10/16
3143 */
3144 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
3145 FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio;
3146 const int fd = fileno(stdio);
3147 char mode[8];
3148 if (flags & PERLIO_DUP_FD) {
3149 const int dfd = PerlLIO_dup_cloexec(fileno(stdio));
3150 if (dfd >= 0) {
3151 stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode));
3152 goto set_this;
3153 }
3154 else {
3155 NOOP;
3156 /* FIXME: To avoid messy error recovery if dup fails
3157 re-use the existing stdio as though flag was not set
3158 */
3159 }
3160 }
3161 stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode));
3162 set_this:
3163 PerlIOSelf(f, PerlIOStdio)->stdio = stdio;
3164 if(stdio) {
3165 int fd = fileno(stdio);
3166 PerlIOUnix_refcnt_inc(fd);
3167 setfd_cloexec_or_inhexec_by_sysfdness(fd);
3168 }
3169 }
3170 return f;
3171 }
3172
3173 static int
3174 PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
3175 {
3176 PERL_UNUSED_CONTEXT;
3177
3178 /* XXX this could use PerlIO_canset_fileno() and
3179 * PerlIO_set_fileno() support from Configure
3180 */
3181 # if defined(HAS_FDCLOSE)
3182 return fdclose(f, NULL) == 0 ? 1 : 0;
3183 # elif defined(__UCLIBC__)
3184 /* uClibc must come before glibc because it defines __GLIBC__ as well. */
3185 f->__filedes = -1;
3186 return 1;
3187 # elif defined(__GLIBC__)
3188 /* There may be a better way for GLIBC:
3189 - libio.h defines a flag to not close() on cleanup
3190 */
3191 f->_fileno = -1;
3192 return 1;
3193 # elif defined(__sun)
3194 PERL_UNUSED_ARG(f);
3195 return 0;
3196 # elif defined(__hpux)
3197 f->__fileH = 0xff;
3198 f->__fileL = 0xff;
3199 return 1;
3200 /* Next one ->_file seems to be a reasonable fallback, i.e. if
3201 your platform does not have special entry try this one.
3202 [For OSF only have confirmation for Tru64 (alpha)
3203 but assume other OSFs will be similar.]
3204 */
3205 # elif defined(_AIX) || defined(__osf__) || defined(__irix__)
3206 f->_file = -1;
3207 return 1;
3208 # elif defined(__FreeBSD__)
3209 /* There may be a better way on FreeBSD:
3210 - we could insert a dummy func in the _close function entry
3211 f->_close = (int (*)(void *)) dummy_close;
3212 */
3213 f->_file = -1;
3214 return 1;
3215 # elif defined(__OpenBSD__)
3216 /* There may be a better way on OpenBSD:
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(__EMX__)
3223 /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */
3224 f->_handle = -1;
3225 return 1;
3226 # elif defined(__CYGWIN__)
3227 /* There may be a better way on CYGWIN:
3228 - we could insert a dummy func in the _close function entry
3229 f->_close = (int (*)(void *)) dummy_close;
3230 */
3231 f->_file = -1;
3232 return 1;
3233 # elif defined(WIN32)
3234 # if defined(UNDER_CE)
3235 /* WIN_CE does not have access to FILE internals, it hardly has FILE
3236 structure at all
3237 */
3238 # else
3239 PERLIO_FILE_file(f) = -1;
3240 # endif
3241 return 1;
3242 # else
3243 #if 0
3244 /* Sarathy's code did this - we fall back to a dup/dup2 hack
3245 (which isn't thread safe) instead
3246 */
3247 # error "Don't know how to set FILE.fileno on your platform"
3248 #endif
3249 PERL_UNUSED_ARG(f);
3250 return 0;
3251 # endif
3252 }
3253
3254 IV
3255 PerlIOStdio_close(pTHX_ PerlIO *f)
3256 {
3257 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3258 if (!stdio) {
3259 errno = EBADF;
3260 return -1;
3261 }
3262 else {
3263 const int fd = fileno(stdio);
3264 int invalidate = 0;
3265 IV result = 0;
3266 int dupfd = -1;
3267 dSAVEDERRNO;
3268 #ifdef USE_ITHREADS
3269 dVAR;
3270 #endif
3271 #ifdef SOCKS5_VERSION_NAME
3272 /* Socks lib overrides close() but stdio isn't linked to
3273 that library (though we are) - so we must call close()
3274 on sockets on stdio's behalf.
3275 */
3276 int optval;
3277 Sock_size_t optlen = sizeof(int);
3278 if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0)
3279 invalidate = 1;
3280 #endif
3281 /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such
3282 that a subsequent fileno() on it returns -1. Don't want to croak()
3283 from within PerlIOUnix_refcnt_dec() if some buggy caller code is
3284 trying to close an already closed handle which somehow it still has
3285 a reference to. (via.xs, I'm looking at you). */
3286 if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) {
3287 /* File descriptor still in use */
3288 invalidate = 1;
3289 }
3290 if (invalidate) {
3291 /* For STD* handles, don't close stdio, since we shared the FILE *, too. */
3292 if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */
3293 return 0;
3294 if (stdio == stdout || stdio == stderr)
3295 return PerlIO_flush(f);
3296 }
3297 MUTEX_LOCK(&PL_perlio_mutex);
3298 /* Right. We need a mutex here because for a brief while we
3299 will have the situation that fd is actually closed. Hence if
3300 a second thread were to get into this block, its dup() would
3301 likely return our fd as its dupfd. (after all, it is closed)
3302 Then if we get to the dup2() first, we blat the fd back
3303 (messing up its temporary as a side effect) only for it to
3304 then close its dupfd (== our fd) in its close(dupfd) */
3305
3306 /* There is, of course, a race condition, that any other thread
3307 trying to input/output/whatever on this fd will be stuffed
3308 for the duration of this little manoeuvrer. Perhaps we
3309 should hold an IO mutex for the duration of every IO
3310 operation if we know that invalidate doesn't work on this
3311 platform, but that would suck, and could kill performance.
3312
3313 Except that correctness trumps speed.
3314 Advice from klortho #11912. */
3315 if (invalidate) {
3316 /* Tricky - must fclose(stdio) to free memory but not close(fd)
3317 Use Sarathy's trick from maint-5.6 to invalidate the
3318 fileno slot of the FILE *
3319 */
3320 result = PerlIO_flush(f);
3321 SAVE_ERRNO;
3322 invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio);
3323 if (!invalidate) {
3324 dupfd = PerlLIO_dup_cloexec(fd);
3325 #ifdef USE_ITHREADS
3326 if (dupfd < 0) {
3327 /* Oh cXap. This isn't going to go well. Not sure if we can
3328 recover from here, or if closing this particular FILE *
3329 is a good idea now. */
3330 }
3331 #endif
3332 }
3333 } else {
3334 SAVE_ERRNO; /* This is here only to silence compiler warnings */
3335 }
3336 result = PerlSIO_fclose(stdio);
3337 /* We treat error from stdio as success if we invalidated
3338 errno may NOT be expected EBADF
3339 */
3340 if (invalidate && result != 0) {
3341 RESTORE_ERRNO;
3342 result = 0;
3343 }
3344 #ifdef SOCKS5_VERSION_NAME
3345 /* in SOCKS' case, let close() determine return value */
3346 result = close(fd);
3347 #endif
3348 if (dupfd >= 0) {
3349 PerlLIO_dup2_cloexec(dupfd, fd);
3350 setfd_inhexec_for_sysfd(fd);
3351 PerlLIO_close(dupfd);
3352 }
3353 MUTEX_UNLOCK(&PL_perlio_mutex);
3354 return result;
3355 }
3356 }
3357
3358 SSize_t
3359 PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
3360 {
3361 FILE * s;
3362 SSize_t got = 0;
3363 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3364 return -1;
3365 s = PerlIOSelf(f, PerlIOStdio)->stdio;
3366 for (;;) {
3367 if (count == 1) {
3368 STDCHAR *buf = (STDCHAR *) vbuf;
3369 /*
3370 * Perl is expecting PerlIO_getc() to fill the buffer Linux's
3371 * stdio does not do that for fread()
3372 */
3373 const int ch = PerlSIO_fgetc(s);
3374 if (ch != EOF) {
3375 *buf = ch;
3376 got = 1;
3377 }
3378 }
3379 else
3380 got = PerlSIO_fread(vbuf, 1, count, s);
3381 if (got == 0 && PerlSIO_ferror(s))
3382 got = -1;
3383 if (got >= 0 || errno != EINTR)
3384 break;
3385 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3386 return -1;
3387 SETERRNO(0,0); /* just in case */
3388 }
3389 #ifdef __sgi
3390 /* Under some circumstances IRIX stdio fgetc() and fread()
3391 * set the errno to ENOENT, which makes no sense according
3392 * to either IRIX or POSIX. [rt.perl.org #123977] */
3393 if (errno == ENOENT) SETERRNO(0,0);
3394 #endif
3395 return got;
3396 }
3397
3398 SSize_t
3399 PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3400 {
3401 SSize_t unread = 0;
3402 FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
3403
3404 #ifdef STDIO_BUFFER_WRITABLE
3405 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3406 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3407 STDCHAR *base = PerlIO_get_base(f);
3408 SSize_t cnt = PerlIO_get_cnt(f);
3409 STDCHAR *ptr = PerlIO_get_ptr(f);
3410 SSize_t avail = ptr - base;
3411 if (avail > 0) {
3412 if (avail > count) {
3413 avail = count;
3414 }
3415 ptr -= avail;
3416 Move(buf-avail,ptr,avail,STDCHAR);
3417 count -= avail;
3418 unread += avail;
3419 PerlIO_set_ptrcnt(f,ptr,cnt+avail);
3420 if (PerlSIO_feof(s) && unread >= 0)
3421 PerlSIO_clearerr(s);
3422 }
3423 }
3424 else
3425 #endif
3426 if (PerlIO_has_cntptr(f)) {
3427 /* We can get pointer to buffer but not its base
3428 Do ungetc() but check chars are ending up in the
3429 buffer
3430 */
3431 STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s);
3432 STDCHAR *buf = ((STDCHAR *) vbuf) + count;
3433 while (count > 0) {
3434 const int ch = *--buf & 0xFF;
3435 if (ungetc(ch,s) != ch) {
3436 /* ungetc did not work */
3437 break;
3438 }
3439 if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
3440 /* Did not change pointer as expected */
3441 if (fgetc(s) != EOF) /* get char back again */
3442 break;
3443 }
3444 /* It worked ! */
3445 count--;
3446 unread++;
3447 }
3448 }
3449
3450 if (count > 0) {
3451 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
3452 }
3453 return unread;
3454 }
3455
3456 SSize_t
3457 PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
3458 {
3459 SSize_t got;
3460 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3461 return -1;
3462 for (;;) {
3463 got = PerlSIO_fwrite(vbuf, 1, count,
3464 PerlIOSelf(f, PerlIOStdio)->stdio);
3465 if (got >= 0 || errno != EINTR)
3466 break;
3467 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3468 return -1;
3469 SETERRNO(0,0); /* just in case */
3470 }
3471 return got;
3472 }
3473
3474 IV
3475 PerlIOStdio_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
3476 {
3477 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3478 PERL_UNUSED_CONTEXT;
3479
3480 return PerlSIO_fseek(stdio, offset, whence);
3481 }
3482
3483 Off_t
3484 PerlIOStdio_tell(pTHX_ PerlIO *f)
3485 {
3486 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3487 PERL_UNUSED_CONTEXT;
3488
3489 return PerlSIO_ftell(stdio);
3490 }
3491
3492 IV
3493 PerlIOStdio_flush(pTHX_ PerlIO *f)
3494 {
3495 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3496 PERL_UNUSED_CONTEXT;
3497
3498 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3499 return PerlSIO_fflush(stdio);
3500 }
3501 else {
3502 NOOP;
3503 #if 0
3504 /*
3505 * FIXME: This discards ungetc() and pre-read stuff which is not
3506 * right if this is just a "sync" from a layer above Suspect right
3507 * design is to do _this_ but not have layer above flush this
3508 * layer read-to-read
3509 */
3510 /*
3511 * Not writeable - sync by attempting a seek
3512 */
3513 dSAVE_ERRNO;
3514 if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0)
3515 RESTORE_ERRNO;
3516 #endif
3517 }
3518 return 0;
3519 }
3520
3521 IV
3522 PerlIOStdio_eof(pTHX_ PerlIO *f)
3523 {
3524 PERL_UNUSED_CONTEXT;
3525
3526 return PerlSIO_feof(PerlIOSelf(f, PerlIOStdio)->stdio);
3527 }
3528
3529 IV
3530 PerlIOStdio_error(pTHX_ PerlIO *f)
3531 {
3532 PERL_UNUSED_CONTEXT;
3533
3534 return PerlSIO_ferror(PerlIOSelf(f, PerlIOStdio)->stdio);
3535 }
3536
3537 void
3538 PerlIOStdio_clearerr(pTHX_ PerlIO *f)
3539 {
3540 PERL_UNUSED_CONTEXT;
3541
3542 PerlSIO_clearerr(PerlIOSelf(f, PerlIOStdio)->stdio);
3543 }
3544
3545 void
3546 PerlIOStdio_setlinebuf(pTHX_ PerlIO *f)
3547 {
3548 PERL_UNUSED_CONTEXT;
3549
3550 #ifdef HAS_SETLINEBUF
3551 PerlSIO_setlinebuf(PerlIOSelf(f, PerlIOStdio)->stdio);
3552 #else
3553 PerlSIO_setvbuf(PerlIOSelf(f, PerlIOStdio)->stdio, NULL, _IOLBF, 0);
3554 #endif
3555 }
3556
3557 #ifdef FILE_base
3558 STDCHAR *
3559 PerlIOStdio_get_base(pTHX_ PerlIO *f)
3560 {
3561 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3562 PERL_UNUSED_CONTEXT;
3563 return (STDCHAR*)PerlSIO_get_base(stdio);
3564 }
3565
3566 Size_t
3567 PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f)
3568 {
3569 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3570 PERL_UNUSED_CONTEXT;
3571 return PerlSIO_get_bufsiz(stdio);
3572 }
3573 #endif
3574
3575 #ifdef USE_STDIO_PTR
3576 STDCHAR *
3577 PerlIOStdio_get_ptr(pTHX_ PerlIO *f)
3578 {
3579 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3580 PERL_UNUSED_CONTEXT;
3581 return (STDCHAR*)PerlSIO_get_ptr(stdio);
3582 }
3583
3584 SSize_t
3585 PerlIOStdio_get_cnt(pTHX_ PerlIO *f)
3586 {
3587 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3588 PERL_UNUSED_CONTEXT;
3589 return PerlSIO_get_cnt(stdio);
3590 }
3591
3592 void
3593 PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
3594 {
3595 FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3596 PERL_UNUSED_CONTEXT;
3597 if (ptr != NULL) {
3598 #ifdef STDIO_PTR_LVALUE
3599 /* This is a long-standing infamous mess. The root of the
3600 * problem is that one cannot know the signedness of char, and
3601 * more precisely the signedness of FILE._ptr. The following
3602 * things have been tried, and they have all failed (across
3603 * different compilers (remember that core needs to to build
3604 * also with c++) and compiler options:
3605 *
3606 * - casting the RHS to (void*) -- works in *some* places
3607 * - casting the LHS to (void*) -- totally unportable
3608 *
3609 * So let's try silencing the warning at least for gcc. */
3610 GCC_DIAG_IGNORE_STMT(-Wpointer-sign);
3611 PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */
3612 GCC_DIAG_RESTORE_STMT;
3613 #ifdef STDIO_PTR_LVAL_SETS_CNT
3614 assert(PerlSIO_get_cnt(stdio) == (cnt));
3615 #endif
3616 #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT))
3617 /*
3618 * Setting ptr _does_ change cnt - we are done
3619 */
3620 return;
3621 #endif
3622 #else /* STDIO_PTR_LVALUE */
3623 PerlProc_abort();
3624 #endif /* STDIO_PTR_LVALUE */
3625 }
3626 /*
3627 * Now (or only) set cnt
3628 */
3629 #ifdef STDIO_CNT_LVALUE
3630 PerlSIO_set_cnt(stdio, cnt);
3631 #elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT))
3632 PerlSIO_set_ptr(stdio,
3633 PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) -
3634 cnt));
3635 #else /* STDIO_PTR_LVAL_SETS_CNT */
3636 PerlProc_abort();
3637 #endif /* STDIO_CNT_LVALUE */
3638 }
3639
3640
3641 #endif
3642
3643 IV
3644 PerlIOStdio_fill(pTHX_ PerlIO *f)
3645 {
3646 FILE * stdio;
3647 int c;
3648 PERL_UNUSED_CONTEXT;
3649 if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
3650 return -1;
3651 stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
3652
3653 /*
3654 * fflush()ing read-only streams can cause trouble on some stdio-s
3655 */
3656 if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
3657 if (PerlSIO_fflush(stdio) != 0)
3658 return EOF;
3659 }
3660 for (;;) {
3661 c = PerlSIO_fgetc(stdio);
3662 if (c != EOF)
3663 break;
3664 if (! PerlSIO_ferror(stdio) || errno != EINTR)
3665 return EOF;
3666 if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
3667 return -1;
3668 SETERRNO(0,0);
3669 }
3670
3671 #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT)))
3672
3673 #ifdef STDIO_BUFFER_WRITABLE
3674 if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) {
3675 /* Fake ungetc() to the real buffer in case system's ungetc
3676 goes elsewhere
3677 */
3678 STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio);
3679 SSize_t cnt = PerlSIO_get_cnt(stdio);
3680 STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio);
3681 if (ptr == base+1) {
3682 *--ptr = (STDCHAR) c;
3683 PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1);
3684 if (PerlSIO_feof(stdio))
3685 PerlSIO_clearerr(stdio);
3686 return 0;
3687 }
3688 }
3689 else
3690 #endif
3691 if (PerlIO_has_cntptr(f)) {
3692 STDCHAR ch = c;
3693 if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) {
3694 return 0;
3695 }
3696 }
3697 #endif
3698
3699 /* If buffer snoop scheme above fails fall back to
3700 using ungetc().
3701 */
3702 if (PerlSIO_ungetc(c, stdio) != c)
3703 return EOF;
3704
3705 return 0;
3706 }
3707
3708
3709
3710 PERLIO_FUNCS_DECL(PerlIO_stdio) = {
3711 sizeof(PerlIO_funcs),
3712 "stdio",
3713 sizeof(PerlIOStdio),
3714 PERLIO_K_BUFFERED|PERLIO_K_RAW,
3715 PerlIOStdio_pushed,
3716 PerlIOBase_popped,
3717 PerlIOStdio_open,
3718 PerlIOBase_binmode, /* binmode */
3719 NULL,
3720 PerlIOStdio_fileno,
3721 PerlIOStdio_dup,
3722 PerlIOStdio_read,
3723 PerlIOStdio_unread,
3724 PerlIOStdio_write,
3725 PerlIOStdio_seek,
3726 PerlIOStdio_tell,
3727 PerlIOStdio_close,
3728 PerlIOStdio_flush,
3729 PerlIOStdio_fill,
3730 PerlIOStdio_eof,
3731 PerlIOStdio_error,
3732 PerlIOStdio_clearerr,
3733 PerlIOStdio_setlinebuf,
3734 #ifdef FILE_base
3735 PerlIOStdio_get_base,
3736 PerlIOStdio_get_bufsiz,
3737 #else
3738 NULL,
3739 NULL,
3740 #endif
3741 #ifdef USE_STDIO_PTR
3742 PerlIOStdio_get_ptr,
3743 PerlIOStdio_get_cnt,
3744 # if defined(HAS_FAST_STDIO) && defined(USE_FAST_STDIO)
3745 PerlIOStdio_set_ptrcnt,
3746 # else
3747 NULL,
3748 # endif /* HAS_FAST_STDIO && USE_FAST_STDIO */
3749 #else
3750 NULL,
3751 NULL,
3752 NULL,
3753 #endif /* USE_STDIO_PTR */
3754 };
3755
3756 /* Note that calls to PerlIO_exportFILE() are reversed using
3757 * PerlIO_releaseFILE(), not importFILE. */
3758 FILE *
3759 PerlIO_exportFILE(PerlIO * f, const char *mode)
3760 {
3761 dTHX;
3762 FILE *stdio = NULL;
3763 if (PerlIOValid(f)) {
3764 char buf[8];
3765 int fd = PerlIO_fileno(f);
3766 if (fd < 0) {
3767 return NULL;
3768 }
3769 PerlIO_flush(f);
3770 if (!mode || !*mode) {
3771 mode = PerlIO_modestr(f, buf);
3772 }
3773 stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode);
3774 if (stdio) {
3775 PerlIOl *l = *f;
3776 PerlIO *f2;
3777 /* De-link any lower layers so new :stdio sticks */
3778 *f = NULL;
3779 if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) {
3780 PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio);
3781 s->stdio = stdio;
3782 PerlIOUnix_refcnt_inc(fileno(stdio));
3783 /* Link previous lower layers under new one */
3784 *PerlIONext(f) = l;
3785 }
3786 else {
3787 /* restore layers list */
3788 *f = l;
3789 }
3790 }
3791 }
3792 return stdio;
3793 }
3794
3795
3796 FILE *
3797 PerlIO_findFILE(PerlIO *f)
3798 {
3799 PerlIOl *l = *f;
3800 FILE *stdio;
3801 while (l) {
3802 if (l->tab == &PerlIO_stdio) {
3803 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3804 return s->stdio;
3805 }
3806 l = *PerlIONext(&l);
3807 }
3808 /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */
3809 /* However, we're not really exporting a FILE * to someone else (who
3810 becomes responsible for closing it, or calling PerlIO_releaseFILE())
3811 So we need to undo its reference count increase on the underlying file
3812 descriptor. We have to do this, because if the loop above returns you
3813 the FILE *, then *it* didn't increase any reference count. So there's
3814 only one way to be consistent. */
3815 stdio = PerlIO_exportFILE(f, NULL);
3816 if (stdio) {
3817 const int fd = fileno(stdio);
3818 if (fd >= 0)
3819 PerlIOUnix_refcnt_dec(fd);
3820 }
3821 return stdio;
3822 }
3823
3824 /* Use this to reverse PerlIO_exportFILE calls. */
3825 void
3826 PerlIO_releaseFILE(PerlIO *p, FILE *f)
3827 {
3828 PerlIOl *l;
3829 while ((l = *p)) {
3830 if (l->tab == &PerlIO_stdio) {
3831 PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio);
3832 if (s->stdio == f) { /* not in a loop */
3833 const int fd = fileno(f);
3834 if (fd >= 0)
3835 PerlIOUnix_refcnt_dec(fd);
3836 {
3837 dTHX;
3838 PerlIO_pop(aTHX_ p);
3839 }
3840 return;
3841 }
3842 }
3843 p = PerlIONext(p);
3844 }
3845 return;
3846 }
3847
3848 /*--------------------------------------------------------------------------------------*/
3849 /*
3850 * perlio buffer layer
3851 */
3852
3853 IV
3854 PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
3855 {
3856 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
3857 const int fd = PerlIO_fileno(f);
3858 if (fd >= 0 && PerlLIO_isatty(fd)) {
3859 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY;
3860 }
3861 if (*PerlIONext(f)) {
3862 const Off_t posn = PerlIO_tell(PerlIONext(f));
3863 if (posn != (Off_t) - 1) {
3864 b->posn = posn;
3865 }
3866 }
3867 return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
3868 }
3869
3870 PerlIO *
3871 PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
3872 IV n, const char *mode, int fd, int imode, int perm,
3873 PerlIO *f, int narg, SV **args)
3874 {
3875 if (PerlIOValid(f)) {
3876 PerlIO *next = PerlIONext(f);
3877 PerlIO_funcs *tab =
3878 PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
3879 if (tab && tab->Open)
3880 next =
3881 (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3882 next, narg, args);
3883 if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
3884 return NULL;
3885 }
3886 }
3887 else {
3888 PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm());
3889 int init = 0;
3890 if (*mode == IoTYPE_IMPLICIT) {
3891 init = 1;
3892 /*
3893 * mode++;
3894 */
3895 }
3896 if (tab && tab->Open)
3897 f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
3898 f, narg, args);
3899 else
3900 SETERRNO(EINVAL, LIB_INVARG);
3901 if (f) {
3902 if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) {
3903 /*
3904 * if push fails during open, open fails. close will pop us.
3905 */
3906 PerlIO_close (f);
3907 return NULL;
3908 } else {
3909 fd = PerlIO_fileno(f);
3910 if (init && fd == 2) {
3911 /*
3912 * Initial stderr is unbuffered
3913 */
3914 PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
3915 }
3916 #ifdef PERLIO_USING_CRLF
3917 # ifdef PERLIO_IS_BINMODE_FD
3918 if (PERLIO_IS_BINMODE_FD(fd))
3919 PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL);
3920 else
3921 # endif
3922 /*
3923 * do something about failing setmode()? --jhi
3924 */
3925 PerlLIO_setmode(fd, O_BINARY);
3926 #endif
3927 #ifdef VMS
3928 /* Enable line buffering with record-oriented regular files
3929 * so we don't introduce an extraneous record boundary when
3930 * the buffer fills up.
3931 */
3932 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
3933 Stat_t st;
3934 if (PerlLIO_fstat(fd, &st) == 0
3935 && S_ISREG(st.st_mode)
3936 && (st.st_fab_rfm == FAB$C_VAR
3937 || st.st_fab_rfm == FAB$C_VFC)) {
3938 PerlIOBase(f)->flags |= PERLIO_F_LINEBUF;
3939 }
3940 }
3941 #endif
3942 }
3943 }
3944 }
3945 return f;
3946 }
3947
3948 /*
3949 * This "flush" is akin to sfio's sync in that it handles files in either
3950 * read or write state. For write state, we put the postponed data through
3951 * the next layers. For read state, we seek() the next layers to the
3952 * offset given by current position in the buffer, and discard the buffer
3953 * state (XXXX supposed to be for seek()able buffers only, but now it is done
3954 * in any case?). Then the pass the stick further in chain.
3955 */
3956 IV
3957 PerlIOBuf_flush(pTHX_ PerlIO *f)
3958 {
3959 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
3960 int code = 0;
3961 PerlIO *n = PerlIONext(f);
3962 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) {
3963 /*
3964 * write() the buffer
3965 */
3966 const STDCHAR *buf = b->buf;
3967 const STDCHAR *p = buf;
3968 while (p < b->ptr) {
3969 SSize_t count = PerlIO_write(n, p, b->ptr - p);
3970 if (count > 0) {
3971 p += count;
3972 }
3973 else if (count < 0 || PerlIO_error(n)) {
3974 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
3975 PerlIO_save_errno(f);
3976 code = -1;
3977 break;
3978 }
3979 }
3980 b->posn += (p - buf);
3981 }
3982 else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
3983 STDCHAR *buf = PerlIO_get_base(f);
3984 /*
3985 * Note position change
3986 */
3987 b->posn += (b->ptr - buf);
3988 if (b->ptr < b->end) {
3989 /* We did not consume all of it - try and seek downstream to
3990 our logical position
3991 */
3992 if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) {
3993 /* Reload n as some layers may pop themselves on seek */
3994 b->posn = PerlIO_tell(n = PerlIONext(f));
3995 }
3996 else {
3997 /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read
3998 data is lost for good - so return saying "ok" having undone
3999 the position adjust
4000 */
4001 b->posn -= (b->ptr - buf);
4002 return code;
4003 }
4004 }
4005 }
4006 b->ptr = b->end = b->buf;
4007 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4008 /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */
4009 if (PerlIOValid(n) && PerlIO_flush(n) != 0)
4010 code = -1;
4011 return code;
4012 }
4013
4014 /* This discards the content of the buffer after b->ptr, and rereads
4015 * the buffer from the position off in the layer downstream; here off
4016 * is at offset corresponding to b->ptr - b->buf.
4017 */
4018 IV
4019 PerlIOBuf_fill(pTHX_ PerlIO *f)
4020 {
4021 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4022 PerlIO *n = PerlIONext(f);
4023 SSize_t avail;
4024 /*
4025 * Down-stream flush is defined not to loose read data so is harmless.
4026 * we would not normally be fill'ing if there was data left in anycase.
4027 */
4028 if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */
4029 return -1;
4030 if (PerlIOBase(f)->flags & PERLIO_F_TTY)
4031 PerlIOBase_flush_linebuf(aTHX);
4032
4033 if (!b->buf)
4034 PerlIO_get_base(f); /* allocate via vtable */
4035
4036 assert(b->buf); /* The b->buf does get allocated via the vtable system. */
4037
4038 b->ptr = b->end = b->buf;
4039
4040 if (!PerlIOValid(n)) {
4041 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4042 return -1;
4043 }
4044
4045 if (PerlIO_fast_gets(n)) {
4046 /*
4047 * Layer below is also buffered. We do _NOT_ want to call its
4048 * ->Read() because that will loop till it gets what we asked for
4049 * which may hang on a pipe etc. Instead take anything it has to
4050 * hand, or ask it to fill _once_.
4051 */
4052 avail = PerlIO_get_cnt(n);
4053 if (avail <= 0) {
4054 avail = PerlIO_fill(n);
4055 if (avail == 0)
4056 avail = PerlIO_get_cnt(n);
4057 else {
4058 if (!PerlIO_error(n) && PerlIO_eof(n))
4059 avail = 0;
4060 }
4061 }
4062 if (avail > 0) {
4063 STDCHAR *ptr = PerlIO_get_ptr(n);
4064 const SSize_t cnt = avail;
4065 if (avail > (SSize_t)b->bufsiz)
4066 avail = b->bufsiz;
4067 Copy(ptr, b->buf, avail, STDCHAR);
4068 PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail);
4069 }
4070 }
4071 else {
4072 avail = PerlIO_read(n, b->ptr, b->bufsiz);
4073 }
4074 if (avail <= 0) {
4075 if (avail == 0)
4076 PerlIOBase(f)->flags |= PERLIO_F_EOF;
4077 else
4078 {
4079 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
4080 PerlIO_save_errno(f);
4081 }
4082 return -1;
4083 }
4084 b->end = b->buf + avail;
4085 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4086 return 0;
4087 }
4088
4089 SSize_t
4090 PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4091 {
4092 if (PerlIOValid(f)) {
4093 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4094 if (!b->ptr)
4095 PerlIO_get_base(f);
4096 return PerlIOBase_read(aTHX_ f, vbuf, count);
4097 }
4098 return 0;
4099 }
4100
4101 SSize_t
4102 PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4103 {
4104 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4105 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4106 SSize_t unread = 0;
4107 SSize_t avail;
4108 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4109 PerlIO_flush(f);
4110 if (!b->buf)
4111 PerlIO_get_base(f);
4112 if (b->buf) {
4113 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4114 /*
4115 * Buffer is already a read buffer, we can overwrite any chars
4116 * which have been read back to buffer start
4117 */
4118 avail = (b->ptr - b->buf);
4119 }
4120 else {
4121 /*
4122 * Buffer is idle, set it up so whole buffer is available for
4123 * unread
4124 */
4125 avail = b->bufsiz;
4126 b->end = b->buf + avail;
4127 b->ptr = b->end;
4128 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4129 /*
4130 * Buffer extends _back_ from where we are now
4131 */
4132 b->posn -= b->bufsiz;
4133 }
4134 if ((SSize_t) count >= 0 && avail > (SSize_t) count) {
4135 /*
4136 * If we have space for more than count, just move count
4137 */
4138 avail = count;
4139 }
4140 if (avail > 0) {
4141 b->ptr -= avail;
4142 buf -= avail;
4143 /*
4144 * In simple stdio-like ungetc() case chars will be already
4145 * there
4146 */
4147 if (buf != b->ptr) {
4148 Copy(buf, b->ptr, avail, STDCHAR);
4149 }
4150 count -= avail;
4151 unread += avail;
4152 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4153 }
4154 }
4155 if (count > 0) {
4156 unread += PerlIOBase_unread(aTHX_ f, vbuf, count);
4157 }
4158 return unread;
4159 }
4160
4161 SSize_t
4162 PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4163 {
4164 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4165 const STDCHAR *buf = (const STDCHAR *) vbuf;
4166 const STDCHAR *flushptr = buf;
4167 Size_t written = 0;
4168 if (!b->buf)
4169 PerlIO_get_base(f);
4170 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4171 return 0;
4172 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4173 if (PerlIO_flush(f) != 0) {
4174 return 0;
4175 }
4176 }
4177 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4178 flushptr = buf + count;
4179 while (flushptr > buf && *(flushptr - 1) != '\n')
4180 --flushptr;
4181 }
4182 while (count > 0) {
4183 SSize_t avail = b->bufsiz - (b->ptr - b->buf);
4184 if ((SSize_t) count >= 0 && (SSize_t) count < avail)
4185 avail = count;
4186 if (flushptr > buf && flushptr <= buf + avail)
4187 avail = flushptr - buf;
4188 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4189 if (avail) {
4190 Copy(buf, b->ptr, avail, STDCHAR);
4191 count -= avail;
4192 buf += avail;
4193 written += avail;
4194 b->ptr += avail;
4195 if (buf == flushptr)
4196 PerlIO_flush(f);
4197 }
4198 if (b->ptr >= (b->buf + b->bufsiz))
4199 if (PerlIO_flush(f) == -1)
4200 return -1;
4201 }
4202 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4203 PerlIO_flush(f);
4204 return written;
4205 }
4206
4207 IV
4208 PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4209 {
4210 IV code;
4211 if ((code = PerlIO_flush(f)) == 0) {
4212 PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
4213 code = PerlIO_seek(PerlIONext(f), offset, whence);
4214 if (code == 0) {
4215 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4216 b->posn = PerlIO_tell(PerlIONext(f));
4217 }
4218 }
4219 return code;
4220 }
4221
4222 Off_t
4223 PerlIOBuf_tell(pTHX_ PerlIO *f)
4224 {
4225 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4226 /*
4227 * b->posn is file position where b->buf was read, or will be written
4228 */
4229 Off_t posn = b->posn;
4230 if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) &&
4231 (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
4232 #if 1
4233 /* As O_APPEND files are normally shared in some sense it is better
4234 to flush :
4235 */
4236 PerlIO_flush(f);
4237 #else
4238 /* when file is NOT shared then this is sufficient */
4239 PerlIO_seek(PerlIONext(f),0, SEEK_END);
4240 #endif
4241 posn = b->posn = PerlIO_tell(PerlIONext(f));
4242 }
4243 if (b->buf) {
4244 /*
4245 * If buffer is valid adjust position by amount in buffer
4246 */
4247 posn += (b->ptr - b->buf);
4248 }
4249 return posn;
4250 }
4251
4252 IV
4253 PerlIOBuf_popped(pTHX_ PerlIO *f)
4254 {
4255 const IV code = PerlIOBase_popped(aTHX_ f);
4256 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4257 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4258 Safefree(b->buf);
4259 }
4260 b->ptr = b->end = b->buf = NULL;
4261 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4262 return code;
4263 }
4264
4265 IV
4266 PerlIOBuf_close(pTHX_ PerlIO *f)
4267 {
4268 const IV code = PerlIOBase_close(aTHX_ f);
4269 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4270 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4271 Safefree(b->buf);
4272 }
4273 b->ptr = b->end = b->buf = NULL;
4274 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
4275 return code;
4276 }
4277
4278 STDCHAR *
4279 PerlIOBuf_get_ptr(pTHX_ PerlIO *f)
4280 {
4281 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4282 if (!b->buf)
4283 PerlIO_get_base(f);
4284 return b->ptr;
4285 }
4286
4287 SSize_t
4288 PerlIOBuf_get_cnt(pTHX_ PerlIO *f)
4289 {
4290 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4291 if (!b->buf)
4292 PerlIO_get_base(f);
4293 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
4294 return (b->end - b->ptr);
4295 return 0;
4296 }
4297
4298 STDCHAR *
4299 PerlIOBuf_get_base(pTHX_ PerlIO *f)
4300 {
4301 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4302 PERL_UNUSED_CONTEXT;
4303
4304 if (!b->buf) {
4305 if (!b->bufsiz)
4306 b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ;
4307 Newx(b->buf,b->bufsiz, STDCHAR);
4308 if (!b->buf) {
4309 b->buf = (STDCHAR *) & b->oneword;
4310 b->bufsiz = sizeof(b->oneword);
4311 }
4312 b->end = b->ptr = b->buf;
4313 }
4314 return b->buf;
4315 }
4316
4317 Size_t
4318 PerlIOBuf_bufsiz(pTHX_ PerlIO *f)
4319 {
4320 const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4321 if (!b->buf)
4322 PerlIO_get_base(f);
4323 return (b->end - b->buf);
4324 }
4325
4326 void
4327 PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4328 {
4329 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4330 #ifndef DEBUGGING
4331 PERL_UNUSED_ARG(cnt);
4332 #endif
4333 if (!b->buf)
4334 PerlIO_get_base(f);
4335 b->ptr = ptr;
4336 assert(PerlIO_get_cnt(f) == cnt);
4337 assert(b->ptr >= b->buf);
4338 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4339 }
4340
4341 PerlIO *
4342 PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
4343 {
4344 return PerlIOBase_dup(aTHX_ f, o, param, flags);
4345 }
4346
4347
4348
4349 PERLIO_FUNCS_DECL(PerlIO_perlio) = {
4350 sizeof(PerlIO_funcs),
4351 "perlio",
4352 sizeof(PerlIOBuf),
4353 PERLIO_K_BUFFERED|PERLIO_K_RAW,
4354 PerlIOBuf_pushed,
4355 PerlIOBuf_popped,
4356 PerlIOBuf_open,
4357 PerlIOBase_binmode, /* binmode */
4358 NULL,
4359 PerlIOBase_fileno,
4360 PerlIOBuf_dup,
4361 PerlIOBuf_read,
4362 PerlIOBuf_unread,
4363 PerlIOBuf_write,
4364 PerlIOBuf_seek,
4365 PerlIOBuf_tell,
4366 PerlIOBuf_close,
4367 PerlIOBuf_flush,
4368 PerlIOBuf_fill,
4369 PerlIOBase_eof,
4370 PerlIOBase_error,
4371 PerlIOBase_clearerr,
4372 PerlIOBase_setlinebuf,
4373 PerlIOBuf_get_base,
4374 PerlIOBuf_bufsiz,
4375 PerlIOBuf_get_ptr,
4376 PerlIOBuf_get_cnt,
4377 PerlIOBuf_set_ptrcnt,
4378 };
4379
4380 /*--------------------------------------------------------------------------------------*/
4381 /*
4382 * Temp layer to hold unread chars when cannot do it any other way
4383 */
4384
4385 IV
4386 PerlIOPending_fill(pTHX_ PerlIO *f)
4387 {
4388 /*
4389 * Should never happen
4390 */
4391 PerlIO_flush(f);
4392 return 0;
4393 }
4394
4395 IV
4396 PerlIOPending_close(pTHX_ PerlIO *f)
4397 {
4398 /*
4399 * A tad tricky - flush pops us, then we close new top
4400 */
4401 PerlIO_flush(f);
4402 return PerlIO_close(f);
4403 }
4404
4405 IV
4406 PerlIOPending_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
4407 {
4408 /*
4409 * A tad tricky - flush pops us, then we seek new top
4410 */
4411 PerlIO_flush(f);
4412 return PerlIO_seek(f, offset, whence);
4413 }
4414
4415
4416 IV
4417 PerlIOPending_flush(pTHX_ PerlIO *f)
4418 {
4419 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4420 if (b->buf && b->buf != (STDCHAR *) & b->oneword) {
4421 Safefree(b->buf);
4422 b->buf = NULL;
4423 }
4424 PerlIO_pop(aTHX_ f);
4425 return 0;
4426 }
4427
4428 void
4429 PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4430 {
4431 if (cnt <= 0) {
4432 PerlIO_flush(f);
4433 }
4434 else {
4435 PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt);
4436 }
4437 }
4438
4439 IV
4440 PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4441 {
4442 const IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
4443 PerlIOl * const l = PerlIOBase(f);
4444 /*
4445 * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
4446 * etc. get muddled when it changes mid-string when we auto-pop.
4447 */
4448 l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) |
4449 (PerlIOBase(PerlIONext(f))->
4450 flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8));
4451 return code;
4452 }
4453
4454 SSize_t
4455 PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
4456 {
4457 SSize_t avail = PerlIO_get_cnt(f);
4458 SSize_t got = 0;
4459 if ((SSize_t) count >= 0 && (SSize_t)count < avail)
4460 avail = count;
4461 if (avail > 0)
4462 got = PerlIOBuf_read(aTHX_ f, vbuf, avail);
4463 if (got >= 0 && got < (SSize_t)count) {
4464 const SSize_t more =
4465 PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got);
4466 if (more >= 0 || got == 0)
4467 got += more;
4468 }
4469 return got;
4470 }
4471
4472 PERLIO_FUNCS_DECL(PerlIO_pending) = {
4473 sizeof(PerlIO_funcs),
4474 "pending",
4475 sizeof(PerlIOBuf),
4476 PERLIO_K_BUFFERED|PERLIO_K_RAW, /* not sure about RAW here */
4477 PerlIOPending_pushed,
4478 PerlIOBuf_popped,
4479 NULL,
4480 PerlIOBase_binmode, /* binmode */
4481 NULL,
4482 PerlIOBase_fileno,
4483 PerlIOBuf_dup,
4484 PerlIOPending_read,
4485 PerlIOBuf_unread,
4486 PerlIOBuf_write,
4487 PerlIOPending_seek,
4488 PerlIOBuf_tell,
4489 PerlIOPending_close,
4490 PerlIOPending_flush,
4491 PerlIOPending_fill,
4492 PerlIOBase_eof,
4493 PerlIOBase_error,
4494 PerlIOBase_clearerr,
4495 PerlIOBase_setlinebuf,
4496 PerlIOBuf_get_base,
4497 PerlIOBuf_bufsiz,
4498 PerlIOBuf_get_ptr,
4499 PerlIOBuf_get_cnt,
4500 PerlIOPending_set_ptrcnt,
4501 };
4502
4503
4504
4505 /*--------------------------------------------------------------------------------------*/
4506 /*
4507 * crlf - translation On read translate CR,LF to "\n" we do this by
4508 * overriding ptr/cnt entries to hand back a line at a time and keeping a
4509 * record of which nl we "lied" about. On write translate "\n" to CR,LF
4510 *
4511 * c->nl points on the first byte of CR LF pair when it is temporarily
4512 * replaced by LF, or to the last CR of the buffer. In the former case
4513 * the caller thinks that the buffer ends at c->nl + 1, in the latter
4514 * that it ends at c->nl; these two cases can be distinguished by
4515 * *c->nl. c->nl is set during _getcnt() call, and unset during
4516 * _unread() and _flush() calls.
4517 * It only matters for read operations.
4518 */
4519
4520 typedef struct {
4521 PerlIOBuf base; /* PerlIOBuf stuff */
4522 STDCHAR *nl; /* Position of crlf we "lied" about in the
4523 * buffer */
4524 } PerlIOCrlf;
4525
4526 /* Inherit the PERLIO_F_UTF8 flag from previous layer.
4527 * Otherwise the :crlf layer would always revert back to
4528 * raw mode.
4529 */
4530 static void
4531 S_inherit_utf8_flag(PerlIO *f)
4532 {
4533 PerlIO *g = PerlIONext(f);
4534 if (PerlIOValid(g)) {
4535 if (PerlIOBase(g)->flags & PERLIO_F_UTF8) {
4536 PerlIOBase(f)->flags |= PERLIO_F_UTF8;
4537 }
4538 }
4539 }
4540
4541 IV
4542 PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
4543 {
4544 IV code;
4545 PerlIOBase(f)->flags |= PERLIO_F_CRLF;
4546 code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
4547 #if 0
4548 DEBUG_i(
4549 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
4550 (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
4551 PerlIOBase(f)->flags);
4552 );
4553 #endif
4554 {
4555 /* If the old top layer is a CRLF layer, reactivate it (if
4556 * necessary) and remove this new layer from the stack */
4557 PerlIO *g = PerlIONext(f);
4558 if (PerlIOValid(g)) {
4559 PerlIOl *b = PerlIOBase(g);
4560 if (b && b->tab == &PerlIO_crlf) {
4561 if (!(b->flags & PERLIO_F_CRLF))
4562 b->flags |= PERLIO_F_CRLF;
4563 S_inherit_utf8_flag(g);
4564 PerlIO_pop(aTHX_ f);
4565 return code;
4566 }
4567 }
4568 }
4569 S_inherit_utf8_flag(f);
4570 return code;
4571 }
4572
4573
4574 SSize_t
4575 PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4576 {
4577 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4578 if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */
4579 *(c->nl) = NATIVE_0xd;
4580 c->nl = NULL;
4581 }
4582 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4583 return PerlIOBuf_unread(aTHX_ f, vbuf, count);
4584 else {
4585 const STDCHAR *buf = (const STDCHAR *) vbuf + count;
4586 PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
4587 SSize_t unread = 0;
4588 if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
4589 PerlIO_flush(f);
4590 if (!b->buf)
4591 PerlIO_get_base(f);
4592 if (b->buf) {
4593 if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
4594 b->end = b->ptr = b->buf + b->bufsiz;
4595 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4596 b->posn -= b->bufsiz;
4597 }
4598 while (count > 0 && b->ptr > b->buf) {
4599 const int ch = *--buf;
4600 if (ch == '\n') {
4601 if (b->ptr - 2 >= b->buf) {
4602 *--(b->ptr) = NATIVE_0xa;
4603 *--(b->ptr) = NATIVE_0xd;
4604 unread++;
4605 count--;
4606 }
4607 else {
4608 /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */
4609 *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa ==
4610 '\r' */
4611 unread++;
4612 count--;
4613 }
4614 }
4615 else {
4616 *--(b->ptr) = ch;
4617 unread++;
4618 count--;
4619 }
4620 }
4621 }
4622 if (count > 0)
4623 unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count);
4624 return unread;
4625 }
4626 }
4627
4628 /* XXXX This code assumes that buffer size >=2, but does not check it... */
4629 SSize_t
4630 PerlIOCrlf_get_cnt(pTHX_ PerlIO *f)
4631 {
4632 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4633 if (!b->buf)
4634 PerlIO_get_base(f);
4635 if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) {
4636 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4637 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) {
4638 STDCHAR *nl = (c->nl) ? c->nl : b->ptr;
4639 scan:
4640 while (nl < b->end && *nl != NATIVE_0xd)
4641 nl++;
4642 if (nl < b->end && *nl == NATIVE_0xd) {
4643 test:
4644 if (nl + 1 < b->end) {
4645 if (nl[1] == NATIVE_0xa) {
4646 *nl = '\n';
4647 c->nl = nl;
4648 }
4649 else {
4650 /*
4651 * Not CR,LF but just CR
4652 */
4653 nl++;
4654 goto scan;
4655 }
4656 }
4657 else {
4658 /*
4659 * Blast - found CR as last char in buffer
4660 */
4661
4662 if (b->ptr < nl) {
4663 /*
4664 * They may not care, defer work as long as
4665 * possible
4666 */
4667 c->nl = nl;
4668 return (nl - b->ptr);
4669 }
4670 else {
4671 int code;
4672 b->ptr++; /* say we have read it as far as
4673 * flush() is concerned */
4674 b->buf++; /* Leave space in front of buffer */
4675 /* Note as we have moved buf up flush's
4676 posn += ptr-buf
4677 will naturally make posn point at CR
4678 */
4679 b->bufsiz--; /* Buffer is thus smaller */
4680 code = PerlIO_fill(f); /* Fetch some more */
4681 b->bufsiz++; /* Restore size for next time */
4682 b->buf--; /* Point at space */
4683 b->ptr = nl = b->buf; /* Which is what we hand
4684 * off */
4685 *nl = NATIVE_0xd; /* Fill in the CR */
4686 if (code == 0)
4687 goto test; /* fill() call worked */
4688 /*
4689 * CR at EOF - just fall through
4690 */
4691 /* Should we clear EOF though ??? */
4692 }
4693 }
4694 }
4695 }
4696 return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr);
4697 }
4698 return 0;
4699 }
4700
4701 void
4702 PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
4703 {
4704 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4705 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4706 if (!b->buf)
4707 PerlIO_get_base(f);
4708 if (!ptr) {
4709 if (c->nl) {
4710 ptr = c->nl + 1;
4711 if (ptr == b->end && *c->nl == NATIVE_0xd) {
4712 /* Deferred CR at end of buffer case - we lied about count */
4713 ptr--;
4714 }
4715 }
4716 else {
4717 ptr = b->end;
4718 }
4719 ptr -= cnt;
4720 }
4721 else {
4722 NOOP;
4723 #if 0
4724 /*
4725 * Test code - delete when it works ...
4726 */
4727 IV flags = PerlIOBase(f)->flags;
4728 STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end;
4729 if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) {
4730 /* Deferred CR at end of buffer case - we lied about count */
4731 chk--;
4732 }
4733 chk -= cnt;
4734
4735 if (ptr != chk ) {
4736 Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf
4737 " nl=%p e=%p for %d", (void*)ptr, (void*)chk,
4738 flags, c->nl, b->end, cnt);
4739 }
4740 #endif
4741 }
4742 if (c->nl) {
4743 if (ptr > c->nl) {
4744 /*
4745 * They have taken what we lied about
4746 */
4747 *(c->nl) = NATIVE_0xd;
4748 c->nl = NULL;
4749 ptr++;
4750 }
4751 }
4752 b->ptr = ptr;
4753 PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
4754 }
4755
4756 SSize_t
4757 PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
4758 {
4759 if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF))
4760 return PerlIOBuf_write(aTHX_ f, vbuf, count);
4761 else {
4762 PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
4763 const STDCHAR *buf = (const STDCHAR *) vbuf;
4764 const STDCHAR * const ebuf = buf + count;
4765 if (!b->buf)
4766 PerlIO_get_base(f);
4767 if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE))
4768 return 0;
4769 while (buf < ebuf) {
4770 const STDCHAR * const eptr = b->buf + b->bufsiz;
4771 PerlIOBase(f)->flags |= PERLIO_F_WRBUF;
4772 while (buf < ebuf && b->ptr < eptr) {
4773 if (*buf == '\n') {
4774 if ((b->ptr + 2) > eptr) {
4775 /*
4776 * Not room for both
4777 */
4778 PerlIO_flush(f);
4779 break;
4780 }
4781 else {
4782 *(b->ptr)++ = NATIVE_0xd; /* CR */
4783 *(b->ptr)++ = NATIVE_0xa; /* LF */
4784 buf++;
4785 if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) {
4786 PerlIO_flush(f);
4787 break;
4788 }
4789 }
4790 }
4791 else {
4792 *(b->ptr)++ = *buf++;
4793 }
4794 if (b->ptr >= eptr) {
4795 PerlIO_flush(f);
4796 break;
4797 }
4798 }
4799 }
4800 if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
4801 PerlIO_flush(f);
4802 return (buf - (STDCHAR *) vbuf);
4803 }
4804 }
4805
4806 IV
4807 PerlIOCrlf_flush(pTHX_ PerlIO *f)
4808 {
4809 PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf);
4810 if (c->nl) {
4811 *(c->nl) = NATIVE_0xd;
4812 c->nl = NULL;
4813 }
4814 return PerlIOBuf_flush(aTHX_ f);
4815 }
4816
4817 IV
4818 PerlIOCrlf_binmode(pTHX_ PerlIO *f)
4819 {
4820 if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
4821 /* In text mode - flush any pending stuff and flip it */
4822 PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
4823 #ifndef PERLIO_USING_CRLF
4824 /* CRLF is unusual case - if this is just the :crlf layer pop it */
4825 PerlIO_pop(aTHX_ f);
4826 #endif
4827 }
4828 return PerlIOBase_binmode(aTHX_ f);
4829 }
4830
4831 PERLIO_FUNCS_DECL(PerlIO_crlf) = {
4832 sizeof(PerlIO_funcs),
4833 "crlf",
4834 sizeof(PerlIOCrlf),
4835 PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
4836 PerlIOCrlf_pushed,
4837 PerlIOBuf_popped, /* popped */
4838 PerlIOBuf_open,
4839 PerlIOCrlf_binmode, /* binmode */
4840 NULL,
4841 PerlIOBase_fileno,
4842 PerlIOBuf_dup,
4843 PerlIOBuf_read, /* generic read works with ptr/cnt lies */
4844 PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */
4845 PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */
4846 PerlIOBuf_seek,
4847 PerlIOBuf_tell,
4848 PerlIOBuf_close,
4849 PerlIOCrlf_flush,
4850 PerlIOBuf_fill,
4851 PerlIOBase_eof,
4852 PerlIOBase_error,
4853 PerlIOBase_clearerr,
4854 PerlIOBase_setlinebuf,
4855 PerlIOBuf_get_base,
4856 PerlIOBuf_bufsiz,
4857 PerlIOBuf_get_ptr,
4858 PerlIOCrlf_get_cnt,
4859 PerlIOCrlf_set_ptrcnt,
4860 };
4861
4862 PerlIO *
4863 Perl_PerlIO_stdin(pTHX)
4864 {
4865 if (!PL_perlio) {
4866 PerlIO_stdstreams(aTHX);
4867 }
4868 return (PerlIO*)&PL_perlio[1];
4869 }
4870
4871 PerlIO *
4872 Perl_PerlIO_stdout(pTHX)
4873 {
4874 if (!PL_perlio) {
4875 PerlIO_stdstreams(aTHX);
4876 }
4877 return (PerlIO*)&PL_perlio[2];
4878 }
4879
4880 PerlIO *
4881 Perl_PerlIO_stderr(pTHX)
4882 {
4883 if (!PL_perlio) {
4884 PerlIO_stdstreams(aTHX);
4885 }
4886 return (PerlIO*)&PL_perlio[3];
4887 }
4888
4889 /*--------------------------------------------------------------------------------------*/
4890
4891 char *
4892 PerlIO_getname(PerlIO *f, char *buf)
4893 {
4894 #ifdef VMS
4895 dTHX;
4896 char *name = NULL;
4897 bool exported = FALSE;
4898 FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
4899 if (!stdio) {
4900 stdio = PerlIO_exportFILE(f,0);
4901 exported = TRUE;
4902 }
4903 if (stdio) {
4904 name = fgetname(stdio, buf);
4905 if (exported) PerlIO_releaseFILE(f,stdio);
4906 }
4907 return name;
4908 #else
4909 PERL_UNUSED_ARG(f);
4910 PERL_UNUSED_ARG(buf);
4911 Perl_croak_nocontext("Don't know how to get file name");
4912 return NULL;
4913 #endif
4914 }
4915
4916
4917 /*--------------------------------------------------------------------------------------*/
4918 /*
4919 * Functions which can be called on any kind of PerlIO implemented in
4920 * terms of above
4921 */
4922
4923 #undef PerlIO_fdopen
4924 PerlIO *
4925 PerlIO_fdopen(int fd, const char *mode)
4926 {
4927 dTHX;
4928 return PerlIO_openn(aTHX_ NULL, mode, fd, 0, 0, NULL, 0, NULL);
4929 }
4930
4931 #undef PerlIO_open
4932 PerlIO *
4933 PerlIO_open(const char *path, const char *mode)
4934 {
4935 dTHX;
4936 SV *name = sv_2mortal(newSVpv(path, 0));
4937 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, NULL, 1, &name);
4938 }
4939
4940 #undef Perlio_reopen
4941 PerlIO *
4942 PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
4943 {
4944 dTHX;
4945 SV *name = sv_2mortal(newSVpv(path,0));
4946 return PerlIO_openn(aTHX_ NULL, mode, -1, 0, 0, f, 1, &name);
4947 }
4948
4949 #undef PerlIO_getc
4950 int
4951 PerlIO_getc(PerlIO *f)
4952 {
4953 dTHX;
4954 STDCHAR buf[1];
4955 if ( 1 == PerlIO_read(f, buf, 1) ) {
4956 return (unsigned char) buf[0];
4957 }
4958 return EOF;
4959 }
4960
4961 #undef PerlIO_ungetc
4962 int
4963 PerlIO_ungetc(PerlIO *f, int ch)
4964 {
4965 dTHX;
4966 if (ch != EOF) {
4967 STDCHAR buf = ch;
4968 if (PerlIO_unread(f, &buf, 1) == 1)
4969 return ch;
4970 }
4971 return EOF;
4972 }
4973
4974 #undef PerlIO_putc
4975 int
4976 PerlIO_putc(PerlIO *f, int ch)
4977 {
4978 dTHX;
4979 STDCHAR buf = ch;
4980 return PerlIO_write(f, &buf, 1);
4981 }
4982
4983 #undef PerlIO_puts
4984 int
4985 PerlIO_puts(PerlIO *f, const char *s)
4986 {
4987 dTHX;
4988 return PerlIO_write(f, s, strlen(s));
4989 }
4990
4991 #undef PerlIO_rewind
4992 void
4993 PerlIO_rewind(PerlIO *f)
4994 {
4995 dTHX;
4996 PerlIO_seek(f, (Off_t) 0, SEEK_SET);
4997 PerlIO_clearerr(f);
4998 }
4999
5000 #undef PerlIO_vprintf
5001 int
5002 PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap)
5003 {
5004 dTHX;
5005 SV * sv;
5006 const char *s;
5007 STRLEN len;
5008 SSize_t wrote;
5009 #ifdef NEED_VA_COPY
5010 va_list apc;
5011 Perl_va_copy(ap, apc);
5012 sv = vnewSVpvf(fmt, &apc);
5013 va_end(apc);
5014 #else
5015 sv = vnewSVpvf(fmt, &ap);
5016 #endif
5017 s = SvPV_const(sv, len);
5018 wrote = PerlIO_write(f, s, len);
5019 SvREFCNT_dec(sv);
5020 return wrote;
5021 }
5022
5023 #undef PerlIO_printf
5024 int
5025 PerlIO_printf(PerlIO *f, const char *fmt, ...)
5026 {
5027 va_list ap;
5028 int result;
5029 va_start(ap, fmt);
5030 result = PerlIO_vprintf(f, fmt, ap);
5031 va_end(ap);
5032 return result;
5033 }
5034
5035 #undef PerlIO_stdoutf
5036 int
5037 PerlIO_stdoutf(const char *fmt, ...)
5038 {
5039 dTHX;
5040 va_list ap;
5041 int result;
5042 va_start(ap, fmt);
5043 result = PerlIO_vprintf(PerlIO_stdout(), fmt, ap);
5044 va_end(ap);
5045 return result;
5046 }
5047
5048 #undef PerlIO_tmpfile
5049 PerlIO *
5050 PerlIO_tmpfile(void)
5051 {
5052 #ifndef WIN32
5053 dTHX;
5054 #endif
5055 PerlIO *f = NULL;
5056 #ifdef WIN32
5057 const int fd = win32_tmpfd();
5058 if (fd >= 0)
5059 f = PerlIO_fdopen(fd, "w+b");
5060 #elif ! defined(VMS) && ! defined(OS2)
5061 int fd = -1;
5062 char tempname[] = "/tmp/PerlIO_XXXXXX";
5063 const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR");
5064 SV * sv = NULL;
5065 int old_umask = umask(0177);
5066 if (tmpdir && *tmpdir) {
5067 /* if TMPDIR is set and not empty, we try that first */
5068 sv = newSVpv(tmpdir, 0);
5069 sv_catpv(sv, tempname + 4);
5070 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
5071 }
5072 if (fd < 0) {
5073 SvREFCNT_dec(sv);
5074 sv = NULL;
5075 /* else we try /tmp */
5076 fd = Perl_my_mkstemp_cloexec(tempname);
5077 }
5078 if (fd < 0) {
5079 /* Try cwd */
5080 sv = newSVpvs(".");
5081 sv_catpv(sv, tempname + 4);
5082 fd = Perl_my_mkstemp_cloexec(SvPVX(sv));
5083 }
5084 umask(old_umask);
5085 if (fd >= 0) {
5086 f = PerlIO_fdopen(fd, "w+");
5087 if (f)
5088 PerlIOBase(f)->flags |= PERLIO_F_TEMP;
5089 PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname);
5090 }
5091 SvREFCNT_dec(sv);
5092 #else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */
5093 FILE * const stdio = PerlSIO_tmpfile();
5094
5095 if (stdio)
5096 f = PerlIO_fdopen(fileno(stdio), "w+");
5097
5098 #endif /* else WIN32 */
5099 return f;
5100 }
5101
5102 void
5103 Perl_PerlIO_save_errno(pTHX_ PerlIO *f)
5104 {
5105 PERL_UNUSED_CONTEXT;
5106 if (!PerlIOValid(f))
5107 return;
5108 PerlIOBase(f)->err = errno;
5109 #ifdef VMS
5110 PerlIOBase(f)->os_err = vaxc$errno;
5111 #elif defined(OS2)
5112 PerlIOBase(f)->os_err = Perl_rc;
5113 #elif defined(WIN32)
5114 PerlIOBase(f)->os_err = GetLastError();
5115 #endif
5116 }
5117
5118 void
5119 Perl_PerlIO_restore_errno(pTHX_ PerlIO *f)
5120 {
5121 PERL_UNUSED_CONTEXT;
5122 if (!PerlIOValid(f))
5123 return;
5124 SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err);
5125 #ifdef OS2
5126 Perl_rc = PerlIOBase(f)->os_err);
5127 #elif defined(WIN32)
5128 SetLastError(PerlIOBase(f)->os_err);
5129 #endif
5130 }
5131
5132 #undef HAS_FSETPOS
5133 #undef HAS_FGETPOS
5134
5135
5136 /*======================================================================================*/
5137 /*
5138 * Now some functions in terms of above which may be needed even if we are
5139 * not in true PerlIO mode
5140 */
5141 const char *
5142 Perl_PerlIO_context_layers(pTHX_ const char *mode)
5143 {
5144 const char *direction = NULL;
5145 SV *layers;
5146 /*
5147 * Need to supply default layer info from open.pm
5148 */
5149
5150 if (!PL_curcop)
5151 return NULL;
5152
5153 if (mode && mode[0] != 'r') {
5154 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT)
5155 direction = "open>";
5156 } else {
5157 if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN)
5158 direction = "open<";
5159 }
5160 if (!direction)
5161 return NULL;
5162
5163 layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0);
5164
5165 assert(layers);
5166 return SvOK(layers) ? SvPV_nolen_const(layers) : NULL;
5167 }
5168
5169
5170 #ifndef HAS_FSETPOS
5171 #undef PerlIO_setpos
5172 int
5173 PerlIO_setpos(PerlIO *f, SV *pos)
5174 {
5175 if (SvOK(pos)) {
5176 if (f) {
5177 dTHX;
5178 STRLEN len;
5179 const Off_t * const posn = (Off_t *) SvPV(pos, len);
5180 if(len == sizeof(Off_t))
5181 return PerlIO_seek(f, *posn, SEEK_SET);
5182 }
5183 }
5184 SETERRNO(EINVAL, SS_IVCHAN);
5185 return -1;
5186 }
5187 #else
5188 #undef PerlIO_setpos
5189 int
5190 PerlIO_setpos(PerlIO *f, SV *pos)
5191 {
5192 if (SvOK(pos)) {
5193 if (f) {
5194 dTHX;
5195 STRLEN len;
5196 Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len);
5197 if(len == sizeof(Fpos_t))
5198 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5199 return fsetpos64(f, fpos);
5200 #else
5201 return fsetpos(f, fpos);
5202 #endif
5203 }
5204 }
5205 SETERRNO(EINVAL, SS_IVCHAN);
5206 return -1;
5207 }
5208 #endif
5209
5210 #ifndef HAS_FGETPOS
5211 #undef PerlIO_getpos
5212 int
5213 PerlIO_getpos(PerlIO *f, SV *pos)
5214 {
5215 dTHX;
5216 Off_t posn = PerlIO_tell(f);
5217 sv_setpvn(pos, (char *) &posn, sizeof(posn));
5218 return (posn == (Off_t) - 1) ? -1 : 0;
5219 }
5220 #else
5221 #undef PerlIO_getpos
5222 int
5223 PerlIO_getpos(PerlIO *f, SV *pos)
5224 {
5225 dTHX;
5226 Fpos_t fpos;
5227 int code;
5228 #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64)
5229 code = fgetpos64(f, &fpos);
5230 #else
5231 code = fgetpos(f, &fpos);
5232 #endif
5233 sv_setpvn(pos, (char *) &fpos, sizeof(fpos));
5234 return code;
5235 }
5236 #endif
5237
5238 /* print a failure format string message to stderr and fail exit the process
5239 using only libc without depending on any perl data structures being
5240 initialized.
5241 */
5242
5243 void
5244 Perl_noperl_die(const char* pat, ...)
5245 {
5246 va_list arglist;
5247 PERL_ARGS_ASSERT_NOPERL_DIE;
5248 va_start(arglist, pat);
5249 vfprintf(stderr, pat, arglist);
5250 va_end(arglist);
5251 exit(1);
5252 }
5253
5254 /*
5255 * ex: set ts=8 sts=4 sw=4 et:
5256 */
5257