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