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