This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase page file quota advice in README.vms
[perl5.git] / util.c
... / ...
CommitLineData
1/* util.c
2 *
3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content.' --Gandalf to Pippin
14 *
15 * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16 */
17
18/* This file contains assorted utility routines.
19 * Which is a polite way of saying any stuff that people couldn't think of
20 * a better place for. Amongst other things, it includes the warning and
21 * dieing stuff, plus wrappers for malloc code.
22 */
23
24#include "EXTERN.h"
25#define PERL_IN_UTIL_C
26#include "perl.h"
27#include "reentr.h"
28
29#if defined(USE_PERLIO)
30#include "perliol.h" /* For PerlIOUnix_refcnt */
31#endif
32
33#ifndef PERL_MICRO
34#include <signal.h>
35#ifndef SIG_ERR
36# define SIG_ERR ((Sighandler_t) -1)
37#endif
38#endif
39
40#include <math.h>
41#include <stdlib.h>
42
43#ifdef __Lynx__
44/* Missing protos on LynxOS */
45int putenv(char *);
46#endif
47
48#ifdef __amigaos__
49# include "amigaos4/amigaio.h"
50#endif
51
52#ifdef HAS_SELECT
53# ifdef I_SYS_SELECT
54# include <sys/select.h>
55# endif
56#endif
57
58#ifdef USE_C_BACKTRACE
59# ifdef I_BFD
60# define USE_BFD
61# ifdef PERL_DARWIN
62# undef USE_BFD /* BFD is useless in OS X. */
63# endif
64# ifdef USE_BFD
65# include <bfd.h>
66# endif
67# endif
68# ifdef I_DLFCN
69# include <dlfcn.h>
70# endif
71# ifdef I_EXECINFO
72# include <execinfo.h>
73# endif
74#endif
75
76#ifdef PERL_DEBUG_READONLY_COW
77# include <sys/mman.h>
78#endif
79
80#define FLUSH
81
82/* NOTE: Do not call the next three routines directly. Use the macros
83 * in handy.h, so that we can easily redefine everything to do tracking of
84 * allocated hunks back to the original New to track down any memory leaks.
85 * XXX This advice seems to be widely ignored :-( --AD August 1996.
86 */
87
88#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
89# define ALWAYS_NEED_THX
90#endif
91
92#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
93static void
94S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
95{
96 if (header->readonly
97 && mprotect(header, header->size, PROT_READ|PROT_WRITE))
98 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
99 header, header->size, errno);
100}
101
102static void
103S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
104{
105 if (header->readonly
106 && mprotect(header, header->size, PROT_READ))
107 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
108 header, header->size, errno);
109}
110# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
111# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
112#else
113# define maybe_protect_rw(foo) NOOP
114# define maybe_protect_ro(foo) NOOP
115#endif
116
117#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
118 /* Use memory_debug_header */
119# define USE_MDH
120# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
121 || defined(PERL_DEBUG_READONLY_COW)
122# define MDH_HAS_SIZE
123# endif
124#endif
125
126/*
127=for apidoc_section $memory
128=for apidoc safesysmalloc
129Paranoid version of system's malloc()
130
131=cut
132*/
133
134Malloc_t
135Perl_safesysmalloc(MEM_SIZE size)
136{
137#ifdef ALWAYS_NEED_THX
138 dTHX;
139#endif
140 Malloc_t ptr;
141 dSAVEDERRNO;
142
143#ifdef USE_MDH
144 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
145 goto out_of_memory;
146 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
147#endif
148#ifdef DEBUGGING
149 if ((SSize_t)size < 0)
150 Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
151#endif
152 if (!size) size = 1; /* malloc(0) is NASTY on our system */
153 SAVE_ERRNO;
154#ifdef PERL_DEBUG_READONLY_COW
155 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
156 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
157 perror("mmap failed");
158 abort();
159 }
160#else
161 ptr = (Malloc_t)PerlMem_malloc(size);
162#endif
163 PERL_ALLOC_CHECK(ptr);
164 if (ptr != NULL) {
165#ifdef USE_MDH
166 struct perl_memory_debug_header *const header
167 = (struct perl_memory_debug_header *)ptr;
168#endif
169
170#ifdef PERL_POISON
171 PoisonNew(((char *)ptr), size, char);
172#endif
173
174#ifdef PERL_TRACK_MEMPOOL
175 header->interpreter = aTHX;
176 /* Link us into the list. */
177 header->prev = &PL_memory_debug_header;
178 header->next = PL_memory_debug_header.next;
179 PL_memory_debug_header.next = header;
180 maybe_protect_rw(header->next);
181 header->next->prev = header;
182 maybe_protect_ro(header->next);
183# ifdef PERL_DEBUG_READONLY_COW
184 header->readonly = 0;
185# endif
186#endif
187#ifdef MDH_HAS_SIZE
188 header->size = size;
189#endif
190 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
191 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
192
193 /* malloc() can modify errno() even on success, but since someone
194 writing perl code doesn't have any control over when perl calls
195 malloc() we need to hide that.
196 */
197 RESTORE_ERRNO;
198 }
199 else {
200#ifdef USE_MDH
201 out_of_memory:
202#endif
203 {
204#ifndef ALWAYS_NEED_THX
205 dTHX;
206#endif
207 if (PL_nomemok)
208 ptr = NULL;
209 else
210 croak_no_mem();
211 }
212 }
213 return ptr;
214}
215
216/*
217=for apidoc safesysrealloc
218Paranoid version of system's realloc()
219
220=cut
221*/
222
223Malloc_t
224Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
225{
226#ifdef ALWAYS_NEED_THX
227 dTHX;
228#endif
229 Malloc_t ptr;
230#ifdef PERL_DEBUG_READONLY_COW
231 const MEM_SIZE oldsize = where
232 ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
233 : 0;
234#endif
235
236 if (!size) {
237 safesysfree(where);
238 ptr = NULL;
239 }
240 else if (!where) {
241 ptr = safesysmalloc(size);
242 }
243 else {
244 dSAVE_ERRNO;
245#ifdef USE_MDH
246 where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
247 if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
248 goto out_of_memory;
249 size += PERL_MEMORY_DEBUG_HEADER_SIZE;
250 {
251 struct perl_memory_debug_header *const header
252 = (struct perl_memory_debug_header *)where;
253
254# ifdef PERL_TRACK_MEMPOOL
255 if (header->interpreter != aTHX) {
256 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
257 header->interpreter, aTHX);
258 }
259 assert(header->next->prev == header);
260 assert(header->prev->next == header);
261# ifdef PERL_POISON
262 if (header->size > size) {
263 const MEM_SIZE freed_up = header->size - size;
264 char *start_of_freed = ((char *)where) + size;
265 PoisonFree(start_of_freed, freed_up, char);
266 }
267# endif
268# endif
269# ifdef MDH_HAS_SIZE
270 header->size = size;
271# endif
272 }
273#endif
274#ifdef DEBUGGING
275 if ((SSize_t)size < 0)
276 Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
277#endif
278#ifdef PERL_DEBUG_READONLY_COW
279 if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
280 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
281 perror("mmap failed");
282 abort();
283 }
284 Copy(where,ptr,oldsize < size ? oldsize : size,char);
285 if (munmap(where, oldsize)) {
286 perror("munmap failed");
287 abort();
288 }
289#else
290 ptr = (Malloc_t)PerlMem_realloc(where,size);
291#endif
292 PERL_ALLOC_CHECK(ptr);
293
294 /* MUST do this fixup first, before doing ANYTHING else, as anything else
295 might allocate memory/free/move memory, and until we do the fixup, it
296 may well be chasing (and writing to) free memory. */
297 if (ptr != NULL) {
298#ifdef PERL_TRACK_MEMPOOL
299 struct perl_memory_debug_header *const header
300 = (struct perl_memory_debug_header *)ptr;
301
302# ifdef PERL_POISON
303 if (header->size < size) {
304 const MEM_SIZE fresh = size - header->size;
305 char *start_of_fresh = ((char *)ptr) + size;
306 PoisonNew(start_of_fresh, fresh, char);
307 }
308# endif
309
310 maybe_protect_rw(header->next);
311 header->next->prev = header;
312 maybe_protect_ro(header->next);
313 maybe_protect_rw(header->prev);
314 header->prev->next = header;
315 maybe_protect_ro(header->prev);
316#endif
317 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
318
319 /* realloc() can modify errno() even on success, but since someone
320 writing perl code doesn't have any control over when perl calls
321 realloc() we need to hide that.
322 */
323 RESTORE_ERRNO;
324 }
325
326 /* In particular, must do that fixup above before logging anything via
327 *printf(), as it can reallocate memory, which can cause SEGVs. */
328
329 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
330 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
331
332 if (ptr == NULL) {
333#ifdef USE_MDH
334 out_of_memory:
335#endif
336 {
337#ifndef ALWAYS_NEED_THX
338 dTHX;
339#endif
340 if (PL_nomemok)
341 ptr = NULL;
342 else
343 croak_no_mem();
344 }
345 }
346 }
347 return ptr;
348}
349
350/*
351=for apidoc safesysfree
352Safe version of system's free()
353
354=cut
355*/
356
357Free_t
358Perl_safesysfree(Malloc_t where)
359{
360#ifdef ALWAYS_NEED_THX
361 dTHX;
362#endif
363 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
364 if (where) {
365#ifdef USE_MDH
366 Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
367 {
368 struct perl_memory_debug_header *const header
369 = (struct perl_memory_debug_header *)where_intrn;
370
371# ifdef MDH_HAS_SIZE
372 const MEM_SIZE size = header->size;
373# endif
374# ifdef PERL_TRACK_MEMPOOL
375 if (header->interpreter != aTHX) {
376 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
377 header->interpreter, aTHX);
378 }
379 if (!header->prev) {
380 Perl_croak_nocontext("panic: duplicate free");
381 }
382 if (!(header->next))
383 Perl_croak_nocontext("panic: bad free, header->next==NULL");
384 if (header->next->prev != header || header->prev->next != header) {
385 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
386 "header=%p, ->prev->next=%p",
387 header->next->prev, header,
388 header->prev->next);
389 }
390 /* Unlink us from the chain. */
391 maybe_protect_rw(header->next);
392 header->next->prev = header->prev;
393 maybe_protect_ro(header->next);
394 maybe_protect_rw(header->prev);
395 header->prev->next = header->next;
396 maybe_protect_ro(header->prev);
397 maybe_protect_rw(header);
398# ifdef PERL_POISON
399 PoisonNew(where_intrn, size, char);
400# endif
401 /* Trigger the duplicate free warning. */
402 header->next = NULL;
403# endif
404# ifdef PERL_DEBUG_READONLY_COW
405 if (munmap(where_intrn, size)) {
406 perror("munmap failed");
407 abort();
408 }
409# endif
410 }
411#else
412 Malloc_t where_intrn = where;
413#endif /* USE_MDH */
414#ifndef PERL_DEBUG_READONLY_COW
415 PerlMem_free(where_intrn);
416#endif
417 }
418}
419
420/*
421=for apidoc safesyscalloc
422Safe version of system's calloc()
423
424=cut
425*/
426
427Malloc_t
428Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
429{
430#ifdef ALWAYS_NEED_THX
431 dTHX;
432#endif
433 Malloc_t ptr;
434#if defined(USE_MDH) || defined(DEBUGGING)
435 MEM_SIZE total_size = 0;
436#endif
437
438 /* Even though calloc() for zero bytes is strange, be robust. */
439 if (size && (count <= MEM_SIZE_MAX / size)) {
440#if defined(USE_MDH) || defined(DEBUGGING)
441 total_size = size * count;
442#endif
443 }
444 else
445 croak_memory_wrap();
446#ifdef USE_MDH
447 if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
448 total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
449 else
450 croak_memory_wrap();
451#endif
452#ifdef DEBUGGING
453 if ((SSize_t)size < 0 || (SSize_t)count < 0)
454 Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
455 (UV)size, (UV)count);
456#endif
457#ifdef PERL_DEBUG_READONLY_COW
458 if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
459 MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
460 perror("mmap failed");
461 abort();
462 }
463#elif defined(PERL_TRACK_MEMPOOL)
464 /* Have to use malloc() because we've added some space for our tracking
465 header. */
466 /* malloc(0) is non-portable. */
467 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
468#else
469 /* Use calloc() because it might save a memset() if the memory is fresh
470 and clean from the OS. */
471 if (count && size)
472 ptr = (Malloc_t)PerlMem_calloc(count, size);
473 else /* calloc(0) is non-portable. */
474 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
475#endif
476 PERL_ALLOC_CHECK(ptr);
477 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
478 if (ptr != NULL) {
479#ifdef USE_MDH
480 {
481 struct perl_memory_debug_header *const header
482 = (struct perl_memory_debug_header *)ptr;
483
484# ifndef PERL_DEBUG_READONLY_COW
485 memset((void*)ptr, 0, total_size);
486# endif
487# ifdef PERL_TRACK_MEMPOOL
488 header->interpreter = aTHX;
489 /* Link us into the list. */
490 header->prev = &PL_memory_debug_header;
491 header->next = PL_memory_debug_header.next;
492 PL_memory_debug_header.next = header;
493 maybe_protect_rw(header->next);
494 header->next->prev = header;
495 maybe_protect_ro(header->next);
496# ifdef PERL_DEBUG_READONLY_COW
497 header->readonly = 0;
498# endif
499# endif
500# ifdef MDH_HAS_SIZE
501 header->size = total_size;
502# endif
503 ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
504 }
505#endif
506 return ptr;
507 }
508 else {
509#ifndef ALWAYS_NEED_THX
510 dTHX;
511#endif
512 if (PL_nomemok)
513 return NULL;
514 croak_no_mem();
515 }
516}
517
518/* These must be defined when not using Perl's malloc for binary
519 * compatibility */
520
521#ifndef MYMALLOC
522
523Malloc_t Perl_malloc (MEM_SIZE nbytes)
524{
525#ifdef PERL_IMPLICIT_SYS
526 dTHX;
527#endif
528 return (Malloc_t)PerlMem_malloc(nbytes);
529}
530
531Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
532{
533#ifdef PERL_IMPLICIT_SYS
534 dTHX;
535#endif
536 return (Malloc_t)PerlMem_calloc(elements, size);
537}
538
539Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
540{
541#ifdef PERL_IMPLICIT_SYS
542 dTHX;
543#endif
544 return (Malloc_t)PerlMem_realloc(where, nbytes);
545}
546
547Free_t Perl_mfree (Malloc_t where)
548{
549#ifdef PERL_IMPLICIT_SYS
550 dTHX;
551#endif
552 PerlMem_free(where);
553}
554
555#endif
556
557/* This is the value stored in *retlen in the two delimcpy routines below when
558 * there wasn't enough room in the destination to store everything it was asked
559 * to. The value is deliberately very large so that hopefully if code uses it
560 * unquestioninly to access memory, it will likely segfault. And it is small
561 * enough that if the caller does some arithmetic on it before accessing, it
562 * won't overflow into a small legal number. */
563#define DELIMCPY_OUT_OF_BOUNDS_RET I32_MAX
564
565/*
566=for apidoc_section $string
567=for apidoc delimcpy_no_escape
568
569Copy a source buffer to a destination buffer, stopping at (but not including)
570the first occurrence in the source of the delimiter byte, C<delim>. The source
571is the bytes between S<C<from> and C<from_end> - 1>. Similarly, the dest is
572C<to> up to C<to_end>.
573
574The number of bytes copied is written to C<*retlen>.
575
576Returns the position of C<delim> in the C<from> buffer, but if there is no
577such occurrence before C<from_end>, then C<from_end> is returned, and the entire
578buffer S<C<from> .. C<from_end> - 1> is copied.
579
580If there is room in the destination available after the copy, an extra
581terminating safety C<NUL> byte is appended (not included in the returned
582length).
583
584The error case is if the destination buffer is not large enough to accommodate
585everything that should be copied. In this situation, a value larger than
586S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
587fits will be written to the destination. Not having room for the safety C<NUL>
588is not considered an error.
589
590=cut
591*/
592char *
593Perl_delimcpy_no_escape(char *to, const char *to_end,
594 const char *from, const char *from_end,
595 const int delim, I32 *retlen)
596{
597 const char * delim_pos;
598 Ptrdiff_t from_len = from_end - from;
599 Ptrdiff_t to_len = to_end - to;
600 SSize_t copy_len;
601
602 PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
603
604 assert(from_len >= 0);
605 assert(to_len >= 0);
606
607 /* Look for the first delimiter in the source */
608 delim_pos = (const char *) memchr(from, delim, from_len);
609
610 /* Copy up to where the delimiter was found, or the entire buffer if not
611 * found */
612 copy_len = (delim_pos) ? delim_pos - from : from_len;
613
614 /* If not enough room, copy as much as can fit, and set error return */
615 if (copy_len > to_len) {
616 Copy(from, to, to_len, char);
617 *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
618 }
619 else {
620 Copy(from, to, copy_len, char);
621
622 /* If there is extra space available, add a trailing NUL */
623 if (copy_len < to_len) {
624 to[copy_len] = '\0';
625 }
626
627 *retlen = copy_len;
628 }
629
630 return (char *) from + copy_len;
631}
632
633/*
634=for apidoc delimcpy
635
636Copy a source buffer to a destination buffer, stopping at (but not including)
637the first occurrence in the source of an unescaped (defined below) delimiter
638byte, C<delim>. The source is the bytes between S<C<from> and C<from_end> -
6391>. Similarly, the dest is C<to> up to C<to_end>.
640
641The number of bytes copied is written to C<*retlen>.
642
643Returns the position of the first uncopied C<delim> in the C<from> buffer, but
644if there is no such occurrence before C<from_end>, then C<from_end> is returned,
645and the entire buffer S<C<from> .. C<from_end> - 1> is copied.
646
647If there is room in the destination available after the copy, an extra
648terminating safety C<NUL> byte is appended (not included in the returned
649length).
650
651The error case is if the destination buffer is not large enough to accommodate
652everything that should be copied. In this situation, a value larger than
653S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
654fits will be written to the destination. Not having room for the safety C<NUL>
655is not considered an error.
656
657In the following examples, let C<x> be the delimiter, and C<0> represent a C<NUL>
658byte (B<NOT> the digit C<0>). Then we would have
659
660 Source Destination
661 abcxdef abc0
662
663provided the destination buffer is at least 4 bytes long.
664
665An escaped delimiter is one which is immediately preceded by a single
666backslash. Escaped delimiters are copied, and the copy continues past the
667delimiter; the backslash is not copied:
668
669 Source Destination
670 abc\xdef abcxdef0
671
672(provided the destination buffer is at least 8 bytes long).
673
674It's actually somewhat more complicated than that. A sequence of any odd number
675of backslashes escapes the following delimiter, and the copy continues with
676exactly one of the backslashes stripped.
677
678 Source Destination
679 abc\xdef abcxdef0
680 abc\\\xdef abc\\xdef0
681 abc\\\\\xdef abc\\\\xdef0
682
683(as always, if the destination is large enough)
684
685An even number of preceding backslashes does not escape the delimiter, so that
686the copy stops just before it, and includes all the backslashes (no stripping;
687zero is considered even):
688
689 Source Destination
690 abcxdef abc0
691 abc\\xdef abc\\0
692 abc\\\\xdef abc\\\\0
693
694=cut
695*/
696
697char *
698Perl_delimcpy(char *to, const char *to_end,
699 const char *from, const char *from_end,
700 const int delim, I32 *retlen)
701{
702 const char * const orig_to = to;
703 Ptrdiff_t copy_len = 0;
704 bool stopped_early = FALSE; /* Ran out of room to copy to */
705
706 PERL_ARGS_ASSERT_DELIMCPY;
707 assert(from_end >= from);
708 assert(to_end >= to);
709
710 /* Don't use the loop for the trivial case of the first character being the
711 * delimiter; otherwise would have to worry inside the loop about backing
712 * up before the start of 'from' */
713 if (LIKELY(from_end > from && *from != delim)) {
714 while ((copy_len = from_end - from) > 0) {
715 const char * backslash_pos;
716 const char * delim_pos;
717
718 /* Look for the next delimiter in the remaining portion of the
719 * source. A loop invariant is that we already know that the copy
720 * should include *from; this comes from the conditional before the
721 * loop, and how we set things up at the end of each iteration */
722 delim_pos = (const char *) memchr(from + 1, delim, copy_len - 1);
723
724 /* If didn't find it, done looking; set up so copies all of the
725 * source */
726 if (! delim_pos) {
727 copy_len = from_end - from;
728 break;
729 }
730
731 /* Look for a backslash immediately before the delimiter */
732 backslash_pos = delim_pos - 1;
733
734 /* If the delimiter is not escaped, this ends the copy */
735 if (*backslash_pos != '\\') {
736 copy_len = delim_pos - from;
737 break;
738 }
739
740 /* Here there is a backslash just before the delimiter, but it
741 * could be the final backslash in a sequence of them. Backup to
742 * find the first one in it. */
743 do {
744 backslash_pos--;
745 }
746 while (backslash_pos >= from && *backslash_pos == '\\');
747
748 /* If the number of backslashes is even, they just escape one
749 * another, leaving the delimiter unescaped, and stopping the copy.
750 * */
751 if (! ((delim_pos - (backslash_pos + 1)) & 1)) {
752 copy_len = delim_pos - from; /* even, copy up to delimiter */
753 break;
754 }
755
756 /* Here is odd, so the delimiter is escaped. We will try to copy
757 * all but the final backslash in the sequence */
758 copy_len = delim_pos - 1 - from;
759
760 /* Do the copy, but not beyond the end of the destination */
761 if (copy_len >= to_end - to) {
762 Copy(from, to, to_end - to, char);
763 stopped_early = TRUE;
764 to = (char *) to_end;
765 }
766 else {
767 Copy(from, to, copy_len, char);
768 to += copy_len;
769 }
770
771 /* Set up so next iteration will include the delimiter */
772 from = delim_pos;
773 }
774 }
775
776 /* Here, have found the final segment to copy. Copy that, but not beyond
777 * the size of the destination. If not enough room, copy as much as can
778 * fit, and set error return */
779 if (stopped_early || copy_len > to_end - to) {
780 Copy(from, to, to_end - to, char);
781 *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
782 }
783 else {
784 Copy(from, to, copy_len, char);
785
786 to += copy_len;
787
788 /* If there is extra space available, add a trailing NUL */
789 if (to < to_end) {
790 *to = '\0';
791 }
792
793 *retlen = to - orig_to;
794 }
795
796 return (char *) from + copy_len;
797}
798
799/*
800=for apidoc ninstr
801
802Find the first (leftmost) occurrence of a sequence of bytes within another
803sequence. This is the Perl version of C<strstr()>, extended to handle
804arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
805is what the initial C<n> in the function name stands for; some systems have an
806equivalent, C<memmem()>, but with a somewhat different API).
807
808Another way of thinking about this function is finding a needle in a haystack.
809C<big> points to the first byte in the haystack. C<big_end> points to one byte
810beyond the final byte in the haystack. C<little> points to the first byte in
811the needle. C<little_end> points to one byte beyond the final byte in the
812needle. All the parameters must be non-C<NULL>.
813
814The function returns C<NULL> if there is no occurrence of C<little> within
815C<big>. If C<little> is the empty string, C<big> is returned.
816
817Because this function operates at the byte level, and because of the inherent
818characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
819needle and the haystack are strings with the same UTF-8ness, but not if the
820UTF-8ness differs.
821
822=cut
823
824*/
825
826char *
827Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
828{
829 PERL_ARGS_ASSERT_NINSTR;
830
831#ifdef HAS_MEMMEM
832 return ninstr(big, bigend, little, lend);
833#else
834
835 if (little >= lend) {
836 return (char*) big;
837 }
838 else {
839 const U8 first = *little;
840 Size_t lsize;
841
842 /* No match can start closer to the end of the haystack than the length
843 * of the needle. */
844 bigend -= lend - little;
845 little++; /* Look for 'first', then the remainder is in here */
846 lsize = lend - little;
847
848 while (big <= bigend) {
849 big = (char *) memchr((U8 *) big, first, bigend - big + 1);
850 if (big == NULL || big > bigend) {
851 return NULL;
852 }
853
854 if (memEQ(big + 1, little, lsize)) {
855 return (char*) big;
856 }
857 big++;
858 }
859 }
860
861 return NULL;
862
863#endif
864
865}
866
867/*
868=for apidoc rninstr
869
870Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
871sequence of bytes within another sequence, returning C<NULL> if there is no
872such occurrence.
873
874=cut
875
876*/
877
878char *
879Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
880{
881 const Ptrdiff_t little_len = lend - little;
882 const Ptrdiff_t big_len = bigend - big;
883
884 PERL_ARGS_ASSERT_RNINSTR;
885
886 /* A non-existent needle trivially matches the rightmost possible position
887 * in the haystack */
888 if (UNLIKELY(little_len <= 0)) {
889 return (char*)bigend;
890 }
891
892 /* If the needle is larger than the haystack, the needle can't possibly fit
893 * inside the haystack. */
894 if (UNLIKELY(little_len > big_len)) {
895 return NULL;
896 }
897
898 /* Special case length 1 needles. It's trivial if we have memrchr();
899 * and otherwise we just do a per-byte search backwards.
900 *
901 * XXX When we don't have memrchr, we could use something like
902 * S_find_next_masked( or S_find_span_end() to do per-word searches */
903 if (little_len == 1) {
904 const char final = *little;
905
906#ifdef HAS_MEMRCHR
907
908 return (char *) memrchr(big, final, big_len);
909#else
910 const char * cur = bigend - 1;
911
912 do {
913 if (*cur == final) {
914 return (char *) cur;
915 }
916 } while (--cur >= big);
917
918 return NULL;
919#endif
920
921 }
922 else { /* Below, the needle is longer than a single byte */
923
924 /* We search backwards in the haystack for the final character of the
925 * needle. Each time one is found, we see if the characters just
926 * before it in the haystack match the rest of the needle. */
927 const char final = *(lend - 1);
928
929 /* What matches consists of 'little_len'-1 characters, then the final
930 * one */
931 const Size_t prefix_len = little_len - 1;
932
933 /* If the final character in the needle is any closer than this to the
934 * left edge, there wouldn't be enough room for all of it to fit in the
935 * haystack */
936 const char * const left_fence = big + prefix_len;
937
938 /* Start at the right edge */
939 char * cur = (char *) bigend;
940
941 /* memrchr() makes the search easy (and fast); otherwise, look
942 * backwards byte-by-byte. */
943 do {
944
945#ifdef HAS_MEMRCHR
946
947 cur = (char *) memrchr(left_fence, final, cur - left_fence);
948 if (cur == NULL) {
949 return NULL;
950 }
951#else
952 do {
953 cur--;
954 if (cur < left_fence) {
955 return NULL;
956 }
957 }
958 while (*cur != final);
959#endif
960
961 /* Here, we know that *cur is 'final'; see if the preceding bytes
962 * of the needle also match the corresponding haystack bytes */
963 if memEQ(cur - prefix_len, little, prefix_len) {
964 return cur - prefix_len;
965 }
966 } while (cur > left_fence);
967
968 return NULL;
969 }
970}
971
972/* As a space optimization, we do not compile tables for strings of length
973 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
974 special-cased in fbm_instr().
975
976 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
977
978/*
979
980=for apidoc fbm_compile
981
982Analyzes the string in order to make fast searches on it using C<fbm_instr()>
983-- the Boyer-Moore algorithm.
984
985=cut
986*/
987
988void
989Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
990{
991 const U8 *s;
992 STRLEN i;
993 STRLEN len;
994 MAGIC *mg;
995
996 PERL_ARGS_ASSERT_FBM_COMPILE;
997
998 if (isGV_with_GP(sv) || SvROK(sv))
999 return;
1000
1001 if (SvVALID(sv))
1002 return;
1003
1004 if (flags & FBMcf_TAIL) {
1005 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
1006 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
1007 if (mg && mg->mg_len >= 0)
1008 mg->mg_len++;
1009 }
1010 if (!SvPOK(sv) || SvNIOKp(sv))
1011 s = (U8*)SvPV_force_mutable(sv, len);
1012 else s = (U8 *)SvPV_mutable(sv, len);
1013 if (len == 0) /* TAIL might be on a zero-length string. */
1014 return;
1015 SvUPGRADE(sv, SVt_PVMG);
1016 SvIOK_off(sv);
1017 SvNOK_off(sv);
1018
1019 /* add PERL_MAGIC_bm magic holding the FBM lookup table */
1020
1021 assert(!mg_find(sv, PERL_MAGIC_bm));
1022 mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
1023 assert(mg);
1024
1025 if (len > 2) {
1026 /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
1027 the BM table. */
1028 const U8 mlen = (len>255) ? 255 : (U8)len;
1029 const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
1030 U8 *table;
1031
1032 Newx(table, 256, U8);
1033 memset((void*)table, mlen, 256);
1034 mg->mg_ptr = (char *)table;
1035 mg->mg_len = 256;
1036
1037 s += len - 1; /* last char */
1038 i = 0;
1039 while (s >= sb) {
1040 if (table[*s] == mlen)
1041 table[*s] = (U8)i;
1042 s--, i++;
1043 }
1044 }
1045
1046 BmUSEFUL(sv) = 100; /* Initial value */
1047 ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
1048}
1049
1050
1051/*
1052=for apidoc fbm_instr
1053
1054Returns the location of the SV in the string delimited by C<big> and
1055C<bigend> (C<bigend>) is the char following the last char).
1056It returns C<NULL> if the string can't be found. The C<sv>
1057does not have to be C<fbm_compiled>, but the search will not be as fast
1058then.
1059
1060=cut
1061
1062If SvTAIL(littlestr) is true, a fake "\n" was appended to the string
1063during FBM compilation due to FBMcf_TAIL in flags. It indicates that
1064the littlestr must be anchored to the end of bigstr (or to any \n if
1065FBMrf_MULTILINE).
1066
1067E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
1068while /abc$/ compiles to "abc\n" with SvTAIL() true.
1069
1070A littlestr of "abc", !SvTAIL matches as /abc/;
1071a littlestr of "ab\n", SvTAIL matches as:
1072 without FBMrf_MULTILINE: /ab\n?\z/
1073 with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
1074
1075(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
1076 "If SvTAIL is actually due to \Z or \z, this gives false positives
1077 if multiline".
1078*/
1079
1080
1081char *
1082Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
1083{
1084 unsigned char *s;
1085 STRLEN l;
1086 const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
1087 STRLEN littlelen = l;
1088 const I32 multiline = flags & FBMrf_MULTILINE;
1089 bool valid = SvVALID(littlestr);
1090 bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
1091
1092 PERL_ARGS_ASSERT_FBM_INSTR;
1093
1094 assert(bigend >= big);
1095
1096 if ((STRLEN)(bigend - big) < littlelen) {
1097 if ( tail
1098 && ((STRLEN)(bigend - big) == littlelen - 1)
1099 && (littlelen == 1
1100 || (*big == *little &&
1101 memEQ((char *)big, (char *)little, littlelen - 1))))
1102 return (char*)big;
1103 return NULL;
1104 }
1105
1106 switch (littlelen) { /* Special cases for 0, 1 and 2 */
1107 case 0:
1108 return (char*)big; /* Cannot be SvTAIL! */
1109
1110 case 1:
1111 if (tail && !multiline) /* Anchor only! */
1112 /* [-1] is safe because we know that bigend != big. */
1113 return (char *) (bigend - (bigend[-1] == '\n'));
1114
1115 s = (unsigned char *)memchr((void*)big, *little, bigend-big);
1116 if (s)
1117 return (char *)s;
1118 if (tail)
1119 return (char *) bigend;
1120 return NULL;
1121
1122 case 2:
1123 if (tail && !multiline) {
1124 /* a littlestr with SvTAIL must be of the form "X\n" (where X
1125 * is a single char). It is anchored, and can only match
1126 * "....X\n" or "....X" */
1127 if (bigend[-2] == *little && bigend[-1] == '\n')
1128 return (char*)bigend - 2;
1129 if (bigend[-1] == *little)
1130 return (char*)bigend - 1;
1131 return NULL;
1132 }
1133
1134 {
1135 /* memchr() is likely to be very fast, possibly using whatever
1136 * hardware support is available, such as checking a whole
1137 * cache line in one instruction.
1138 * So for a 2 char pattern, calling memchr() is likely to be
1139 * faster than running FBM, or rolling our own. The previous
1140 * version of this code was roll-your-own which typically
1141 * only needed to read every 2nd char, which was good back in
1142 * the day, but no longer.
1143 */
1144 unsigned char c1 = little[0];
1145 unsigned char c2 = little[1];
1146
1147 /* *** for all this case, bigend points to the last char,
1148 * not the trailing \0: this makes the conditions slightly
1149 * simpler */
1150 bigend--;
1151 s = big;
1152 if (c1 != c2) {
1153 while (s < bigend) {
1154 /* do a quick test for c1 before calling memchr();
1155 * this avoids the expensive fn call overhead when
1156 * there are lots of c1's */
1157 if (LIKELY(*s != c1)) {
1158 s++;
1159 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
1160 if (!s)
1161 break;
1162 }
1163 if (s[1] == c2)
1164 return (char*)s;
1165
1166 /* failed; try searching for c2 this time; that way
1167 * we don't go pathologically slow when the string
1168 * consists mostly of c1's or vice versa.
1169 */
1170 s += 2;
1171 if (s > bigend)
1172 break;
1173 s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
1174 if (!s)
1175 break;
1176 if (s[-1] == c1)
1177 return (char*)s - 1;
1178 }
1179 }
1180 else {
1181 /* c1, c2 the same */
1182 while (s < bigend) {
1183 if (s[0] == c1) {
1184 got_1char:
1185 if (s[1] == c1)
1186 return (char*)s;
1187 s += 2;
1188 }
1189 else {
1190 s++;
1191 s = (unsigned char *)memchr((void*)s, c1, bigend - s);
1192 if (!s || s >= bigend)
1193 break;
1194 goto got_1char;
1195 }
1196 }
1197 }
1198
1199 /* failed to find 2 chars; try anchored match at end without
1200 * the \n */
1201 if (tail && bigend[0] == little[0])
1202 return (char *)bigend;
1203 return NULL;
1204 }
1205
1206 default:
1207 break; /* Only lengths 0 1 and 2 have special-case code. */
1208 }
1209
1210 if (tail && !multiline) { /* tail anchored? */
1211 s = bigend - littlelen;
1212 if (s >= big && bigend[-1] == '\n' && *s == *little
1213 /* Automatically of length > 2 */
1214 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1215 {
1216 return (char*)s; /* how sweet it is */
1217 }
1218 if (s[1] == *little
1219 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
1220 {
1221 return (char*)s + 1; /* how sweet it is */
1222 }
1223 return NULL;
1224 }
1225
1226 if (!valid) {
1227 /* not compiled; use Perl_ninstr() instead */
1228 char * const b = ninstr((char*)big,(char*)bigend,
1229 (char*)little, (char*)little + littlelen);
1230
1231 assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
1232 return b;
1233 }
1234
1235 /* Do actual FBM. */
1236 if (littlelen > (STRLEN)(bigend - big))
1237 return NULL;
1238
1239 {
1240 const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
1241 const unsigned char *oldlittle;
1242
1243 assert(mg);
1244
1245 --littlelen; /* Last char found by table lookup */
1246
1247 s = big + littlelen;
1248 little += littlelen; /* last char */
1249 oldlittle = little;
1250 if (s < bigend) {
1251 const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
1252 const unsigned char lastc = *little;
1253 I32 tmp;
1254
1255 top2:
1256 if ((tmp = table[*s])) {
1257 /* *s != lastc; earliest position it could match now is
1258 * tmp slots further on */
1259 if ((s += tmp) >= bigend)
1260 goto check_end;
1261 if (LIKELY(*s != lastc)) {
1262 s++;
1263 s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
1264 if (!s) {
1265 s = bigend;
1266 goto check_end;
1267 }
1268 goto top2;
1269 }
1270 }
1271
1272
1273 /* hand-rolled strncmp(): less expensive than calling the
1274 * real function (maybe???) */
1275 {
1276 unsigned char * const olds = s;
1277
1278 tmp = littlelen;
1279
1280 while (tmp--) {
1281 if (*--s == *--little)
1282 continue;
1283 s = olds + 1; /* here we pay the price for failure */
1284 little = oldlittle;
1285 if (s < bigend) /* fake up continue to outer loop */
1286 goto top2;
1287 goto check_end;
1288 }
1289 return (char *)s;
1290 }
1291 }
1292 check_end:
1293 if ( s == bigend
1294 && tail
1295 && memEQ((char *)(bigend - littlelen),
1296 (char *)(oldlittle - littlelen), littlelen) )
1297 return (char*)bigend - littlelen;
1298 return NULL;
1299 }
1300}
1301
1302const char *
1303Perl_cntrl_to_mnemonic(const U8 c)
1304{
1305 /* Returns the mnemonic string that represents character 'c', if one
1306 * exists; NULL otherwise. The only ones that exist for the purposes of
1307 * this routine are a few control characters */
1308
1309 switch (c) {
1310 case '\a': return "\\a";
1311 case '\b': return "\\b";
1312 case ESC_NATIVE: return "\\e";
1313 case '\f': return "\\f";
1314 case '\n': return "\\n";
1315 case '\r': return "\\r";
1316 case '\t': return "\\t";
1317 }
1318
1319 return NULL;
1320}
1321
1322/* copy a string to a safe spot */
1323
1324/*
1325=for apidoc_section $string
1326=for apidoc savepv
1327
1328Perl's version of C<strdup()>. Returns a pointer to a newly allocated
1329string which is a duplicate of C<pv>. The size of the string is
1330determined by C<strlen()>, which means it may not contain embedded C<NUL>
1331characters and must have a trailing C<NUL>. To prevent memory leaks, the
1332memory allocated for the new string needs to be freed when no longer needed.
1333This can be done with the C<L</Safefree>> function, or
1334L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
1335
1336On some platforms, Windows for example, all allocated memory owned by a thread
1337is deallocated when that thread ends. So if you need that not to happen, you
1338need to use the shared memory functions, such as C<L</savesharedpv>>.
1339
1340=cut
1341*/
1342
1343char *
1344Perl_savepv(pTHX_ const char *pv)
1345{
1346 PERL_UNUSED_CONTEXT;
1347 if (!pv)
1348 return NULL;
1349 else {
1350 char *newaddr;
1351 const STRLEN pvlen = strlen(pv)+1;
1352 Newx(newaddr, pvlen, char);
1353 return (char*)memcpy(newaddr, pv, pvlen);
1354 }
1355}
1356
1357/* same thing but with a known length */
1358
1359/*
1360=for apidoc savepvn
1361
1362Perl's version of what C<strndup()> would be if it existed. Returns a
1363pointer to a newly allocated string which is a duplicate of the first
1364C<len> bytes from C<pv>, plus a trailing
1365C<NUL> byte. The memory allocated for
1366the new string can be freed with the C<Safefree()> function.
1367
1368On some platforms, Windows for example, all allocated memory owned by a thread
1369is deallocated when that thread ends. So if you need that not to happen, you
1370need to use the shared memory functions, such as C<L</savesharedpvn>>.
1371
1372=cut
1373*/
1374
1375char *
1376Perl_savepvn(pTHX_ const char *pv, Size_t len)
1377{
1378 char *newaddr;
1379 PERL_UNUSED_CONTEXT;
1380
1381 Newx(newaddr,len+1,char);
1382 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1383 if (pv) {
1384 /* might not be null terminated */
1385 newaddr[len] = '\0';
1386 return (char *) CopyD(pv,newaddr,len,char);
1387 }
1388 else {
1389 return (char *) ZeroD(newaddr,len+1,char);
1390 }
1391}
1392
1393/*
1394=for apidoc savesharedpv
1395
1396A version of C<savepv()> which allocates the duplicate string in memory
1397which is shared between threads.
1398
1399=cut
1400*/
1401char *
1402Perl_savesharedpv(pTHX_ const char *pv)
1403{
1404 char *newaddr;
1405 STRLEN pvlen;
1406
1407 PERL_UNUSED_CONTEXT;
1408
1409 if (!pv)
1410 return NULL;
1411
1412 pvlen = strlen(pv)+1;
1413 newaddr = (char*)PerlMemShared_malloc(pvlen);
1414 if (!newaddr) {
1415 croak_no_mem();
1416 }
1417 return (char*)memcpy(newaddr, pv, pvlen);
1418}
1419
1420/*
1421=for apidoc savesharedpvn
1422
1423A version of C<savepvn()> which allocates the duplicate string in memory
1424which is shared between threads. (With the specific difference that a C<NULL>
1425pointer is not acceptable)
1426
1427=cut
1428*/
1429char *
1430Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1431{
1432 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1433
1434 PERL_UNUSED_CONTEXT;
1435 /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1436
1437 if (!newaddr) {
1438 croak_no_mem();
1439 }
1440 newaddr[len] = '\0';
1441 return (char*)memcpy(newaddr, pv, len);
1442}
1443
1444/*
1445=for apidoc savesvpv
1446
1447A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1448the passed in SV using C<SvPV()>
1449
1450On some platforms, Windows for example, all allocated memory owned by a thread
1451is deallocated when that thread ends. So if you need that not to happen, you
1452need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1453
1454=cut
1455*/
1456
1457char *
1458Perl_savesvpv(pTHX_ SV *sv)
1459{
1460 STRLEN len;
1461 const char * const pv = SvPV_const(sv, len);
1462 char *newaddr;
1463
1464 PERL_ARGS_ASSERT_SAVESVPV;
1465
1466 ++len;
1467 Newx(newaddr,len,char);
1468 return (char *) CopyD(pv,newaddr,len,char);
1469}
1470
1471/*
1472=for apidoc savesharedsvpv
1473
1474A version of C<savesharedpv()> which allocates the duplicate string in
1475memory which is shared between threads.
1476
1477=cut
1478*/
1479
1480char *
1481Perl_savesharedsvpv(pTHX_ SV *sv)
1482{
1483 STRLEN len;
1484 const char * const pv = SvPV_const(sv, len);
1485
1486 PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1487
1488 return savesharedpvn(pv, len);
1489}
1490
1491/* the SV for Perl_form() and mess() is not kept in an arena */
1492
1493STATIC SV *
1494S_mess_alloc(pTHX)
1495{
1496 SV *sv;
1497 XPVMG *any;
1498
1499 if (PL_phase != PERL_PHASE_DESTRUCT)
1500 return newSVpvs_flags("", SVs_TEMP);
1501
1502 if (PL_mess_sv)
1503 return PL_mess_sv;
1504
1505 /* Create as PVMG now, to avoid any upgrading later */
1506 Newx(sv, 1, SV);
1507 Newxz(any, 1, XPVMG);
1508 SvFLAGS(sv) = SVt_PVMG;
1509 SvANY(sv) = (void*)any;
1510 SvPV_set(sv, NULL);
1511 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1512 PL_mess_sv = sv;
1513 return sv;
1514}
1515
1516#if defined(PERL_IMPLICIT_CONTEXT)
1517char *
1518Perl_form_nocontext(const char* pat, ...)
1519{
1520 dTHX;
1521 char *retval;
1522 va_list args;
1523 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1524 va_start(args, pat);
1525 retval = vform(pat, &args);
1526 va_end(args);
1527 return retval;
1528}
1529#endif /* PERL_IMPLICIT_CONTEXT */
1530
1531/*
1532=for apidoc_section $display
1533=for apidoc form
1534=for apidoc_item form_nocontext
1535
1536These take a sprintf-style format pattern and conventional
1537(non-SV) arguments and return the formatted string.
1538
1539 (char *) Perl_form(pTHX_ const char* pat, ...)
1540
1541can be used any place a string (char *) is required:
1542
1543 char * s = Perl_form("%d.%d",major,minor);
1544
1545They use a single (per-thread) private buffer so if you want to format several
1546strings you must explicitly copy the earlier strings away (and free the copies
1547when you are done).
1548
1549The two forms differ only in that C<form_nocontext> does not take a thread
1550context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1551already have the thread context.
1552
1553=for apidoc vform
1554Like C<L</form>> but but the arguments are an encapsulated argument list.
1555
1556=cut
1557*/
1558
1559char *
1560Perl_form(pTHX_ const char* pat, ...)
1561{
1562 char *retval;
1563 va_list args;
1564 PERL_ARGS_ASSERT_FORM;
1565 va_start(args, pat);
1566 retval = vform(pat, &args);
1567 va_end(args);
1568 return retval;
1569}
1570
1571char *
1572Perl_vform(pTHX_ const char *pat, va_list *args)
1573{
1574 SV * const sv = mess_alloc();
1575 PERL_ARGS_ASSERT_VFORM;
1576 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1577 return SvPVX(sv);
1578}
1579
1580/*
1581=for apidoc mess
1582=for apidoc_item mess_nocontext
1583
1584These take a sprintf-style format pattern and argument list, which are used to
1585generate a string message. If the message does not end with a newline, then it
1586will be extended with some indication of the current location in the code, as
1587described for C<L</mess_sv>>.
1588
1589Normally, the resulting message is returned in a new mortal SV.
1590But during global destruction a single SV may be shared between uses of
1591this function.
1592
1593The two forms differ only in that C<mess_nocontext> does not take a thread
1594context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1595already have the thread context.
1596
1597=cut
1598*/
1599
1600#if defined(PERL_IMPLICIT_CONTEXT)
1601SV *
1602Perl_mess_nocontext(const char *pat, ...)
1603{
1604 dTHX;
1605 SV *retval;
1606 va_list args;
1607 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1608 va_start(args, pat);
1609 retval = vmess(pat, &args);
1610 va_end(args);
1611 return retval;
1612}
1613#endif /* PERL_IMPLICIT_CONTEXT */
1614
1615SV *
1616Perl_mess(pTHX_ const char *pat, ...)
1617{
1618 SV *retval;
1619 va_list args;
1620 PERL_ARGS_ASSERT_MESS;
1621 va_start(args, pat);
1622 retval = vmess(pat, &args);
1623 va_end(args);
1624 return retval;
1625}
1626
1627const COP*
1628Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1629 bool opnext)
1630{
1631 /* Look for curop starting from o. cop is the last COP we've seen. */
1632 /* opnext means that curop is actually the ->op_next of the op we are
1633 seeking. */
1634
1635 PERL_ARGS_ASSERT_CLOSEST_COP;
1636
1637 if (!o || !curop || (
1638 opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1639 ))
1640 return cop;
1641
1642 if (o->op_flags & OPf_KIDS) {
1643 const OP *kid;
1644 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1645 const COP *new_cop;
1646
1647 /* If the OP_NEXTSTATE has been optimised away we can still use it
1648 * the get the file and line number. */
1649
1650 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1651 cop = (const COP *)kid;
1652
1653 /* Keep searching, and return when we've found something. */
1654
1655 new_cop = closest_cop(cop, kid, curop, opnext);
1656 if (new_cop)
1657 return new_cop;
1658 }
1659 }
1660
1661 /* Nothing found. */
1662
1663 return NULL;
1664}
1665
1666/*
1667=for apidoc mess_sv
1668
1669Expands a message, intended for the user, to include an indication of
1670the current location in the code, if the message does not already appear
1671to be complete.
1672
1673C<basemsg> is the initial message or object. If it is a reference, it
1674will be used as-is and will be the result of this function. Otherwise it
1675is used as a string, and if it already ends with a newline, it is taken
1676to be complete, and the result of this function will be the same string.
1677If the message does not end with a newline, then a segment such as C<at
1678foo.pl line 37> will be appended, and possibly other clauses indicating
1679the current state of execution. The resulting message will end with a
1680dot and a newline.
1681
1682Normally, the resulting message is returned in a new mortal SV.
1683During global destruction a single SV may be shared between uses of this
1684function. If C<consume> is true, then the function is permitted (but not
1685required) to modify and return C<basemsg> instead of allocating a new SV.
1686
1687=cut
1688*/
1689
1690SV *
1691Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1692{
1693 SV *sv;
1694
1695#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1696 {
1697 char *ws;
1698 UV wi;
1699 /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1700 if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1701 && grok_atoUV(ws, &wi, NULL)
1702 && wi <= PERL_INT_MAX
1703 ) {
1704 Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1705 }
1706 }
1707#endif
1708
1709 PERL_ARGS_ASSERT_MESS_SV;
1710
1711 if (SvROK(basemsg)) {
1712 if (consume) {
1713 sv = basemsg;
1714 }
1715 else {
1716 sv = mess_alloc();
1717 sv_setsv(sv, basemsg);
1718 }
1719 return sv;
1720 }
1721
1722 if (SvPOK(basemsg) && consume) {
1723 sv = basemsg;
1724 }
1725 else {
1726 sv = mess_alloc();
1727 sv_copypv(sv, basemsg);
1728 }
1729
1730 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1731 /*
1732 * Try and find the file and line for PL_op. This will usually be
1733 * PL_curcop, but it might be a cop that has been optimised away. We
1734 * can try to find such a cop by searching through the optree starting
1735 * from the sibling of PL_curcop.
1736 */
1737
1738 if (PL_curcop) {
1739 const COP *cop =
1740 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1741 if (!cop)
1742 cop = PL_curcop;
1743
1744 if (CopLINE(cop))
1745 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1746 OutCopFILE(cop), (IV)CopLINE(cop));
1747 }
1748
1749 /* Seems that GvIO() can be untrustworthy during global destruction. */
1750 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1751 && IoLINES(GvIOp(PL_last_in_gv)))
1752 {
1753 STRLEN l;
1754 const bool line_mode = (RsSIMPLE(PL_rs) &&
1755 *SvPV_const(PL_rs,l) == '\n' && l == 1);
1756 Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
1757 SVfARG(PL_last_in_gv == PL_argvgv
1758 ? &PL_sv_no
1759 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1760 line_mode ? "line" : "chunk",
1761 (IV)IoLINES(GvIOp(PL_last_in_gv)));
1762 }
1763 if (PL_phase == PERL_PHASE_DESTRUCT)
1764 sv_catpvs(sv, " during global destruction");
1765 sv_catpvs(sv, ".\n");
1766 }
1767 return sv;
1768}
1769
1770/*
1771=for apidoc vmess
1772
1773C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1774argument list, respectively. These are used to generate a string message. If
1775the
1776message does not end with a newline, then it will be extended with
1777some indication of the current location in the code, as described for
1778L</mess_sv>.
1779
1780Normally, the resulting message is returned in a new mortal SV.
1781During global destruction a single SV may be shared between uses of
1782this function.
1783
1784=cut
1785*/
1786
1787SV *
1788Perl_vmess(pTHX_ const char *pat, va_list *args)
1789{
1790 SV * const sv = mess_alloc();
1791
1792 PERL_ARGS_ASSERT_VMESS;
1793
1794 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1795 return mess_sv(sv, 1);
1796}
1797
1798void
1799Perl_write_to_stderr(pTHX_ SV* msv)
1800{
1801 IO *io;
1802 MAGIC *mg;
1803
1804 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1805
1806 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1807 && (io = GvIO(PL_stderrgv))
1808 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1809 Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1810 G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1811 else {
1812 PerlIO * const serr = Perl_error_log;
1813
1814 do_print(msv, serr);
1815 (void)PerlIO_flush(serr);
1816 }
1817}
1818
1819/*
1820=for apidoc_section $warning
1821*/
1822
1823/* Common code used in dieing and warning */
1824
1825STATIC SV *
1826S_with_queued_errors(pTHX_ SV *ex)
1827{
1828 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1829 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1830 sv_catsv(PL_errors, ex);
1831 ex = sv_mortalcopy(PL_errors);
1832 SvCUR_set(PL_errors, 0);
1833 }
1834 return ex;
1835}
1836
1837STATIC bool
1838S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1839{
1840 HV *stash;
1841 GV *gv;
1842 CV *cv;
1843 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1844 /* sv_2cv might call Perl_croak() or Perl_warner() */
1845 SV * const oldhook = *hook;
1846
1847 if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
1848 return FALSE;
1849
1850 ENTER;
1851 SAVESPTR(*hook);
1852 *hook = NULL;
1853 cv = sv_2cv(oldhook, &stash, &gv, 0);
1854 LEAVE;
1855 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1856 dSP;
1857 SV *exarg;
1858
1859 ENTER;
1860 save_re_context();
1861 if (warn) {
1862 SAVESPTR(*hook);
1863 *hook = NULL;
1864 }
1865 exarg = newSVsv(ex);
1866 SvREADONLY_on(exarg);
1867 SAVEFREESV(exarg);
1868
1869 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1870 PUSHMARK(SP);
1871 XPUSHs(exarg);
1872 PUTBACK;
1873 call_sv(MUTABLE_SV(cv), G_DISCARD);
1874 POPSTACK;
1875 LEAVE;
1876 return TRUE;
1877 }
1878 return FALSE;
1879}
1880
1881/*
1882=for apidoc die_sv
1883=for apidoc_item die_nocontext
1884
1885These ehave the same as L</croak_sv>, except for the return type.
1886It should be used only where the C<OP *> return type is required.
1887The functions never actually return.
1888
1889The two forms differ only in that C<die_nocontext> does not take a thread
1890context (C<aTHX>) parameter, so is used in situations where the caller doesn't
1891already have the thread context.
1892
1893=cut
1894*/
1895
1896/* silence __declspec(noreturn) warnings */
1897MSVC_DIAG_IGNORE(4646 4645)
1898OP *
1899Perl_die_sv(pTHX_ SV *baseex)
1900{
1901 PERL_ARGS_ASSERT_DIE_SV;
1902 croak_sv(baseex);
1903 /* NOTREACHED */
1904 NORETURN_FUNCTION_END;
1905}
1906MSVC_DIAG_RESTORE
1907
1908/*
1909=for apidoc die
1910
1911Behaves the same as L</croak>, except for the return type.
1912It should be used only where the C<OP *> return type is required.
1913The function never actually returns.
1914
1915=cut
1916*/
1917
1918#if defined(PERL_IMPLICIT_CONTEXT)
1919
1920/* silence __declspec(noreturn) warnings */
1921MSVC_DIAG_IGNORE(4646 4645)
1922OP *
1923Perl_die_nocontext(const char* pat, ...)
1924{
1925 dTHX;
1926 va_list args;
1927 va_start(args, pat);
1928 vcroak(pat, &args);
1929 NOT_REACHED; /* NOTREACHED */
1930 va_end(args);
1931 NORETURN_FUNCTION_END;
1932}
1933MSVC_DIAG_RESTORE
1934
1935#endif /* PERL_IMPLICIT_CONTEXT */
1936
1937/* silence __declspec(noreturn) warnings */
1938MSVC_DIAG_IGNORE(4646 4645)
1939OP *
1940Perl_die(pTHX_ const char* pat, ...)
1941{
1942 va_list args;
1943 va_start(args, pat);
1944 vcroak(pat, &args);
1945 NOT_REACHED; /* NOTREACHED */
1946 va_end(args);
1947 NORETURN_FUNCTION_END;
1948}
1949MSVC_DIAG_RESTORE
1950
1951/*
1952=for apidoc croak_sv
1953
1954This is an XS interface to Perl's C<die> function.
1955
1956C<baseex> is the error message or object. If it is a reference, it
1957will be used as-is. Otherwise it is used as a string, and if it does
1958not end with a newline then it will be extended with some indication of
1959the current location in the code, as described for L</mess_sv>.
1960
1961The error message or object will be used as an exception, by default
1962returning control to the nearest enclosing C<eval>, but subject to
1963modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1964function never returns normally.
1965
1966To die with a simple string message, the L</croak> function may be
1967more convenient.
1968
1969=cut
1970*/
1971
1972void
1973Perl_croak_sv(pTHX_ SV *baseex)
1974{
1975 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1976 PERL_ARGS_ASSERT_CROAK_SV;
1977 invoke_exception_hook(ex, FALSE);
1978 die_unwind(ex);
1979}
1980
1981/*
1982=for apidoc vcroak
1983
1984This is an XS interface to Perl's C<die> function.
1985
1986C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1987argument list. These are used to generate a string message. If the
1988message does not end with a newline, then it will be extended with
1989some indication of the current location in the code, as described for
1990L</mess_sv>.
1991
1992The error message will be used as an exception, by default
1993returning control to the nearest enclosing C<eval>, but subject to
1994modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1995function never returns normally.
1996
1997For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1998(C<$@>) will be used as an error message or object instead of building an
1999error message from arguments. If you want to throw a non-string object,
2000or build an error message in an SV yourself, it is preferable to use
2001the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
2002
2003=cut
2004*/
2005
2006void
2007Perl_vcroak(pTHX_ const char* pat, va_list *args)
2008{
2009 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
2010 invoke_exception_hook(ex, FALSE);
2011 die_unwind(ex);
2012}
2013
2014/*
2015=for apidoc croak
2016=for apidoc_item croak_nocontext
2017
2018These are XS interfaces to Perl's C<die> function.
2019
2020They take a sprintf-style format pattern and argument list, which are used to
2021generate a string message. If the message does not end with a newline, then it
2022will be extended with some indication of the current location in the code, as
2023described for C<L</mess_sv>>.
2024
2025The error message will be used as an exception, by default
2026returning control to the nearest enclosing C<eval>, but subject to
2027modification by a C<$SIG{__DIE__}> handler. In any case, these croak
2028functions never return normally.
2029
2030For historical reasons, if C<pat> is null then the contents of C<ERRSV>
2031(C<$@>) will be used as an error message or object instead of building an
2032error message from arguments. If you want to throw a non-string object,
2033or build an error message in an SV yourself, it is preferable to use
2034the C<L</croak_sv>> function, which does not involve clobbering C<ERRSV>.
2035
2036The two forms differ only in that C<croak_nocontext> does not take a thread
2037context (C<aTHX>) parameter. It is usually preferred as it takes up fewer
2038bytes of code than plain C<Perl_croak>, and time is rarely a critical resource
2039when you are about to throw an exception.
2040
2041=cut
2042*/
2043
2044#if defined(PERL_IMPLICIT_CONTEXT)
2045void
2046Perl_croak_nocontext(const char *pat, ...)
2047{
2048 dTHX;
2049 va_list args;
2050 va_start(args, pat);
2051 vcroak(pat, &args);
2052 NOT_REACHED; /* NOTREACHED */
2053 va_end(args);
2054}
2055#endif /* PERL_IMPLICIT_CONTEXT */
2056
2057/* saves machine code for a common noreturn idiom typically used in Newx*() */
2058GCC_DIAG_IGNORE_DECL(-Wunused-function);
2059void
2060Perl_croak_memory_wrap(void)
2061{
2062 Perl_croak_nocontext("%s",PL_memory_wrap);
2063}
2064GCC_DIAG_RESTORE_DECL;
2065
2066void
2067Perl_croak(pTHX_ const char *pat, ...)
2068{
2069 va_list args;
2070 va_start(args, pat);
2071 vcroak(pat, &args);
2072 NOT_REACHED; /* NOTREACHED */
2073 va_end(args);
2074}
2075
2076/*
2077=for apidoc croak_no_modify
2078
2079This encapsulates a common reason for dying, generating terser object code than
2080using the generic C<Perl_croak>. It is exactly equivalent to
2081C<Perl_croak(aTHX_ "%s", PL_no_modify)> (which expands to something like
2082"Modification of a read-only value attempted").
2083
2084Less code used on exception code paths reduces CPU cache pressure.
2085
2086=cut
2087*/
2088
2089void
2090Perl_croak_no_modify(void)
2091{
2092 Perl_croak_nocontext( "%s", PL_no_modify);
2093}
2094
2095/* does not return, used in util.c perlio.c and win32.c
2096 This is typically called when malloc returns NULL.
2097*/
2098void
2099Perl_croak_no_mem(void)
2100{
2101 dTHX;
2102
2103 int fd = PerlIO_fileno(Perl_error_log);
2104 if (fd < 0)
2105 SETERRNO(EBADF,RMS_IFI);
2106 else {
2107 /* Can't use PerlIO to write as it allocates memory */
2108 PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
2109 }
2110 my_exit(1);
2111}
2112
2113/* does not return, used only in POPSTACK */
2114void
2115Perl_croak_popstack(void)
2116{
2117 dTHX;
2118 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
2119 my_exit(1);
2120}
2121
2122/*
2123=for apidoc warn_sv
2124
2125This is an XS interface to Perl's C<warn> function.
2126
2127C<baseex> is the error message or object. If it is a reference, it
2128will be used as-is. Otherwise it is used as a string, and if it does
2129not end with a newline then it will be extended with some indication of
2130the current location in the code, as described for L</mess_sv>.
2131
2132The error message or object will by default be written to standard error,
2133but this is subject to modification by a C<$SIG{__WARN__}> handler.
2134
2135To warn with a simple string message, the L</warn> function may be
2136more convenient.
2137
2138=cut
2139*/
2140
2141void
2142Perl_warn_sv(pTHX_ SV *baseex)
2143{
2144 SV *ex = mess_sv(baseex, 0);
2145 PERL_ARGS_ASSERT_WARN_SV;
2146 if (!invoke_exception_hook(ex, TRUE))
2147 write_to_stderr(ex);
2148}
2149
2150/*
2151=for apidoc vwarn
2152
2153This is an XS interface to Perl's C<warn> function.
2154
2155This is like C<L</warn>>, but C<args> are an encapsulated
2156argument list.
2157
2158Unlike with L</vcroak>, C<pat> is not permitted to be null.
2159
2160=cut
2161*/
2162
2163void
2164Perl_vwarn(pTHX_ const char* pat, va_list *args)
2165{
2166 SV *ex = vmess(pat, args);
2167 PERL_ARGS_ASSERT_VWARN;
2168 if (!invoke_exception_hook(ex, TRUE))
2169 write_to_stderr(ex);
2170}
2171
2172/*
2173=for apidoc warn
2174=for apidoc_item warn_nocontext
2175
2176These are XS interfaces to Perl's C<warn> function.
2177
2178They take a sprintf-style format pattern and argument list, which are used to
2179generate a string message. If the message does not end with a newline, then it
2180will be extended with some indication of the current location in the code, as
2181described for C<L</mess_sv>>.
2182
2183The error message or object will by default be written to standard error,
2184but this is subject to modification by a C<$SIG{__WARN__}> handler.
2185
2186Unlike with C<L</croak>>, C<pat> is not permitted to be null.
2187
2188The two forms differ only in that C<warn_nocontext> does not take a thread
2189context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2190already have the thread context.
2191
2192=cut
2193*/
2194
2195#if defined(PERL_IMPLICIT_CONTEXT)
2196void
2197Perl_warn_nocontext(const char *pat, ...)
2198{
2199 dTHX;
2200 va_list args;
2201 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
2202 va_start(args, pat);
2203 vwarn(pat, &args);
2204 va_end(args);
2205}
2206#endif /* PERL_IMPLICIT_CONTEXT */
2207
2208void
2209Perl_warn(pTHX_ const char *pat, ...)
2210{
2211 va_list args;
2212 PERL_ARGS_ASSERT_WARN;
2213 va_start(args, pat);
2214 vwarn(pat, &args);
2215 va_end(args);
2216}
2217
2218/*
2219=for apidoc warner
2220=for apidoc_item warner_nocontext
2221
2222These output a warning of the specified category (or categories) given by
2223C<err>, using the sprintf-style format pattern C<pat>, and argument list.
2224
2225C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2226C<packWARN4> macros populated with the appropriate number of warning
2227categories. If any of the warning categories they specify is fatal, a fatal
2228exception is thrown.
2229
2230In any event a message is generated by the pattern and arguments. If the
2231message does not end with a newline, then it will be extended with some
2232indication of the current location in the code, as described for L</mess_sv>.
2233
2234The error message or object will by default be written to standard error,
2235but this is subject to modification by a C<$SIG{__WARN__}> handler.
2236
2237C<pat> is not permitted to be null.
2238
2239The two forms differ only in that C<warner_nocontext> does not take a thread
2240context (C<aTHX>) parameter, so is used in situations where the caller doesn't
2241already have the thread context.
2242
2243These functions differ from the similarly named C<L</warn>> functions, in that
2244the latter are for XS code to unconditionally display a warning, whereas these
2245are for code that may be compiling a perl program, and does extra checking to
2246see if the warning should be fatal.
2247
2248=for apidoc ck_warner
2249=for apidoc_item ck_warner_d
2250If none of the warning categories given by C<err> are enabled, do nothing;
2251otherwise call C<L</warner>> or C<L</warner_nocontext>> with the passed-in
2252parameters;.
2253
2254C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
2255C<packWARN4> macros populated with the appropriate number of warning
2256categories.
2257
2258The two forms differ only in that C<ck_warner_d> should be used if warnings for
2259any of the categories are by default enabled.
2260
2261=for apidoc vwarner
2262This is like C<L</warner>>, but C<args> are an encapsulated argument list.
2263
2264=cut
2265*/
2266
2267#if defined(PERL_IMPLICIT_CONTEXT)
2268void
2269Perl_warner_nocontext(U32 err, const char *pat, ...)
2270{
2271 dTHX;
2272 va_list args;
2273 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
2274 va_start(args, pat);
2275 vwarner(err, pat, &args);
2276 va_end(args);
2277}
2278#endif /* PERL_IMPLICIT_CONTEXT */
2279
2280void
2281Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2282{
2283 PERL_ARGS_ASSERT_CK_WARNER_D;
2284
2285 if (Perl_ckwarn_d(aTHX_ err)) {
2286 va_list args;
2287 va_start(args, pat);
2288 vwarner(err, pat, &args);
2289 va_end(args);
2290 }
2291}
2292
2293void
2294Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2295{
2296 PERL_ARGS_ASSERT_CK_WARNER;
2297
2298 if (Perl_ckwarn(aTHX_ err)) {
2299 va_list args;
2300 va_start(args, pat);
2301 vwarner(err, pat, &args);
2302 va_end(args);
2303 }
2304}
2305
2306void
2307Perl_warner(pTHX_ U32 err, const char* pat,...)
2308{
2309 va_list args;
2310 PERL_ARGS_ASSERT_WARNER;
2311 va_start(args, pat);
2312 vwarner(err, pat, &args);
2313 va_end(args);
2314}
2315
2316void
2317Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
2318{
2319 PERL_ARGS_ASSERT_VWARNER;
2320 if (
2321 (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2322 !(PL_in_eval & EVAL_KEEPERR)
2323 ) {
2324 SV * const msv = vmess(pat, args);
2325
2326 if (PL_parser && PL_parser->error_count) {
2327 qerror(msv);
2328 }
2329 else {
2330 invoke_exception_hook(msv, FALSE);
2331 die_unwind(msv);
2332 }
2333 }
2334 else {
2335 Perl_vwarn(aTHX_ pat, args);
2336 }
2337}
2338
2339/* implements the ckWARN? macros */
2340
2341bool
2342Perl_ckwarn(pTHX_ U32 w)
2343{
2344 /* If lexical warnings have not been set, use $^W. */
2345 if (isLEXWARN_off)
2346 return PL_dowarn & G_WARN_ON;
2347
2348 return ckwarn_common(w);
2349}
2350
2351/* implements the ckWARN?_d macro */
2352
2353bool
2354Perl_ckwarn_d(pTHX_ U32 w)
2355{
2356 /* If lexical warnings have not been set then default classes warn. */
2357 if (isLEXWARN_off)
2358 return TRUE;
2359
2360 return ckwarn_common(w);
2361}
2362
2363static bool
2364S_ckwarn_common(pTHX_ U32 w)
2365{
2366 if (PL_curcop->cop_warnings == pWARN_ALL)
2367 return TRUE;
2368
2369 if (PL_curcop->cop_warnings == pWARN_NONE)
2370 return FALSE;
2371
2372 /* Check the assumption that at least the first slot is non-zero. */
2373 assert(unpackWARN1(w));
2374
2375 /* Check the assumption that it is valid to stop as soon as a zero slot is
2376 seen. */
2377 if (!unpackWARN2(w)) {
2378 assert(!unpackWARN3(w));
2379 assert(!unpackWARN4(w));
2380 } else if (!unpackWARN3(w)) {
2381 assert(!unpackWARN4(w));
2382 }
2383
2384 /* Right, dealt with all the special cases, which are implemented as non-
2385 pointers, so there is a pointer to a real warnings mask. */
2386 do {
2387 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2388 return TRUE;
2389 } while (w >>= WARNshift);
2390
2391 return FALSE;
2392}
2393
2394/* Set buffer=NULL to get a new one. */
2395STRLEN *
2396Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2397 STRLEN size) {
2398 const MEM_SIZE len_wanted =
2399 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2400 PERL_UNUSED_CONTEXT;
2401 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2402
2403 buffer = (STRLEN*)
2404 (specialWARN(buffer) ?
2405 PerlMemShared_malloc(len_wanted) :
2406 PerlMemShared_realloc(buffer, len_wanted));
2407 buffer[0] = size;
2408 Copy(bits, (buffer + 1), size, char);
2409 if (size < WARNsize)
2410 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2411 return buffer;
2412}
2413
2414/* since we've already done strlen() for both nam and val
2415 * we can use that info to make things faster than
2416 * sprintf(s, "%s=%s", nam, val)
2417 */
2418#define my_setenv_format(s, nam, nlen, val, vlen) \
2419 Copy(nam, s, nlen, char); \
2420 *(s+nlen) = '='; \
2421 Copy(val, s+(nlen+1), vlen, char); \
2422 *(s+(nlen+1+vlen)) = '\0'
2423
2424
2425
2426#ifdef USE_ENVIRON_ARRAY
2427/* NB: VMS' my_setenv() is in vms.c */
2428
2429/* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
2430 * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
2431 * testing for HAS UNSETENV is sufficient.
2432 */
2433# if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2434# define MY_HAS_SETENV
2435# endif
2436
2437/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
2438 * 'current' is non-null, with up to three sizes that are added together.
2439 * It handles integer overflow.
2440 */
2441# ifndef MY_HAS_SETENV
2442static char *
2443S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
2444{
2445 void *p;
2446 Size_t sl, l = l1 + l2;
2447
2448 if (l < l2)
2449 goto panic;
2450 l += l3;
2451 if (l < l3)
2452 goto panic;
2453 sl = l * size;
2454 if (sl < l)
2455 goto panic;
2456
2457 p = current
2458 ? safesysrealloc(current, sl)
2459 : safesysmalloc(sl);
2460 if (p)
2461 return (char*)p;
2462
2463 panic:
2464 croak_memory_wrap();
2465}
2466# endif
2467
2468
2469# if !defined(WIN32) && !defined(NETWARE)
2470
2471/*
2472=for apidoc_section $utility
2473=for apidoc my_setenv
2474
2475A wrapper for the C library L<setenv(3)>. Don't use the latter, as the perl
2476version has desirable safeguards
2477
2478=cut
2479*/
2480
2481void
2482Perl_my_setenv(pTHX_ const char *nam, const char *val)
2483{
2484# ifdef __amigaos4__
2485 amigaos4_obtain_environ(__FUNCTION__);
2486# endif
2487
2488# ifdef USE_ITHREADS
2489 /* only parent thread can modify process environment, so no need to use a
2490 * mutex */
2491 if (PL_curinterp == aTHX)
2492# endif
2493 {
2494
2495# ifndef PERL_USE_SAFE_PUTENV
2496 if (!PL_use_safe_putenv) {
2497 /* most putenv()s leak, so we manipulate environ directly */
2498 UV i;
2499 Size_t vlen, nlen = strlen(nam);
2500
2501 /* where does it go? */
2502 for (i = 0; environ[i]; i++) {
2503 if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
2504 break;
2505 }
2506
2507 if (environ == PL_origenviron) { /* need we copy environment? */
2508 UV j, max;
2509 char **tmpenv;
2510
2511 max = i;
2512 while (environ[max])
2513 max++;
2514
2515 /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
2516 tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
2517
2518 for (j=0; j<max; j++) { /* copy environment */
2519 const Size_t len = strlen(environ[j]);
2520 tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
2521 Copy(environ[j], tmpenv[j], len+1, char);
2522 }
2523
2524 tmpenv[max] = NULL;
2525 environ = tmpenv; /* tell exec where it is now */
2526 }
2527
2528 if (!val) {
2529 safesysfree(environ[i]);
2530 while (environ[i]) {
2531 environ[i] = environ[i+1];
2532 i++;
2533 }
2534# ifdef __amigaos4__
2535 goto my_setenv_out;
2536# else
2537 return;
2538# endif
2539 }
2540
2541 if (!environ[i]) { /* does not exist yet */
2542 environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
2543 environ[i+1] = NULL; /* make sure it's null terminated */
2544 }
2545 else
2546 safesysfree(environ[i]);
2547
2548 vlen = strlen(val);
2549
2550 environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
2551 /* all that work just for this */
2552 my_setenv_format(environ[i], nam, nlen, val, vlen);
2553 }
2554 else {
2555
2556# endif /* !PERL_USE_SAFE_PUTENV */
2557
2558# ifdef MY_HAS_SETENV
2559# if defined(HAS_UNSETENV)
2560 if (val == NULL) {
2561 (void)unsetenv(nam);
2562 } else {
2563 (void)setenv(nam, val, 1);
2564 }
2565# else /* ! HAS_UNSETENV */
2566 (void)setenv(nam, val, 1);
2567# endif /* HAS_UNSETENV */
2568
2569# elif defined(HAS_UNSETENV)
2570
2571 if (val == NULL) {
2572 if (environ) /* old glibc can crash with null environ */
2573 (void)unsetenv(nam);
2574 } else {
2575 const Size_t nlen = strlen(nam);
2576 const Size_t vlen = strlen(val);
2577 char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
2578 my_setenv_format(new_env, nam, nlen, val, vlen);
2579 (void)putenv(new_env);
2580 }
2581
2582# else /* ! HAS_UNSETENV */
2583
2584 char *new_env;
2585 const Size_t nlen = strlen(nam);
2586 Size_t vlen;
2587 if (!val) {
2588 val = "";
2589 }
2590 vlen = strlen(val);
2591 new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
2592 /* all that work just for this */
2593 my_setenv_format(new_env, nam, nlen, val, vlen);
2594 (void)putenv(new_env);
2595
2596# endif /* MY_HAS_SETENV */
2597
2598# ifndef PERL_USE_SAFE_PUTENV
2599 }
2600# endif
2601 }
2602
2603# ifdef __amigaos4__
2604my_setenv_out:
2605 amigaos4_release_environ(__FUNCTION__);
2606# endif
2607}
2608
2609# else /* WIN32 || NETWARE */
2610
2611void
2612Perl_my_setenv(pTHX_ const char *nam, const char *val)
2613{
2614 char *envstr;
2615 const Size_t nlen = strlen(nam);
2616 Size_t vlen;
2617
2618 if (!val) {
2619 val = "";
2620 }
2621 vlen = strlen(val);
2622 envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
2623 my_setenv_format(envstr, nam, nlen, val, vlen);
2624 (void)PerlEnv_putenv(envstr);
2625 safesysfree(envstr);
2626}
2627
2628# endif /* WIN32 || NETWARE */
2629
2630#endif /* USE_ENVIRON_ARRAY */
2631
2632
2633
2634
2635#ifdef UNLINK_ALL_VERSIONS
2636I32
2637Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2638{
2639 I32 retries = 0;
2640
2641 PERL_ARGS_ASSERT_UNLNK;
2642
2643 while (PerlLIO_unlink(f) >= 0)
2644 retries++;
2645 return retries ? 0 : -1;
2646}
2647#endif
2648
2649PerlIO *
2650Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2651{
2652#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2653 int p[2];
2654 I32 This, that;
2655 Pid_t pid;
2656 SV *sv;
2657 I32 did_pipes = 0;
2658 int pp[2];
2659
2660 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2661
2662 PERL_FLUSHALL_FOR_CHILD;
2663 This = (*mode == 'w');
2664 that = !This;
2665 if (TAINTING_get) {
2666 taint_env();
2667 taint_proper("Insecure %s%s", "EXEC");
2668 }
2669 if (PerlProc_pipe_cloexec(p) < 0)
2670 return NULL;
2671 /* Try for another pipe pair for error return */
2672 if (PerlProc_pipe_cloexec(pp) >= 0)
2673 did_pipes = 1;
2674 while ((pid = PerlProc_fork()) < 0) {
2675 if (errno != EAGAIN) {
2676 PerlLIO_close(p[This]);
2677 PerlLIO_close(p[that]);
2678 if (did_pipes) {
2679 PerlLIO_close(pp[0]);
2680 PerlLIO_close(pp[1]);
2681 }
2682 return NULL;
2683 }
2684 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2685 sleep(5);
2686 }
2687 if (pid == 0) {
2688 /* Child */
2689#undef THIS
2690#undef THAT
2691#define THIS that
2692#define THAT This
2693 /* Close parent's end of error status pipe (if any) */
2694 if (did_pipes)
2695 PerlLIO_close(pp[0]);
2696 /* Now dup our end of _the_ pipe to right position */
2697 if (p[THIS] != (*mode == 'r')) {
2698 PerlLIO_dup2(p[THIS], *mode == 'r');
2699 PerlLIO_close(p[THIS]);
2700 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2701 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2702 }
2703 else {
2704 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
2705 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2706 }
2707#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2708 /* No automatic close - do it by hand */
2709# ifndef NOFILE
2710# define NOFILE 20
2711# endif
2712 {
2713 int fd;
2714
2715 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2716 if (fd != pp[1])
2717 PerlLIO_close(fd);
2718 }
2719 }
2720#endif
2721 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2722 PerlProc__exit(1);
2723#undef THIS
2724#undef THAT
2725 }
2726 /* Parent */
2727 if (did_pipes)
2728 PerlLIO_close(pp[1]);
2729 /* Keep the lower of the two fd numbers */
2730 if (p[that] < p[This]) {
2731 PerlLIO_dup2_cloexec(p[This], p[that]);
2732 PerlLIO_close(p[This]);
2733 p[This] = p[that];
2734 }
2735 else
2736 PerlLIO_close(p[that]); /* close child's end of pipe */
2737
2738 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2739 SvUPGRADE(sv,SVt_IV);
2740 SvIV_set(sv, pid);
2741 PL_forkprocess = pid;
2742 /* If we managed to get status pipe check for exec fail */
2743 if (did_pipes && pid > 0) {
2744 int errkid;
2745 unsigned read_total = 0;
2746
2747 while (read_total < sizeof(int)) {
2748 const SSize_t n1 = PerlLIO_read(pp[0],
2749 (void*)(((char*)&errkid)+read_total),
2750 (sizeof(int)) - read_total);
2751 if (n1 <= 0)
2752 break;
2753 read_total += n1;
2754 }
2755 PerlLIO_close(pp[0]);
2756 did_pipes = 0;
2757 if (read_total) { /* Error */
2758 int pid2, status;
2759 PerlLIO_close(p[This]);
2760 if (read_total != sizeof(int))
2761 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
2762 do {
2763 pid2 = wait4pid(pid, &status, 0);
2764 } while (pid2 == -1 && errno == EINTR);
2765 errno = errkid; /* Propagate errno from kid */
2766 return NULL;
2767 }
2768 }
2769 if (did_pipes)
2770 PerlLIO_close(pp[0]);
2771 return PerlIO_fdopen(p[This], mode);
2772#else
2773# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
2774 return my_syspopen4(aTHX_ NULL, mode, n, args);
2775# elif defined(WIN32)
2776 return win32_popenlist(mode, n, args);
2777# else
2778 Perl_croak(aTHX_ "List form of piped open not implemented");
2779 return (PerlIO *) NULL;
2780# endif
2781#endif
2782}
2783
2784 /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2785#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2786PerlIO *
2787Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2788{
2789 int p[2];
2790 I32 This, that;
2791 Pid_t pid;
2792 SV *sv;
2793 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2794 I32 did_pipes = 0;
2795 int pp[2];
2796
2797 PERL_ARGS_ASSERT_MY_POPEN;
2798
2799 PERL_FLUSHALL_FOR_CHILD;
2800#ifdef OS2
2801 if (doexec) {
2802 return my_syspopen(aTHX_ cmd,mode);
2803 }
2804#endif
2805 This = (*mode == 'w');
2806 that = !This;
2807 if (doexec && TAINTING_get) {
2808 taint_env();
2809 taint_proper("Insecure %s%s", "EXEC");
2810 }
2811 if (PerlProc_pipe_cloexec(p) < 0)
2812 return NULL;
2813 if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
2814 did_pipes = 1;
2815 while ((pid = PerlProc_fork()) < 0) {
2816 if (errno != EAGAIN) {
2817 PerlLIO_close(p[This]);
2818 PerlLIO_close(p[that]);
2819 if (did_pipes) {
2820 PerlLIO_close(pp[0]);
2821 PerlLIO_close(pp[1]);
2822 }
2823 if (!doexec)
2824 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2825 return NULL;
2826 }
2827 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2828 sleep(5);
2829 }
2830 if (pid == 0) {
2831
2832#undef THIS
2833#undef THAT
2834#define THIS that
2835#define THAT This
2836 if (did_pipes)
2837 PerlLIO_close(pp[0]);
2838 if (p[THIS] != (*mode == 'r')) {
2839 PerlLIO_dup2(p[THIS], *mode == 'r');
2840 PerlLIO_close(p[THIS]);
2841 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2842 PerlLIO_close(p[THAT]);
2843 }
2844 else {
2845 setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
2846 PerlLIO_close(p[THAT]);
2847 }
2848#ifndef OS2
2849 if (doexec) {
2850#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2851#ifndef NOFILE
2852#define NOFILE 20
2853#endif
2854 {
2855 int fd;
2856
2857 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2858 if (fd != pp[1])
2859 PerlLIO_close(fd);
2860 }
2861#endif
2862 /* may or may not use the shell */
2863 do_exec3(cmd, pp[1], did_pipes);
2864 PerlProc__exit(1);
2865 }
2866#endif /* defined OS2 */
2867
2868#ifdef PERLIO_USING_CRLF
2869 /* Since we circumvent IO layers when we manipulate low-level
2870 filedescriptors directly, need to manually switch to the
2871 default, binary, low-level mode; see PerlIOBuf_open(). */
2872 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2873#endif
2874 PL_forkprocess = 0;
2875#ifdef PERL_USES_PL_PIDSTATUS
2876 hv_clear(PL_pidstatus); /* we have no children */
2877#endif
2878 return NULL;
2879#undef THIS
2880#undef THAT
2881 }
2882 if (did_pipes)
2883 PerlLIO_close(pp[1]);
2884 if (p[that] < p[This]) {
2885 PerlLIO_dup2_cloexec(p[This], p[that]);
2886 PerlLIO_close(p[This]);
2887 p[This] = p[that];
2888 }
2889 else
2890 PerlLIO_close(p[that]);
2891
2892 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2893 SvUPGRADE(sv,SVt_IV);
2894 SvIV_set(sv, pid);
2895 PL_forkprocess = pid;
2896 if (did_pipes && pid > 0) {
2897 int errkid;
2898 unsigned n = 0;
2899
2900 while (n < sizeof(int)) {
2901 const SSize_t n1 = PerlLIO_read(pp[0],
2902 (void*)(((char*)&errkid)+n),
2903 (sizeof(int)) - n);
2904 if (n1 <= 0)
2905 break;
2906 n += n1;
2907 }
2908 PerlLIO_close(pp[0]);
2909 did_pipes = 0;
2910 if (n) { /* Error */
2911 int pid2, status;
2912 PerlLIO_close(p[This]);
2913 if (n != sizeof(int))
2914 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2915 do {
2916 pid2 = wait4pid(pid, &status, 0);
2917 } while (pid2 == -1 && errno == EINTR);
2918 errno = errkid; /* Propagate errno from kid */
2919 return NULL;
2920 }
2921 }
2922 if (did_pipes)
2923 PerlLIO_close(pp[0]);
2924 return PerlIO_fdopen(p[This], mode);
2925}
2926#elif defined(DJGPP)
2927FILE *djgpp_popen();
2928PerlIO *
2929Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2930{
2931 PERL_FLUSHALL_FOR_CHILD;
2932 /* Call system's popen() to get a FILE *, then import it.
2933 used 0 for 2nd parameter to PerlIO_importFILE;
2934 apparently not used
2935 */
2936 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2937}
2938#elif defined(__LIBCATAMOUNT__)
2939PerlIO *
2940Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2941{
2942 return NULL;
2943}
2944
2945#endif /* !DOSISH */
2946
2947/* this is called in parent before the fork() */
2948void
2949Perl_atfork_lock(void)
2950#if defined(USE_ITHREADS)
2951# ifdef USE_PERLIO
2952 PERL_TSA_ACQUIRE(PL_perlio_mutex)
2953# endif
2954# ifdef MYMALLOC
2955 PERL_TSA_ACQUIRE(PL_malloc_mutex)
2956# endif
2957 PERL_TSA_ACQUIRE(PL_op_mutex)
2958#endif
2959{
2960#if defined(USE_ITHREADS)
2961 /* locks must be held in locking order (if any) */
2962# ifdef USE_PERLIO
2963 MUTEX_LOCK(&PL_perlio_mutex);
2964# endif
2965# ifdef MYMALLOC
2966 MUTEX_LOCK(&PL_malloc_mutex);
2967# endif
2968 OP_REFCNT_LOCK;
2969#endif
2970}
2971
2972/* this is called in both parent and child after the fork() */
2973void
2974Perl_atfork_unlock(void)
2975#if defined(USE_ITHREADS)
2976# ifdef USE_PERLIO
2977 PERL_TSA_RELEASE(PL_perlio_mutex)
2978# endif
2979# ifdef MYMALLOC
2980 PERL_TSA_RELEASE(PL_malloc_mutex)
2981# endif
2982 PERL_TSA_RELEASE(PL_op_mutex)
2983#endif
2984{
2985#if defined(USE_ITHREADS)
2986 /* locks must be released in same order as in atfork_lock() */
2987# ifdef USE_PERLIO
2988 MUTEX_UNLOCK(&PL_perlio_mutex);
2989# endif
2990# ifdef MYMALLOC
2991 MUTEX_UNLOCK(&PL_malloc_mutex);
2992# endif
2993 OP_REFCNT_UNLOCK;
2994#endif
2995}
2996
2997Pid_t
2998Perl_my_fork(void)
2999{
3000#if defined(HAS_FORK)
3001 Pid_t pid;
3002#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
3003 atfork_lock();
3004 pid = fork();
3005 atfork_unlock();
3006#else
3007 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
3008 * handlers elsewhere in the code */
3009 pid = fork();
3010#endif
3011 return pid;
3012#elif defined(__amigaos4__)
3013 return amigaos_fork();
3014#else
3015 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
3016 Perl_croak_nocontext("fork() not available");
3017 return 0;
3018#endif /* HAS_FORK */
3019}
3020
3021#ifndef HAS_DUP2
3022int
3023dup2(int oldfd, int newfd)
3024{
3025#if defined(HAS_FCNTL) && defined(F_DUPFD)
3026 if (oldfd == newfd)
3027 return oldfd;
3028 PerlLIO_close(newfd);
3029 return fcntl(oldfd, F_DUPFD, newfd);
3030#else
3031#define DUP2_MAX_FDS 256
3032 int fdtmp[DUP2_MAX_FDS];
3033 I32 fdx = 0;
3034 int fd;
3035
3036 if (oldfd == newfd)
3037 return oldfd;
3038 PerlLIO_close(newfd);
3039 /* good enough for low fd's... */
3040 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
3041 if (fdx >= DUP2_MAX_FDS) {
3042 PerlLIO_close(fd);
3043 fd = -1;
3044 break;
3045 }
3046 fdtmp[fdx++] = fd;
3047 }
3048 while (fdx > 0)
3049 PerlLIO_close(fdtmp[--fdx]);
3050 return fd;
3051#endif
3052}
3053#endif
3054
3055#ifndef PERL_MICRO
3056#ifdef HAS_SIGACTION
3057
3058/*
3059=for apidoc_section $signals
3060=for apidoc rsignal
3061
3062A wrapper for the C library L<signal(2)>. Don't use the latter, as the Perl
3063version knows things that interact with the rest of the perl interpreter.
3064
3065=cut
3066*/
3067
3068Sighandler_t
3069Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3070{
3071 struct sigaction act, oact;
3072
3073#ifdef USE_ITHREADS
3074 /* only "parent" interpreter can diddle signals */
3075 if (PL_curinterp != aTHX)
3076 return (Sighandler_t) SIG_ERR;
3077#endif
3078
3079 act.sa_handler = handler;
3080 sigemptyset(&act.sa_mask);
3081 act.sa_flags = 0;
3082#ifdef SA_RESTART
3083 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3084 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3085#endif
3086#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3087 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3088 act.sa_flags |= SA_NOCLDWAIT;
3089#endif
3090 if (sigaction(signo, &act, &oact) == -1)
3091 return (Sighandler_t) SIG_ERR;
3092 else
3093 return (Sighandler_t) oact.sa_handler;
3094}
3095
3096Sighandler_t
3097Perl_rsignal_state(pTHX_ int signo)
3098{
3099 struct sigaction oact;
3100 PERL_UNUSED_CONTEXT;
3101
3102 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3103 return (Sighandler_t) SIG_ERR;
3104 else
3105 return (Sighandler_t) oact.sa_handler;
3106}
3107
3108int
3109Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3110{
3111 struct sigaction act;
3112
3113 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
3114
3115#ifdef USE_ITHREADS
3116 /* only "parent" interpreter can diddle signals */
3117 if (PL_curinterp != aTHX)
3118 return -1;
3119#endif
3120
3121 act.sa_handler = handler;
3122 sigemptyset(&act.sa_mask);
3123 act.sa_flags = 0;
3124#ifdef SA_RESTART
3125 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3126 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
3127#endif
3128#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
3129 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
3130 act.sa_flags |= SA_NOCLDWAIT;
3131#endif
3132 return sigaction(signo, &act, save);
3133}
3134
3135int
3136Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3137{
3138 PERL_UNUSED_CONTEXT;
3139#ifdef USE_ITHREADS
3140 /* only "parent" interpreter can diddle signals */
3141 if (PL_curinterp != aTHX)
3142 return -1;
3143#endif
3144
3145 return sigaction(signo, save, (struct sigaction *)NULL);
3146}
3147
3148#else /* !HAS_SIGACTION */
3149
3150Sighandler_t
3151Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3152{
3153#if defined(USE_ITHREADS) && !defined(WIN32)
3154 /* only "parent" interpreter can diddle signals */
3155 if (PL_curinterp != aTHX)
3156 return (Sighandler_t) SIG_ERR;
3157#endif
3158
3159 return PerlProc_signal(signo, handler);
3160}
3161
3162static Signal_t
3163sig_trap(int signo)
3164{
3165 PL_sig_trapped++;
3166}
3167
3168Sighandler_t
3169Perl_rsignal_state(pTHX_ int signo)
3170{
3171 Sighandler_t oldsig;
3172
3173#if defined(USE_ITHREADS) && !defined(WIN32)
3174 /* only "parent" interpreter can diddle signals */
3175 if (PL_curinterp != aTHX)
3176 return (Sighandler_t) SIG_ERR;
3177#endif
3178
3179 PL_sig_trapped = 0;
3180 oldsig = PerlProc_signal(signo, sig_trap);
3181 PerlProc_signal(signo, oldsig);
3182 if (PL_sig_trapped)
3183 PerlProc_kill(PerlProc_getpid(), signo);
3184 return oldsig;
3185}
3186
3187int
3188Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3189{
3190#if defined(USE_ITHREADS) && !defined(WIN32)
3191 /* only "parent" interpreter can diddle signals */
3192 if (PL_curinterp != aTHX)
3193 return -1;
3194#endif
3195 *save = PerlProc_signal(signo, handler);
3196 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3197}
3198
3199int
3200Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3201{
3202#if defined(USE_ITHREADS) && !defined(WIN32)
3203 /* only "parent" interpreter can diddle signals */
3204 if (PL_curinterp != aTHX)
3205 return -1;
3206#endif
3207 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3208}
3209
3210#endif /* !HAS_SIGACTION */
3211#endif /* !PERL_MICRO */
3212
3213 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3214#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3215I32
3216Perl_my_pclose(pTHX_ PerlIO *ptr)
3217{
3218 int status;
3219 SV **svp;
3220 Pid_t pid;
3221 Pid_t pid2 = 0;
3222 bool close_failed;
3223 dSAVEDERRNO;
3224 const int fd = PerlIO_fileno(ptr);
3225 bool should_wait;
3226
3227 svp = av_fetch(PL_fdpid,fd,TRUE);
3228 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3229 SvREFCNT_dec(*svp);
3230 *svp = NULL;
3231
3232#if defined(USE_PERLIO)
3233 /* Find out whether the refcount is low enough for us to wait for the
3234 child proc without blocking. */
3235 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3236#else
3237 should_wait = pid > 0;
3238#endif
3239
3240#ifdef OS2
3241 if (pid == -1) { /* Opened by popen. */
3242 return my_syspclose(ptr);
3243 }
3244#endif
3245 close_failed = (PerlIO_close(ptr) == EOF);
3246 SAVE_ERRNO;
3247 if (should_wait) do {
3248 pid2 = wait4pid(pid, &status, 0);
3249 } while (pid2 == -1 && errno == EINTR);
3250 if (close_failed) {
3251 RESTORE_ERRNO;
3252 return -1;
3253 }
3254 return(
3255 should_wait
3256 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3257 : 0
3258 );
3259}
3260#elif defined(__LIBCATAMOUNT__)
3261I32
3262Perl_my_pclose(pTHX_ PerlIO *ptr)
3263{
3264 return -1;
3265}
3266#endif /* !DOSISH */
3267
3268#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3269I32
3270Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3271{
3272 I32 result = 0;
3273 PERL_ARGS_ASSERT_WAIT4PID;
3274#ifdef PERL_USES_PL_PIDSTATUS
3275 if (!pid) {
3276 /* PERL_USES_PL_PIDSTATUS is only defined when neither
3277 waitpid() nor wait4() is available, or on OS/2, which
3278 doesn't appear to support waiting for a progress group
3279 member, so we can only treat a 0 pid as an unknown child.
3280 */
3281 errno = ECHILD;
3282 return -1;
3283 }
3284 {
3285 if (pid > 0) {
3286 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3287 pid, rather than a string form. */
3288 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3289 if (svp && *svp != &PL_sv_undef) {
3290 *statusp = SvIVX(*svp);
3291 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3292 G_DISCARD);
3293 return pid;
3294 }
3295 }
3296 else {
3297 HE *entry;
3298
3299 hv_iterinit(PL_pidstatus);
3300 if ((entry = hv_iternext(PL_pidstatus))) {
3301 SV * const sv = hv_iterval(PL_pidstatus,entry);
3302 I32 len;
3303 const char * const spid = hv_iterkey(entry,&len);
3304
3305 assert (len == sizeof(Pid_t));
3306 memcpy((char *)&pid, spid, len);
3307 *statusp = SvIVX(sv);
3308 /* The hash iterator is currently on this entry, so simply
3309 calling hv_delete would trigger the lazy delete, which on
3310 aggregate does more work, because next call to hv_iterinit()
3311 would spot the flag, and have to call the delete routine,
3312 while in the meantime any new entries can't re-use that
3313 memory. */
3314 hv_iterinit(PL_pidstatus);
3315 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3316 return pid;
3317 }
3318 }
3319 }
3320#endif
3321#ifdef HAS_WAITPID
3322# ifdef HAS_WAITPID_RUNTIME
3323 if (!HAS_WAITPID_RUNTIME)
3324 goto hard_way;
3325# endif
3326 result = PerlProc_waitpid(pid,statusp,flags);
3327 goto finish;
3328#endif
3329#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3330 result = wait4(pid,statusp,flags,NULL);
3331 goto finish;
3332#endif
3333#ifdef PERL_USES_PL_PIDSTATUS
3334#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3335 hard_way:
3336#endif
3337 {
3338 if (flags)
3339 Perl_croak(aTHX_ "Can't do waitpid with flags");
3340 else {
3341 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3342 pidgone(result,*statusp);
3343 if (result < 0)
3344 *statusp = -1;
3345 }
3346 }
3347#endif
3348#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3349 finish:
3350#endif
3351 if (result < 0 && errno == EINTR) {
3352 PERL_ASYNC_CHECK();
3353 errno = EINTR; /* reset in case a signal handler changed $! */
3354 }
3355 return result;
3356}
3357#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3358
3359#ifdef PERL_USES_PL_PIDSTATUS
3360void
3361S_pidgone(pTHX_ Pid_t pid, int status)
3362{
3363 SV *sv;
3364
3365 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3366 SvUPGRADE(sv,SVt_IV);
3367 SvIV_set(sv, status);
3368 return;
3369}
3370#endif
3371
3372#if defined(OS2)
3373int pclose();
3374#ifdef HAS_FORK
3375int /* Cannot prototype with I32
3376 in os2ish.h. */
3377my_syspclose(PerlIO *ptr)
3378#else
3379I32
3380Perl_my_pclose(pTHX_ PerlIO *ptr)
3381#endif
3382{
3383 /* Needs work for PerlIO ! */
3384 FILE * const f = PerlIO_findFILE(ptr);
3385 const I32 result = pclose(f);
3386 PerlIO_releaseFILE(ptr,f);
3387 return result;
3388}
3389#endif
3390
3391#if defined(DJGPP)
3392int djgpp_pclose();
3393I32
3394Perl_my_pclose(pTHX_ PerlIO *ptr)
3395{
3396 /* Needs work for PerlIO ! */
3397 FILE * const f = PerlIO_findFILE(ptr);
3398 I32 result = djgpp_pclose(f);
3399 result = (result << 8) & 0xff00;
3400 PerlIO_releaseFILE(ptr,f);
3401 return result;
3402}
3403#endif
3404
3405#define PERL_REPEATCPY_LINEAR 4
3406void
3407Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3408{
3409 PERL_ARGS_ASSERT_REPEATCPY;
3410
3411 assert(len >= 0);
3412
3413 if (count < 0)
3414 croak_memory_wrap();
3415
3416 if (len == 1)
3417 memset(to, *from, count);
3418 else if (count) {
3419 char *p = to;
3420 IV items, linear, half;
3421
3422 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3423 for (items = 0; items < linear; ++items) {
3424 const char *q = from;
3425 IV todo;
3426 for (todo = len; todo > 0; todo--)
3427 *p++ = *q++;
3428 }
3429
3430 half = count / 2;
3431 while (items <= half) {
3432 IV size = items * len;
3433 memcpy(p, to, size);
3434 p += size;
3435 items *= 2;
3436 }
3437
3438 if (count > items)
3439 memcpy(p, to, (count - items) * len);
3440 }
3441}
3442
3443#ifndef HAS_RENAME
3444I32
3445Perl_same_dirent(pTHX_ const char *a, const char *b)
3446{
3447 char *fa = strrchr(a,'/');
3448 char *fb = strrchr(b,'/');
3449 Stat_t tmpstatbuf1;
3450 Stat_t tmpstatbuf2;
3451 SV * const tmpsv = sv_newmortal();
3452
3453 PERL_ARGS_ASSERT_SAME_DIRENT;
3454
3455 if (fa)
3456 fa++;
3457 else
3458 fa = a;
3459 if (fb)
3460 fb++;
3461 else
3462 fb = b;
3463 if (strNE(a,b))
3464 return FALSE;
3465 if (fa == a)
3466 sv_setpvs(tmpsv, ".");
3467 else
3468 sv_setpvn(tmpsv, a, fa - a);
3469 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3470 return FALSE;
3471 if (fb == b)
3472 sv_setpvs(tmpsv, ".");
3473 else
3474 sv_setpvn(tmpsv, b, fb - b);
3475 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3476 return FALSE;
3477 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3478 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3479}
3480#endif /* !HAS_RENAME */
3481
3482char*
3483Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3484 const char *const *const search_ext, I32 flags)
3485{
3486 const char *xfound = NULL;
3487 char *xfailed = NULL;
3488 char tmpbuf[MAXPATHLEN];
3489 char *s;
3490 I32 len = 0;
3491 int retval;
3492 char *bufend;
3493#if defined(DOSISH) && !defined(OS2)
3494# define SEARCH_EXTS ".bat", ".cmd", NULL
3495# define MAX_EXT_LEN 4
3496#endif
3497#ifdef OS2
3498# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3499# define MAX_EXT_LEN 4
3500#endif
3501#ifdef VMS
3502# define SEARCH_EXTS ".pl", ".com", NULL
3503# define MAX_EXT_LEN 4
3504#endif
3505 /* additional extensions to try in each dir if scriptname not found */
3506#ifdef SEARCH_EXTS
3507 static const char *const exts[] = { SEARCH_EXTS };
3508 const char *const *const ext = search_ext ? search_ext : exts;
3509 int extidx = 0, i = 0;
3510 const char *curext = NULL;
3511#else
3512 PERL_UNUSED_ARG(search_ext);
3513# define MAX_EXT_LEN 0
3514#endif
3515
3516 PERL_ARGS_ASSERT_FIND_SCRIPT;
3517
3518 /*
3519 * If dosearch is true and if scriptname does not contain path
3520 * delimiters, search the PATH for scriptname.
3521 *
3522 * If SEARCH_EXTS is also defined, will look for each
3523 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3524 * while searching the PATH.
3525 *
3526 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3527 * proceeds as follows:
3528 * If DOSISH or VMSISH:
3529 * + look for ./scriptname{,.foo,.bar}
3530 * + search the PATH for scriptname{,.foo,.bar}
3531 *
3532 * If !DOSISH:
3533 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3534 * this will not look in '.' if it's not in the PATH)
3535 */
3536 tmpbuf[0] = '\0';
3537
3538#ifdef VMS
3539# ifdef ALWAYS_DEFTYPES
3540 len = strlen(scriptname);
3541 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3542 int idx = 0, deftypes = 1;
3543 bool seen_dot = 1;
3544
3545 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3546# else
3547 if (dosearch) {
3548 int idx = 0, deftypes = 1;
3549 bool seen_dot = 1;
3550
3551 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3552# endif
3553 /* The first time through, just add SEARCH_EXTS to whatever we
3554 * already have, so we can check for default file types. */
3555 while (deftypes ||
3556 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3557 {
3558 Stat_t statbuf;
3559 if (deftypes) {
3560 deftypes = 0;
3561 *tmpbuf = '\0';
3562 }
3563 if ((strlen(tmpbuf) + strlen(scriptname)
3564 + MAX_EXT_LEN) >= sizeof tmpbuf)
3565 continue; /* don't search dir with too-long name */
3566 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3567#else /* !VMS */
3568
3569#ifdef DOSISH
3570 if (strEQ(scriptname, "-"))
3571 dosearch = 0;
3572 if (dosearch) { /* Look in '.' first. */
3573 const char *cur = scriptname;
3574#ifdef SEARCH_EXTS
3575 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3576 while (ext[i])
3577 if (strEQ(ext[i++],curext)) {
3578 extidx = -1; /* already has an ext */
3579 break;
3580 }
3581 do {
3582#endif
3583 DEBUG_p(PerlIO_printf(Perl_debug_log,
3584 "Looking for %s\n",cur));
3585 {
3586 Stat_t statbuf;
3587 if (PerlLIO_stat(cur,&statbuf) >= 0
3588 && !S_ISDIR(statbuf.st_mode)) {
3589 dosearch = 0;
3590 scriptname = cur;
3591#ifdef SEARCH_EXTS
3592 break;
3593#endif
3594 }
3595 }
3596#ifdef SEARCH_EXTS
3597 if (cur == scriptname) {
3598 len = strlen(scriptname);
3599 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3600 break;
3601 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3602 cur = tmpbuf;
3603 }
3604 } while (extidx >= 0 && ext[extidx] /* try an extension? */
3605 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3606#endif
3607 }
3608#endif
3609
3610 if (dosearch && !strchr(scriptname, '/')
3611#ifdef DOSISH
3612 && !strchr(scriptname, '\\')
3613#endif
3614 && (s = PerlEnv_getenv("PATH")))
3615 {
3616 bool seen_dot = 0;
3617
3618 bufend = s + strlen(s);
3619 while (s < bufend) {
3620 Stat_t statbuf;
3621# ifdef DOSISH
3622 for (len = 0; *s
3623 && *s != ';'; len++, s++) {
3624 if (len < sizeof tmpbuf)
3625 tmpbuf[len] = *s;
3626 }
3627 if (len < sizeof tmpbuf)
3628 tmpbuf[len] = '\0';
3629# else
3630 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3631 ':', &len);
3632# endif
3633 if (s < bufend)
3634 s++;
3635 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3636 continue; /* don't search dir with too-long name */
3637 if (len
3638# ifdef DOSISH
3639 && tmpbuf[len - 1] != '/'
3640 && tmpbuf[len - 1] != '\\'
3641# endif
3642 )
3643 tmpbuf[len++] = '/';
3644 if (len == 2 && tmpbuf[0] == '.')
3645 seen_dot = 1;
3646 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3647#endif /* !VMS */
3648
3649#ifdef SEARCH_EXTS
3650 len = strlen(tmpbuf);
3651 if (extidx > 0) /* reset after previous loop */
3652 extidx = 0;
3653 do {
3654#endif
3655 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3656 retval = PerlLIO_stat(tmpbuf,&statbuf);
3657 if (S_ISDIR(statbuf.st_mode)) {
3658 retval = -1;
3659 }
3660#ifdef SEARCH_EXTS
3661 } while ( retval < 0 /* not there */
3662 && extidx>=0 && ext[extidx] /* try an extension? */
3663 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3664 );
3665#endif
3666 if (retval < 0)
3667 continue;
3668 if (S_ISREG(statbuf.st_mode)
3669 && cando(S_IRUSR,TRUE,&statbuf)
3670#if !defined(DOSISH)
3671 && cando(S_IXUSR,TRUE,&statbuf)
3672#endif
3673 )
3674 {
3675 xfound = tmpbuf; /* bingo! */
3676 break;
3677 }
3678 if (!xfailed)
3679 xfailed = savepv(tmpbuf);
3680 }
3681#ifndef DOSISH
3682 {
3683 Stat_t statbuf;
3684 if (!xfound && !seen_dot && !xfailed &&
3685 (PerlLIO_stat(scriptname,&statbuf) < 0
3686 || S_ISDIR(statbuf.st_mode)))
3687#endif
3688 seen_dot = 1; /* Disable message. */
3689#ifndef DOSISH
3690 }
3691#endif
3692 if (!xfound) {
3693 if (flags & 1) { /* do or die? */
3694 /* diag_listed_as: Can't execute %s */
3695 Perl_croak(aTHX_ "Can't %s %s%s%s",
3696 (xfailed ? "execute" : "find"),
3697 (xfailed ? xfailed : scriptname),
3698 (xfailed ? "" : " on PATH"),
3699 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3700 }
3701 scriptname = NULL;
3702 }
3703 Safefree(xfailed);
3704 scriptname = xfound;
3705 }
3706 return (scriptname ? savepv(scriptname) : NULL);
3707}
3708
3709#ifndef PERL_GET_CONTEXT_DEFINED
3710
3711void *
3712Perl_get_context(void)
3713{
3714#if defined(USE_ITHREADS)
3715# ifdef OLD_PTHREADS_API
3716 pthread_addr_t t;
3717 int error = pthread_getspecific(PL_thr_key, &t);
3718 if (error)
3719 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3720 return (void*)t;
3721# elif defined(I_MACH_CTHREADS)
3722 return (void*)cthread_data(cthread_self());
3723# else
3724 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3725# endif
3726#else
3727 return (void*)NULL;
3728#endif
3729}
3730
3731void
3732Perl_set_context(void *t)
3733{
3734#if defined(USE_ITHREADS)
3735#endif
3736 PERL_ARGS_ASSERT_SET_CONTEXT;
3737#if defined(USE_ITHREADS)
3738# ifdef I_MACH_CTHREADS
3739 cthread_set_data(cthread_self(), t);
3740# else
3741 {
3742 const int error = pthread_setspecific(PL_thr_key, t);
3743 if (error)
3744 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3745 }
3746# endif
3747#else
3748 PERL_UNUSED_ARG(t);
3749#endif
3750}
3751
3752#endif /* !PERL_GET_CONTEXT_DEFINED */
3753
3754char **
3755Perl_get_op_names(pTHX)
3756{
3757 PERL_UNUSED_CONTEXT;
3758 return (char **)PL_op_name;
3759}
3760
3761char **
3762Perl_get_op_descs(pTHX)
3763{
3764 PERL_UNUSED_CONTEXT;
3765 return (char **)PL_op_desc;
3766}
3767
3768const char *
3769Perl_get_no_modify(pTHX)
3770{
3771 PERL_UNUSED_CONTEXT;
3772 return PL_no_modify;
3773}
3774
3775U32 *
3776Perl_get_opargs(pTHX)
3777{
3778 PERL_UNUSED_CONTEXT;
3779 return (U32 *)PL_opargs;
3780}
3781
3782PPADDR_t*
3783Perl_get_ppaddr(pTHX)
3784{
3785 PERL_UNUSED_CONTEXT;
3786 return (PPADDR_t*)PL_ppaddr;
3787}
3788
3789#ifndef HAS_GETENV_LEN
3790char *
3791Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3792{
3793 char * const env_trans = PerlEnv_getenv(env_elem);
3794 PERL_UNUSED_CONTEXT;
3795 PERL_ARGS_ASSERT_GETENV_LEN;
3796 if (env_trans)
3797 *len = strlen(env_trans);
3798 return env_trans;
3799}
3800#endif
3801
3802
3803MGVTBL*
3804Perl_get_vtbl(pTHX_ int vtbl_id)
3805{
3806 PERL_UNUSED_CONTEXT;
3807
3808 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3809 ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3810}
3811
3812I32
3813Perl_my_fflush_all(pTHX)
3814{
3815#if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3816 return PerlIO_flush(NULL);
3817#else
3818# if defined(HAS__FWALK)
3819 extern int fflush(FILE *);
3820 /* undocumented, unprototyped, but very useful BSDism */
3821 extern void _fwalk(int (*)(FILE *));
3822 _fwalk(&fflush);
3823 return 0;
3824# else
3825# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3826 long open_max = -1;
3827# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3828 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3829# elif defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3830 open_max = sysconf(_SC_OPEN_MAX);
3831# elif defined(FOPEN_MAX)
3832 open_max = FOPEN_MAX;
3833# elif defined(OPEN_MAX)
3834 open_max = OPEN_MAX;
3835# elif defined(_NFILE)
3836 open_max = _NFILE;
3837# endif
3838 if (open_max > 0) {
3839 long i;
3840 for (i = 0; i < open_max; i++)
3841 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3842 STDIO_STREAM_ARRAY[i]._file < open_max &&
3843 STDIO_STREAM_ARRAY[i]._flag)
3844 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3845 return 0;
3846 }
3847# endif
3848 SETERRNO(EBADF,RMS_IFI);
3849 return EOF;
3850# endif
3851#endif
3852}
3853
3854void
3855Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3856{
3857 if (ckWARN(WARN_IO)) {
3858 HEK * const name
3859 = gv && (isGV_with_GP(gv))
3860 ? GvENAME_HEK((gv))
3861 : NULL;
3862 const char * const direction = have == '>' ? "out" : "in";
3863
3864 if (name && HEK_LEN(name))
3865 Perl_warner(aTHX_ packWARN(WARN_IO),
3866 "Filehandle %" HEKf " opened only for %sput",
3867 HEKfARG(name), direction);
3868 else
3869 Perl_warner(aTHX_ packWARN(WARN_IO),
3870 "Filehandle opened only for %sput", direction);
3871 }
3872}
3873
3874void
3875Perl_report_evil_fh(pTHX_ const GV *gv)
3876{
3877 const IO *io = gv ? GvIO(gv) : NULL;
3878 const PERL_BITFIELD16 op = PL_op->op_type;
3879 const char *vile;
3880 I32 warn_type;
3881
3882 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3883 vile = "closed";
3884 warn_type = WARN_CLOSED;
3885 }
3886 else {
3887 vile = "unopened";
3888 warn_type = WARN_UNOPENED;
3889 }
3890
3891 if (ckWARN(warn_type)) {
3892 SV * const name
3893 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3894 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3895 const char * const pars =
3896 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3897 const char * const func =
3898 (const char *)
3899 (op == OP_READLINE || op == OP_RCATLINE
3900 ? "readline" : /* "<HANDLE>" not nice */
3901 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3902 PL_op_desc[op]);
3903 const char * const type =
3904 (const char *)
3905 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3906 ? "socket" : "filehandle");
3907 const bool have_name = name && SvCUR(name);
3908 Perl_warner(aTHX_ packWARN(warn_type),
3909 "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3910 have_name ? " " : "",
3911 SVfARG(have_name ? name : &PL_sv_no));
3912 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3913 Perl_warner(
3914 aTHX_ packWARN(warn_type),
3915 "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3916 func, pars, have_name ? " " : "",
3917 SVfARG(have_name ? name : &PL_sv_no)
3918 );
3919 }
3920}
3921
3922/* To workaround core dumps from the uninitialised tm_zone we get the
3923 * system to give us a reasonable struct to copy. This fix means that
3924 * strftime uses the tm_zone and tm_gmtoff values returned by
3925 * localtime(time()). That should give the desired result most of the
3926 * time. But probably not always!
3927 *
3928 * This does not address tzname aspects of NETaa14816.
3929 *
3930 */
3931
3932#ifdef __GLIBC__
3933# ifndef STRUCT_TM_HASZONE
3934# define STRUCT_TM_HASZONE
3935# endif
3936#endif
3937
3938#ifdef STRUCT_TM_HASZONE /* Backward compat */
3939# ifndef HAS_TM_TM_ZONE
3940# define HAS_TM_TM_ZONE
3941# endif
3942#endif
3943
3944void
3945Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
3946{
3947#ifdef HAS_TM_TM_ZONE
3948 Time_t now;
3949 const struct tm* my_tm;
3950 PERL_UNUSED_CONTEXT;
3951 PERL_ARGS_ASSERT_INIT_TM;
3952 (void)time(&now);
3953 ENV_LOCALE_READ_LOCK;
3954 my_tm = localtime(&now);
3955 if (my_tm)
3956 Copy(my_tm, ptm, 1, struct tm);
3957 ENV_LOCALE_READ_UNLOCK;
3958#else
3959 PERL_UNUSED_CONTEXT;
3960 PERL_ARGS_ASSERT_INIT_TM;
3961 PERL_UNUSED_ARG(ptm);
3962#endif
3963}
3964
3965/*
3966=for apidoc_section $time
3967=for apidoc mini_mktime
3968normalise S<C<struct tm>> values without the localtime() semantics (and
3969overhead) of mktime().
3970
3971=cut
3972 */
3973void
3974Perl_mini_mktime(struct tm *ptm)
3975{
3976 int yearday;
3977 int secs;
3978 int month, mday, year, jday;
3979 int odd_cent, odd_year;
3980
3981 PERL_ARGS_ASSERT_MINI_MKTIME;
3982
3983#define DAYS_PER_YEAR 365
3984#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3985#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3986#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3987#define SECS_PER_HOUR (60*60)
3988#define SECS_PER_DAY (24*SECS_PER_HOUR)
3989/* parentheses deliberately absent on these two, otherwise they don't work */
3990#define MONTH_TO_DAYS 153/5
3991#define DAYS_TO_MONTH 5/153
3992/* offset to bias by March (month 4) 1st between month/mday & year finding */
3993#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3994/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3995#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3996
3997/*
3998 * Year/day algorithm notes:
3999 *
4000 * With a suitable offset for numeric value of the month, one can find
4001 * an offset into the year by considering months to have 30.6 (153/5) days,
4002 * using integer arithmetic (i.e., with truncation). To avoid too much
4003 * messing about with leap days, we consider January and February to be
4004 * the 13th and 14th month of the previous year. After that transformation,
4005 * we need the month index we use to be high by 1 from 'normal human' usage,
4006 * so the month index values we use run from 4 through 15.
4007 *
4008 * Given that, and the rules for the Gregorian calendar (leap years are those
4009 * divisible by 4 unless also divisible by 100, when they must be divisible
4010 * by 400 instead), we can simply calculate the number of days since some
4011 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4012 * the days we derive from our month index, and adding in the day of the
4013 * month. The value used here is not adjusted for the actual origin which
4014 * it normally would use (1 January A.D. 1), since we're not exposing it.
4015 * We're only building the value so we can turn around and get the
4016 * normalised values for the year, month, day-of-month, and day-of-year.
4017 *
4018 * For going backward, we need to bias the value we're using so that we find
4019 * the right year value. (Basically, we don't want the contribution of
4020 * March 1st to the number to apply while deriving the year). Having done
4021 * that, we 'count up' the contribution to the year number by accounting for
4022 * full quadracenturies (400-year periods) with their extra leap days, plus
4023 * the contribution from full centuries (to avoid counting in the lost leap
4024 * days), plus the contribution from full quad-years (to count in the normal
4025 * leap days), plus the leftover contribution from any non-leap years.
4026 * At this point, if we were working with an actual leap day, we'll have 0
4027 * days left over. This is also true for March 1st, however. So, we have
4028 * to special-case that result, and (earlier) keep track of the 'odd'
4029 * century and year contributions. If we got 4 extra centuries in a qcent,
4030 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4031 * Otherwise, we add back in the earlier bias we removed (the 123 from
4032 * figuring in March 1st), find the month index (integer division by 30.6),
4033 * and the remainder is the day-of-month. We then have to convert back to
4034 * 'real' months (including fixing January and February from being 14/15 in
4035 * the previous year to being in the proper year). After that, to get
4036 * tm_yday, we work with the normalised year and get a new yearday value for
4037 * January 1st, which we subtract from the yearday value we had earlier,
4038 * representing the date we've re-built. This is done from January 1
4039 * because tm_yday is 0-origin.
4040 *
4041 * Since POSIX time routines are only guaranteed to work for times since the
4042 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4043 * applies Gregorian calendar rules even to dates before the 16th century
4044 * doesn't bother me. Besides, you'd need cultural context for a given
4045 * date to know whether it was Julian or Gregorian calendar, and that's
4046 * outside the scope for this routine. Since we convert back based on the
4047 * same rules we used to build the yearday, you'll only get strange results
4048 * for input which needed normalising, or for the 'odd' century years which
4049 * were leap years in the Julian calendar but not in the Gregorian one.
4050 * I can live with that.
4051 *
4052 * This algorithm also fails to handle years before A.D. 1 gracefully, but
4053 * that's still outside the scope for POSIX time manipulation, so I don't
4054 * care.
4055 *
4056 * - lwall
4057 */
4058
4059 year = 1900 + ptm->tm_year;
4060 month = ptm->tm_mon;
4061 mday = ptm->tm_mday;
4062 jday = 0;
4063 if (month >= 2)
4064 month+=2;
4065 else
4066 month+=14, year--;
4067 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4068 yearday += month*MONTH_TO_DAYS + mday + jday;
4069 /*
4070 * Note that we don't know when leap-seconds were or will be,
4071 * so we have to trust the user if we get something which looks
4072 * like a sensible leap-second. Wild values for seconds will
4073 * be rationalised, however.
4074 */
4075 if ((unsigned) ptm->tm_sec <= 60) {
4076 secs = 0;
4077 }
4078 else {
4079 secs = ptm->tm_sec;
4080 ptm->tm_sec = 0;
4081 }
4082 secs += 60 * ptm->tm_min;
4083 secs += SECS_PER_HOUR * ptm->tm_hour;
4084 if (secs < 0) {
4085 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4086 /* got negative remainder, but need positive time */
4087 /* back off an extra day to compensate */
4088 yearday += (secs/SECS_PER_DAY)-1;
4089 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4090 }
4091 else {
4092 yearday += (secs/SECS_PER_DAY);
4093 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4094 }
4095 }
4096 else if (secs >= SECS_PER_DAY) {
4097 yearday += (secs/SECS_PER_DAY);
4098 secs %= SECS_PER_DAY;
4099 }
4100 ptm->tm_hour = secs/SECS_PER_HOUR;
4101 secs %= SECS_PER_HOUR;
4102 ptm->tm_min = secs/60;
4103 secs %= 60;
4104 ptm->tm_sec += secs;
4105 /* done with time of day effects */
4106 /*
4107 * The algorithm for yearday has (so far) left it high by 428.
4108 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4109 * bias it by 123 while trying to figure out what year it
4110 * really represents. Even with this tweak, the reverse
4111 * translation fails for years before A.D. 0001.
4112 * It would still fail for Feb 29, but we catch that one below.
4113 */
4114 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
4115 yearday -= YEAR_ADJUST;
4116 year = (yearday / DAYS_PER_QCENT) * 400;
4117 yearday %= DAYS_PER_QCENT;
4118 odd_cent = yearday / DAYS_PER_CENT;
4119 year += odd_cent * 100;
4120 yearday %= DAYS_PER_CENT;
4121 year += (yearday / DAYS_PER_QYEAR) * 4;
4122 yearday %= DAYS_PER_QYEAR;
4123 odd_year = yearday / DAYS_PER_YEAR;
4124 year += odd_year;
4125 yearday %= DAYS_PER_YEAR;
4126 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4127 month = 1;
4128 yearday = 29;
4129 }
4130 else {
4131 yearday += YEAR_ADJUST; /* recover March 1st crock */
4132 month = yearday*DAYS_TO_MONTH;
4133 yearday -= month*MONTH_TO_DAYS;
4134 /* recover other leap-year adjustment */
4135 if (month > 13) {
4136 month-=14;
4137 year++;
4138 }
4139 else {
4140 month-=2;
4141 }
4142 }
4143 ptm->tm_year = year - 1900;
4144 if (yearday) {
4145 ptm->tm_mday = yearday;
4146 ptm->tm_mon = month;
4147 }
4148 else {
4149 ptm->tm_mday = 31;
4150 ptm->tm_mon = month - 1;
4151 }
4152 /* re-build yearday based on Jan 1 to get tm_yday */
4153 year--;
4154 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4155 yearday += 14*MONTH_TO_DAYS + 1;
4156 ptm->tm_yday = jday - yearday;
4157 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4158}
4159
4160char *
4161Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
4162{
4163#ifdef HAS_STRFTIME
4164
4165/*
4166=for apidoc_section $time
4167=for apidoc my_strftime
4168strftime(), but with a different API so that the return value is a pointer
4169to the formatted result (which MUST be arranged to be FREED BY THE
4170CALLER). This allows this function to increase the buffer size as needed,
4171so that the caller doesn't have to worry about that.
4172
4173Note that yday and wday effectively are ignored by this function, as
4174mini_mktime() overwrites them
4175
4176Also note that this is always executed in the underlying locale of the program,
4177giving localized results.
4178
4179=cut
4180 */
4181
4182 char *buf;
4183 int buflen;
4184 struct tm mytm;
4185 int len;
4186
4187 PERL_ARGS_ASSERT_MY_STRFTIME;
4188
4189 init_tm(&mytm); /* XXX workaround - see init_tm() above */
4190 mytm.tm_sec = sec;
4191 mytm.tm_min = min;
4192 mytm.tm_hour = hour;
4193 mytm.tm_mday = mday;
4194 mytm.tm_mon = mon;
4195 mytm.tm_year = year;
4196 mytm.tm_wday = wday;
4197 mytm.tm_yday = yday;
4198 mytm.tm_isdst = isdst;
4199 mini_mktime(&mytm);
4200 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4201#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4202 STMT_START {
4203 struct tm mytm2;
4204 mytm2 = mytm;
4205 mktime(&mytm2);
4206#ifdef HAS_TM_TM_GMTOFF
4207 mytm.tm_gmtoff = mytm2.tm_gmtoff;
4208#endif
4209#ifdef HAS_TM_TM_ZONE
4210 mytm.tm_zone = mytm2.tm_zone;
4211#endif
4212 } STMT_END;
4213#endif
4214 buflen = 64;
4215 Newx(buf, buflen, char);
4216
4217 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
4218
4219 len = strftime(buf, buflen, fmt, &mytm);
4220
4221 GCC_DIAG_RESTORE_STMT;
4222
4223 /*
4224 ** The following is needed to handle the situation where
4225 ** tmpbuf overflows. Basically we want to allocate a buffer
4226 ** and try repeatedly, until it's large enough. The reason why it is so
4227 ** complicated ** is that getting a return value of 0 from strftime can
4228 ** indicate one of the following:
4229 ** 1. buffer overflowed,
4230 ** 2. illegal conversion specifier, or
4231 ** 3. the format string specifies nothing to be returned (which isn't an
4232 ** an error). This could be because the format is an empty string
4233 ** or it specifies %p which yields an empty string in some locales.
4234 ** If there is a better way to make it portable, go ahead by
4235 ** all means.
4236 */
4237 if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
4238 return buf;
4239 else {
4240 /* Possibly buf overflowed - try again with a bigger buf */
4241 const int fmtlen = strlen(fmt);
4242 int bufsize = fmtlen + buflen;
4243
4244 Renew(buf, bufsize, char);
4245 while (buf) {
4246
4247 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
4248 buflen = strftime(buf, bufsize, fmt, &mytm);
4249 GCC_DIAG_RESTORE_STMT;
4250
4251 if (inRANGE(buflen, 1, bufsize - 1))
4252 break;
4253 /* heuristic to prevent out-of-memory errors */
4254 if (bufsize > 100*fmtlen) {
4255
4256 /* "%p" can legally return nothing, assume that was the case if we
4257 * can't make the buffer large enough to get a non-zero return. For
4258 * any other formats, assume it is an error (probably it is an illegal
4259 * conversion specifier.) */
4260 if (strEQ(fmt, "%p")) {
4261 Renew(buf, 1, char);
4262 *buf = '\0';
4263 }
4264 else {
4265 Safefree(buf);
4266 buf = NULL;
4267 }
4268 break;
4269 }
4270 bufsize *= 2;
4271 Renew(buf, bufsize, char);
4272 }
4273 return buf;
4274 }
4275#else
4276 Perl_croak(aTHX_ "panic: no strftime");
4277 return NULL;
4278#endif
4279}
4280
4281
4282#define SV_CWD_RETURN_UNDEF \
4283 sv_set_undef(sv); \
4284 return FALSE
4285
4286#define SV_CWD_ISDOT(dp) \
4287 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4288 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4289
4290/*
4291=for apidoc_section $utility
4292
4293=for apidoc getcwd_sv
4294
4295Fill C<sv> with current working directory
4296
4297=cut
4298*/
4299
4300/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4301 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4302 * getcwd(3) if available
4303 * Comments from the original:
4304 * This is a faster version of getcwd. It's also more dangerous
4305 * because you might chdir out of a directory that you can't chdir
4306 * back into. */
4307
4308int
4309Perl_getcwd_sv(pTHX_ SV *sv)
4310{
4311#ifndef PERL_MICRO
4312 SvTAINTED_on(sv);
4313
4314 PERL_ARGS_ASSERT_GETCWD_SV;
4315
4316#ifdef HAS_GETCWD
4317 {
4318 char buf[MAXPATHLEN];
4319
4320 /* Some getcwd()s automatically allocate a buffer of the given
4321 * size from the heap if they are given a NULL buffer pointer.
4322 * The problem is that this behaviour is not portable. */
4323 if (getcwd(buf, sizeof(buf) - 1)) {
4324 sv_setpv(sv, buf);
4325 return TRUE;
4326 }
4327 else {
4328 SV_CWD_RETURN_UNDEF;
4329 }
4330 }
4331
4332#else
4333
4334 Stat_t statbuf;
4335 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4336 int pathlen=0;
4337 Direntry_t *dp;
4338
4339 SvUPGRADE(sv, SVt_PV);
4340
4341 if (PerlLIO_lstat(".", &statbuf) < 0) {
4342 SV_CWD_RETURN_UNDEF;
4343 }
4344
4345 orig_cdev = statbuf.st_dev;
4346 orig_cino = statbuf.st_ino;
4347 cdev = orig_cdev;
4348 cino = orig_cino;
4349
4350 for (;;) {
4351 DIR *dir;
4352 int namelen;
4353 odev = cdev;
4354 oino = cino;
4355
4356 if (PerlDir_chdir("..") < 0) {
4357 SV_CWD_RETURN_UNDEF;
4358 }
4359 if (PerlLIO_stat(".", &statbuf) < 0) {
4360 SV_CWD_RETURN_UNDEF;
4361 }
4362
4363 cdev = statbuf.st_dev;
4364 cino = statbuf.st_ino;
4365
4366 if (odev == cdev && oino == cino) {
4367 break;
4368 }
4369 if (!(dir = PerlDir_open("."))) {
4370 SV_CWD_RETURN_UNDEF;
4371 }
4372
4373 while ((dp = PerlDir_read(dir)) != NULL) {
4374#ifdef DIRNAMLEN
4375 namelen = dp->d_namlen;
4376#else
4377 namelen = strlen(dp->d_name);
4378#endif
4379 /* skip . and .. */
4380 if (SV_CWD_ISDOT(dp)) {
4381 continue;
4382 }
4383
4384 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4385 SV_CWD_RETURN_UNDEF;
4386 }
4387
4388 tdev = statbuf.st_dev;
4389 tino = statbuf.st_ino;
4390 if (tino == oino && tdev == odev) {
4391 break;
4392 }
4393 }
4394
4395 if (!dp) {
4396 SV_CWD_RETURN_UNDEF;
4397 }
4398
4399 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4400 SV_CWD_RETURN_UNDEF;
4401 }
4402
4403 SvGROW(sv, pathlen + namelen + 1);
4404
4405 if (pathlen) {
4406 /* shift down */
4407 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4408 }
4409
4410 /* prepend current directory to the front */
4411 *SvPVX(sv) = '/';
4412 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4413 pathlen += (namelen + 1);
4414
4415#ifdef VOID_CLOSEDIR
4416 PerlDir_close(dir);
4417#else
4418 if (PerlDir_close(dir) < 0) {
4419 SV_CWD_RETURN_UNDEF;
4420 }
4421#endif
4422 }
4423
4424 if (pathlen) {
4425 SvCUR_set(sv, pathlen);
4426 *SvEND(sv) = '\0';
4427 SvPOK_only(sv);
4428
4429 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4430 SV_CWD_RETURN_UNDEF;
4431 }
4432 }
4433 if (PerlLIO_stat(".", &statbuf) < 0) {
4434 SV_CWD_RETURN_UNDEF;
4435 }
4436
4437 cdev = statbuf.st_dev;
4438 cino = statbuf.st_ino;
4439
4440 if (cdev != orig_cdev || cino != orig_cino) {
4441 Perl_croak(aTHX_ "Unstable directory path, "
4442 "current directory changed unexpectedly");
4443 }
4444
4445 return TRUE;
4446#endif
4447
4448#else
4449 return FALSE;
4450#endif
4451}
4452
4453#include "vutil.c"
4454
4455#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4456# define EMULATE_SOCKETPAIR_UDP
4457#endif
4458
4459#ifdef EMULATE_SOCKETPAIR_UDP
4460static int
4461S_socketpair_udp (int fd[2]) {
4462 dTHX;
4463 /* Fake a datagram socketpair using UDP to localhost. */
4464 int sockets[2] = {-1, -1};
4465 struct sockaddr_in addresses[2];
4466 int i;
4467 Sock_size_t size = sizeof(struct sockaddr_in);
4468 unsigned short port;
4469 int got;
4470
4471 memset(&addresses, 0, sizeof(addresses));
4472 i = 1;
4473 do {
4474 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4475 if (sockets[i] == -1)
4476 goto tidy_up_and_fail;
4477
4478 addresses[i].sin_family = AF_INET;
4479 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4480 addresses[i].sin_port = 0; /* kernel choses port. */
4481 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4482 sizeof(struct sockaddr_in)) == -1)
4483 goto tidy_up_and_fail;
4484 } while (i--);
4485
4486 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4487 for each connect the other socket to it. */
4488 i = 1;
4489 do {
4490 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4491 &size) == -1)
4492 goto tidy_up_and_fail;
4493 if (size != sizeof(struct sockaddr_in))
4494 goto abort_tidy_up_and_fail;
4495 /* !1 is 0, !0 is 1 */
4496 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4497 sizeof(struct sockaddr_in)) == -1)
4498 goto tidy_up_and_fail;
4499 } while (i--);
4500
4501 /* Now we have 2 sockets connected to each other. I don't trust some other
4502 process not to have already sent a packet to us (by random) so send
4503 a packet from each to the other. */
4504 i = 1;
4505 do {
4506 /* I'm going to send my own port number. As a short.
4507 (Who knows if someone somewhere has sin_port as a bitfield and needs
4508 this routine. (I'm assuming crays have socketpair)) */
4509 port = addresses[i].sin_port;
4510 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4511 if (got != sizeof(port)) {
4512 if (got == -1)
4513 goto tidy_up_and_fail;
4514 goto abort_tidy_up_and_fail;
4515 }
4516 } while (i--);
4517
4518 /* Packets sent. I don't trust them to have arrived though.
4519 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4520 connect to localhost will use a second kernel thread. In 2.6 the
4521 first thread running the connect() returns before the second completes,
4522 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4523 returns 0. Poor programs have tripped up. One poor program's authors'
4524 had a 50-1 reverse stock split. Not sure how connected these were.)
4525 So I don't trust someone not to have an unpredictable UDP stack.
4526 */
4527
4528 {
4529 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4530 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4531 fd_set rset;
4532
4533 FD_ZERO(&rset);
4534 FD_SET((unsigned int)sockets[0], &rset);
4535 FD_SET((unsigned int)sockets[1], &rset);
4536
4537 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4538 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4539 || !FD_ISSET(sockets[1], &rset)) {
4540 /* I hope this is portable and appropriate. */
4541 if (got == -1)
4542 goto tidy_up_and_fail;
4543 goto abort_tidy_up_and_fail;
4544 }
4545 }
4546
4547 /* And the paranoia department even now doesn't trust it to have arrive
4548 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4549 {
4550 struct sockaddr_in readfrom;
4551 unsigned short buffer[2];
4552
4553 i = 1;
4554 do {
4555#ifdef MSG_DONTWAIT
4556 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4557 sizeof(buffer), MSG_DONTWAIT,
4558 (struct sockaddr *) &readfrom, &size);
4559#else
4560 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4561 sizeof(buffer), 0,
4562 (struct sockaddr *) &readfrom, &size);
4563#endif
4564
4565 if (got == -1)
4566 goto tidy_up_and_fail;
4567 if (got != sizeof(port)
4568 || size != sizeof(struct sockaddr_in)
4569 /* Check other socket sent us its port. */
4570 || buffer[0] != (unsigned short) addresses[!i].sin_port
4571 /* Check kernel says we got the datagram from that socket */
4572 || readfrom.sin_family != addresses[!i].sin_family
4573 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4574 || readfrom.sin_port != addresses[!i].sin_port)
4575 goto abort_tidy_up_and_fail;
4576 } while (i--);
4577 }
4578 /* My caller (my_socketpair) has validated that this is non-NULL */
4579 fd[0] = sockets[0];
4580 fd[1] = sockets[1];
4581 /* I hereby declare this connection open. May God bless all who cross
4582 her. */
4583 return 0;
4584
4585 abort_tidy_up_and_fail:
4586 errno = ECONNABORTED;
4587 tidy_up_and_fail:
4588 {
4589 dSAVE_ERRNO;
4590 if (sockets[0] != -1)
4591 PerlLIO_close(sockets[0]);
4592 if (sockets[1] != -1)
4593 PerlLIO_close(sockets[1]);
4594 RESTORE_ERRNO;
4595 return -1;
4596 }
4597}
4598#endif /* EMULATE_SOCKETPAIR_UDP */
4599
4600#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4601int
4602Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4603 /* Stevens says that family must be AF_LOCAL, protocol 0.
4604 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
4605 dTHXa(NULL);
4606 int listener = -1;
4607 int connector = -1;
4608 int acceptor = -1;
4609 struct sockaddr_in listen_addr;
4610 struct sockaddr_in connect_addr;
4611 Sock_size_t size;
4612
4613 if (protocol
4614#ifdef AF_UNIX
4615 || family != AF_UNIX
4616#endif
4617 ) {
4618 errno = EAFNOSUPPORT;
4619 return -1;
4620 }
4621 if (!fd) {
4622 errno = EINVAL;
4623 return -1;
4624 }
4625
4626#ifdef SOCK_CLOEXEC
4627 type &= ~SOCK_CLOEXEC;
4628#endif
4629
4630#ifdef EMULATE_SOCKETPAIR_UDP
4631 if (type == SOCK_DGRAM)
4632 return S_socketpair_udp(fd);
4633#endif
4634
4635 aTHXa(PERL_GET_THX);
4636 listener = PerlSock_socket(AF_INET, type, 0);
4637 if (listener == -1)
4638 return -1;
4639 memset(&listen_addr, 0, sizeof(listen_addr));
4640 listen_addr.sin_family = AF_INET;
4641 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4642 listen_addr.sin_port = 0; /* kernel choses port. */
4643 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4644 sizeof(listen_addr)) == -1)
4645 goto tidy_up_and_fail;
4646 if (PerlSock_listen(listener, 1) == -1)
4647 goto tidy_up_and_fail;
4648
4649 connector = PerlSock_socket(AF_INET, type, 0);
4650 if (connector == -1)
4651 goto tidy_up_and_fail;
4652 /* We want to find out the port number to connect to. */
4653 size = sizeof(connect_addr);
4654 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4655 &size) == -1)
4656 goto tidy_up_and_fail;
4657 if (size != sizeof(connect_addr))
4658 goto abort_tidy_up_and_fail;
4659 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4660 sizeof(connect_addr)) == -1)
4661 goto tidy_up_and_fail;
4662
4663 size = sizeof(listen_addr);
4664 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4665 &size);
4666 if (acceptor == -1)
4667 goto tidy_up_and_fail;
4668 if (size != sizeof(listen_addr))
4669 goto abort_tidy_up_and_fail;
4670 PerlLIO_close(listener);
4671 /* Now check we are talking to ourself by matching port and host on the
4672 two sockets. */
4673 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4674 &size) == -1)
4675 goto tidy_up_and_fail;
4676 if (size != sizeof(connect_addr)
4677 || listen_addr.sin_family != connect_addr.sin_family
4678 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4679 || listen_addr.sin_port != connect_addr.sin_port) {
4680 goto abort_tidy_up_and_fail;
4681 }
4682 fd[0] = connector;
4683 fd[1] = acceptor;
4684 return 0;
4685
4686 abort_tidy_up_and_fail:
4687#ifdef ECONNABORTED
4688 errno = ECONNABORTED; /* This would be the standard thing to do. */
4689#elif defined(ECONNREFUSED)
4690 errno = ECONNREFUSED; /* some OSes might not have ECONNABORTED. */
4691#else
4692 errno = ETIMEDOUT; /* Desperation time. */
4693#endif
4694 tidy_up_and_fail:
4695 {
4696 dSAVE_ERRNO;
4697 if (listener != -1)
4698 PerlLIO_close(listener);
4699 if (connector != -1)
4700 PerlLIO_close(connector);
4701 if (acceptor != -1)
4702 PerlLIO_close(acceptor);
4703 RESTORE_ERRNO;
4704 return -1;
4705 }
4706}
4707#else
4708/* In any case have a stub so that there's code corresponding
4709 * to the my_socketpair in embed.fnc. */
4710int
4711Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4712#ifdef HAS_SOCKETPAIR
4713 return socketpair(family, type, protocol, fd);
4714#else
4715 return -1;
4716#endif
4717}
4718#endif
4719
4720/*
4721
4722=for apidoc sv_nosharing
4723
4724Dummy routine which "shares" an SV when there is no sharing module present.
4725Or "locks" it. Or "unlocks" it. In other
4726words, ignores its single SV argument.
4727Exists to avoid test for a C<NULL> function pointer and because it could
4728potentially warn under some level of strict-ness.
4729
4730=cut
4731*/
4732
4733void
4734Perl_sv_nosharing(pTHX_ SV *sv)
4735{
4736 PERL_UNUSED_CONTEXT;
4737 PERL_UNUSED_ARG(sv);
4738}
4739
4740/*
4741
4742=for apidoc sv_destroyable
4743
4744Dummy routine which reports that object can be destroyed when there is no
4745sharing module present. It ignores its single SV argument, and returns
4746'true'. Exists to avoid test for a C<NULL> function pointer and because it
4747could potentially warn under some level of strict-ness.
4748
4749=cut
4750*/
4751
4752bool
4753Perl_sv_destroyable(pTHX_ SV *sv)
4754{
4755 PERL_UNUSED_CONTEXT;
4756 PERL_UNUSED_ARG(sv);
4757 return TRUE;
4758}
4759
4760U32
4761Perl_parse_unicode_opts(pTHX_ const char **popt)
4762{
4763 const char *p = *popt;
4764 U32 opt = 0;
4765
4766 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4767
4768 if (*p) {
4769 if (isDIGIT(*p)) {
4770 const char* endptr = p + strlen(p);
4771 UV uv;
4772 if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4773 opt = (U32)uv;
4774 p = endptr;
4775 if (p && *p && *p != '\n' && *p != '\r') {
4776 if (isSPACE(*p))
4777 goto the_end_of_the_opts_parser;
4778 else
4779 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4780 }
4781 }
4782 else {
4783 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4784 }
4785 }
4786 else {
4787 for (; *p; p++) {
4788 switch (*p) {
4789 case PERL_UNICODE_STDIN:
4790 opt |= PERL_UNICODE_STDIN_FLAG; break;
4791 case PERL_UNICODE_STDOUT:
4792 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4793 case PERL_UNICODE_STDERR:
4794 opt |= PERL_UNICODE_STDERR_FLAG; break;
4795 case PERL_UNICODE_STD:
4796 opt |= PERL_UNICODE_STD_FLAG; break;
4797 case PERL_UNICODE_IN:
4798 opt |= PERL_UNICODE_IN_FLAG; break;
4799 case PERL_UNICODE_OUT:
4800 opt |= PERL_UNICODE_OUT_FLAG; break;
4801 case PERL_UNICODE_INOUT:
4802 opt |= PERL_UNICODE_INOUT_FLAG; break;
4803 case PERL_UNICODE_LOCALE:
4804 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4805 case PERL_UNICODE_ARGV:
4806 opt |= PERL_UNICODE_ARGV_FLAG; break;
4807 case PERL_UNICODE_UTF8CACHEASSERT:
4808 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4809 default:
4810 if (*p != '\n' && *p != '\r') {
4811 if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4812 else
4813 Perl_croak(aTHX_
4814 "Unknown Unicode option letter '%c'", *p);
4815 }
4816 }
4817 }
4818 }
4819 }
4820 else
4821 opt = PERL_UNICODE_DEFAULT_FLAGS;
4822
4823 the_end_of_the_opts_parser:
4824
4825 if (opt & ~PERL_UNICODE_ALL_FLAGS)
4826 Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4827 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4828
4829 *popt = p;
4830
4831 return opt;
4832}
4833
4834#ifdef VMS
4835# include <starlet.h>
4836#endif
4837
4838U32
4839Perl_seed(pTHX)
4840{
4841 /*
4842 * This is really just a quick hack which grabs various garbage
4843 * values. It really should be a real hash algorithm which
4844 * spreads the effect of every input bit onto every output bit,
4845 * if someone who knows about such things would bother to write it.
4846 * Might be a good idea to add that function to CORE as well.
4847 * No numbers below come from careful analysis or anything here,
4848 * except they are primes and SEED_C1 > 1E6 to get a full-width
4849 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4850 * probably be bigger too.
4851 */
4852#if RANDBITS > 16
4853# define SEED_C1 1000003
4854#define SEED_C4 73819
4855#else
4856# define SEED_C1 25747
4857#define SEED_C4 20639
4858#endif
4859#define SEED_C2 3
4860#define SEED_C3 269
4861#define SEED_C5 26107
4862
4863#ifndef PERL_NO_DEV_RANDOM
4864 int fd;
4865#endif
4866 U32 u;
4867#ifdef HAS_GETTIMEOFDAY
4868 struct timeval when;
4869#else
4870 Time_t when;
4871#endif
4872
4873/* This test is an escape hatch, this symbol isn't set by Configure. */
4874#ifndef PERL_NO_DEV_RANDOM
4875#ifndef PERL_RANDOM_DEVICE
4876 /* /dev/random isn't used by default because reads from it will block
4877 * if there isn't enough entropy available. You can compile with
4878 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4879 * is enough real entropy to fill the seed. */
4880# ifdef __amigaos4__
4881# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4882# else
4883# define PERL_RANDOM_DEVICE "/dev/urandom"
4884# endif
4885#endif
4886 fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
4887 if (fd != -1) {
4888 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4889 u = 0;
4890 PerlLIO_close(fd);
4891 if (u)
4892 return u;
4893 }
4894#endif
4895
4896#ifdef HAS_GETTIMEOFDAY
4897 PerlProc_gettimeofday(&when,NULL);
4898 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4899#else
4900 (void)time(&when);
4901 u = (U32)SEED_C1 * when;
4902#endif
4903 u += SEED_C3 * (U32)PerlProc_getpid();
4904 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4905#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4906 u += SEED_C5 * (U32)PTR2UV(&when);
4907#endif
4908 return u;
4909}
4910
4911void
4912Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4913{
4914#ifndef NO_PERL_HASH_ENV
4915 const char *env_pv;
4916#endif
4917 unsigned long i;
4918
4919 PERL_ARGS_ASSERT_GET_HASH_SEED;
4920
4921#ifndef NO_PERL_HASH_ENV
4922 env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4923
4924 if ( env_pv )
4925 {
4926 /* ignore leading spaces */
4927 while (isSPACE(*env_pv))
4928 env_pv++;
4929# ifdef USE_PERL_PERTURB_KEYS
4930 /* if they set it to "0" we disable key traversal randomization completely */
4931 if (strEQ(env_pv,"0")) {
4932 PL_hash_rand_bits_enabled= 0;
4933 } else {
4934 /* otherwise switch to deterministic mode */
4935 PL_hash_rand_bits_enabled= 2;
4936 }
4937# endif
4938 /* ignore a leading 0x... if it is there */
4939 if (env_pv[0] == '0' && env_pv[1] == 'x')
4940 env_pv += 2;
4941
4942 for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4943 seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4944 if ( isXDIGIT(*env_pv)) {
4945 seed_buffer[i] |= READ_XDIGIT(env_pv);
4946 }
4947 }
4948 while (isSPACE(*env_pv))
4949 env_pv++;
4950
4951 if (*env_pv && !isXDIGIT(*env_pv)) {
4952 Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4953 }
4954 /* should we check for unparsed crap? */
4955 /* should we warn about unused hex? */
4956 /* should we warn about insufficient hex? */
4957 }
4958 else
4959#endif /* NO_PERL_HASH_ENV */
4960 {
4961 for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4962 seed_buffer[i] = (unsigned char)(Perl_internal_drand48() * (U8_MAX+1));
4963 }
4964 }
4965#ifdef USE_PERL_PERTURB_KEYS
4966 { /* initialize PL_hash_rand_bits from the hash seed.
4967 * This value is highly volatile, it is updated every
4968 * hash insert, and is used as part of hash bucket chain
4969 * randomization and hash iterator randomization. */
4970 PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4971 for( i = 0; i < sizeof(UV) ; i++ ) {
4972 PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4973 PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4974 }
4975 }
4976# ifndef NO_PERL_HASH_ENV
4977 env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4978 if (env_pv) {
4979 if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4980 PL_hash_rand_bits_enabled= 0;
4981 } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4982 PL_hash_rand_bits_enabled= 1;
4983 } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4984 PL_hash_rand_bits_enabled= 2;
4985 } else {
4986 Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4987 }
4988 }
4989# endif
4990#endif
4991}
4992
4993#ifdef PERL_MEM_LOG
4994
4995/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4996 * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4997 * given, and you supply your own implementation.
4998 *
4999 * The default implementation reads a single env var, PERL_MEM_LOG,
5000 * expecting one or more of the following:
5001 *
5002 * \d+ - fd fd to write to : must be 1st (grok_atoUV)
5003 * 'm' - memlog was PERL_MEM_LOG=1
5004 * 's' - svlog was PERL_SV_LOG=1
5005 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
5006 *
5007 * This makes the logger controllable enough that it can reasonably be
5008 * added to the system perl.
5009 */
5010
5011/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5012 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5013 */
5014#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5015
5016/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5017 * writes to. In the default logger, this is settable at runtime.
5018 */
5019#ifndef PERL_MEM_LOG_FD
5020# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5021#endif
5022
5023#ifndef PERL_MEM_LOG_NOIMPL
5024
5025# ifdef DEBUG_LEAKING_SCALARS
5026# define SV_LOG_SERIAL_FMT " [%lu]"
5027# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial
5028# else
5029# define SV_LOG_SERIAL_FMT
5030# define _SV_LOG_SERIAL_ARG(sv)
5031# endif
5032
5033static void
5034S_mem_log_common(enum mem_log_type mlt, const UV n,
5035 const UV typesize, const char *type_name, const SV *sv,
5036 Malloc_t oldalloc, Malloc_t newalloc,
5037 const char *filename, const int linenumber,
5038 const char *funcname)
5039{
5040 const char *pmlenv;
5041 dTHX;
5042
5043 PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5044
5045 PL_mem_log[0] |= 0x2; /* Flag that the call is from this code */
5046 pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5047 PL_mem_log[0] &= ~0x2;
5048 if (!pmlenv)
5049 return;
5050 if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5051 {
5052 /* We can't use SVs or PerlIO for obvious reasons,
5053 * so we'll use stdio and low-level IO instead. */
5054 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5055
5056# ifdef HAS_GETTIMEOFDAY
5057# define MEM_LOG_TIME_FMT "%10d.%06d: "
5058# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
5059 struct timeval tv;
5060 gettimeofday(&tv, 0);
5061# else
5062# define MEM_LOG_TIME_FMT "%10d: "
5063# define MEM_LOG_TIME_ARG (int)when
5064 Time_t when;
5065 (void)time(&when);
5066# endif
5067 /* If there are other OS specific ways of hires time than
5068 * gettimeofday() (see dist/Time-HiRes), the easiest way is
5069 * probably that they would be used to fill in the struct
5070 * timeval. */
5071 {
5072 STRLEN len;
5073 const char* endptr = pmlenv + strlen(pmlenv);
5074 int fd;
5075 UV uv;
5076 if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
5077 && uv && uv <= PERL_INT_MAX
5078 ) {
5079 fd = (int)uv;
5080 } else {
5081 fd = PERL_MEM_LOG_FD;
5082 }
5083
5084 if (strchr(pmlenv, 't')) {
5085 len = my_snprintf(buf, sizeof(buf),
5086 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5087 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5088 }
5089 switch (mlt) {
5090 case MLT_ALLOC:
5091 len = my_snprintf(buf, sizeof(buf),
5092 "alloc: %s:%d:%s: %" IVdf " %" UVuf
5093 " %s = %" IVdf ": %" UVxf "\n",
5094 filename, linenumber, funcname, n, typesize,
5095 type_name, n * typesize, PTR2UV(newalloc));
5096 break;
5097 case MLT_REALLOC:
5098 len = my_snprintf(buf, sizeof(buf),
5099 "realloc: %s:%d:%s: %" IVdf " %" UVuf
5100 " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
5101 filename, linenumber, funcname, n, typesize,
5102 type_name, n * typesize, PTR2UV(oldalloc),
5103 PTR2UV(newalloc));
5104 break;
5105 case MLT_FREE:
5106 len = my_snprintf(buf, sizeof(buf),
5107 "free: %s:%d:%s: %" UVxf "\n",
5108 filename, linenumber, funcname,
5109 PTR2UV(oldalloc));
5110 break;
5111 case MLT_NEW_SV:
5112 case MLT_DEL_SV:
5113 len = my_snprintf(buf, sizeof(buf),
5114 "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
5115 mlt == MLT_NEW_SV ? "new" : "del",
5116 filename, linenumber, funcname,
5117 PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5118 break;
5119 default:
5120 len = 0;
5121 }
5122 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5123 }
5124 }
5125}
5126#endif /* !PERL_MEM_LOG_NOIMPL */
5127
5128#ifndef PERL_MEM_LOG_NOIMPL
5129# define \
5130 mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5131 mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5132#else
5133/* this is suboptimal, but bug compatible. User is providing their
5134 own implementation, but is getting these functions anyway, and they
5135 do nothing. But _NOIMPL users should be able to cope or fix */
5136# define \
5137 mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5138 /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5139#endif
5140
5141Malloc_t
5142Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5143 Malloc_t newalloc,
5144 const char *filename, const int linenumber,
5145 const char *funcname)
5146{
5147 PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5148
5149 mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5150 NULL, NULL, newalloc,
5151 filename, linenumber, funcname);
5152 return newalloc;
5153}
5154
5155Malloc_t
5156Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5157 Malloc_t oldalloc, Malloc_t newalloc,
5158 const char *filename, const int linenumber,
5159 const char *funcname)
5160{
5161 PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5162
5163 mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5164 NULL, oldalloc, newalloc,
5165 filename, linenumber, funcname);
5166 return newalloc;
5167}
5168
5169Malloc_t
5170Perl_mem_log_free(Malloc_t oldalloc,
5171 const char *filename, const int linenumber,
5172 const char *funcname)
5173{
5174 PERL_ARGS_ASSERT_MEM_LOG_FREE;
5175
5176 mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5177 filename, linenumber, funcname);
5178 return oldalloc;
5179}
5180
5181void
5182Perl_mem_log_new_sv(const SV *sv,
5183 const char *filename, const int linenumber,
5184 const char *funcname)
5185{
5186 mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5187 filename, linenumber, funcname);
5188}
5189
5190void
5191Perl_mem_log_del_sv(const SV *sv,
5192 const char *filename, const int linenumber,
5193 const char *funcname)
5194{
5195 mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5196 filename, linenumber, funcname);
5197}
5198
5199#endif /* PERL_MEM_LOG */
5200
5201/*
5202=for apidoc_section $string
5203=for apidoc quadmath_format_valid
5204
5205C<quadmath_snprintf()> is very strict about its C<format> string and will
5206fail, returning -1, if the format is invalid. It accepts exactly
5207one format spec.
5208
5209C<quadmath_format_valid()> checks that the intended single spec looks
5210sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
5211and has C<Q> before it. This is not a full "printf syntax check",
5212just the basics.
5213
5214Returns true if it is valid, false if not.
5215
5216See also L</quadmath_format_needed>.
5217
5218=cut
5219*/
5220#ifdef USE_QUADMATH
5221bool
5222Perl_quadmath_format_valid(const char* format)
5223{
5224 STRLEN len;
5225
5226 PERL_ARGS_ASSERT_QUADMATH_FORMAT_VALID;
5227
5228 if (format[0] != '%' || strchr(format + 1, '%'))
5229 return FALSE;
5230 len = strlen(format);
5231 /* minimum length three: %Qg */
5232 if (len < 3 || memCHRs("efgaEFGA", format[len - 1]) == NULL)
5233 return FALSE;
5234 if (format[len - 2] != 'Q')
5235 return FALSE;
5236 return TRUE;
5237}
5238#endif
5239
5240/*
5241=for apidoc quadmath_format_needed
5242
5243C<quadmath_format_needed()> returns true if the C<format> string seems to
5244contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
5245or returns false otherwise.
5246
5247The format specifier detection is not complete printf-syntax detection,
5248but it should catch most common cases.
5249
5250If true is returned, those arguments B<should> in theory be processed
5251with C<quadmath_snprintf()>, but in case there is more than one such
5252format specifier (see L</quadmath_format_valid>), and if there is
5253anything else beyond that one (even just a single byte), they
5254B<cannot> be processed because C<quadmath_snprintf()> is very strict,
5255accepting only one format spec, and nothing else.
5256In this case, the code should probably fail.
5257
5258=cut
5259*/
5260#ifdef USE_QUADMATH
5261bool
5262Perl_quadmath_format_needed(const char* format)
5263{
5264 const char *p = format;
5265 const char *q;
5266
5267 PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5268
5269 while ((q = strchr(p, '%'))) {
5270 q++;
5271 if (*q == '+') /* plus */
5272 q++;
5273 if (*q == '#') /* alt */
5274 q++;
5275 if (*q == '*') /* width */
5276 q++;
5277 else {
5278 if (isDIGIT(*q)) {
5279 while (isDIGIT(*q)) q++;
5280 }
5281 }
5282 if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5283 q++;
5284 if (*q == '*')
5285 q++;
5286 else
5287 while (isDIGIT(*q)) q++;
5288 }
5289 if (memCHRs("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5290 return TRUE;
5291 p = q + 1;
5292 }
5293 return FALSE;
5294}
5295#endif
5296
5297/*
5298=for apidoc my_snprintf
5299
5300The C library C<snprintf> functionality, if available and
5301standards-compliant (uses C<vsnprintf>, actually). However, if the
5302C<vsnprintf> is not available, will unfortunately use the unsafe
5303C<vsprintf> which can overrun the buffer (there is an overrun check,
5304but that may be too late). Consider using C<sv_vcatpvf> instead, or
5305getting C<vsnprintf>.
5306
5307=cut
5308*/
5309int
5310Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5311{
5312 int retval = -1;
5313 va_list ap;
5314 PERL_ARGS_ASSERT_MY_SNPRINTF;
5315#ifndef HAS_VSNPRINTF
5316 PERL_UNUSED_VAR(len);
5317#endif
5318 va_start(ap, format);
5319#ifdef USE_QUADMATH
5320 {
5321 bool quadmath_valid = FALSE;
5322 if (quadmath_format_valid(format)) {
5323 /* If the format looked promising, use it as quadmath. */
5324 retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
5325 if (retval == -1) {
5326 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5327 }
5328 quadmath_valid = TRUE;
5329 }
5330 /* quadmath_format_single() will return false for example for
5331 * "foo = %g", or simply "%g". We could handle the %g by
5332 * using quadmath for the NV args. More complex cases of
5333 * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
5334 * quadmath-valid but has stuff in front).
5335 *
5336 * Handling the "Q-less" cases right would require walking
5337 * through the va_list and rewriting the format, calling
5338 * quadmath for the NVs, building a new va_list, and then
5339 * letting vsnprintf/vsprintf to take care of the other
5340 * arguments. This may be doable.
5341 *
5342 * We do not attempt that now. But for paranoia, we here try
5343 * to detect some common (but not all) cases where the
5344 * "Q-less" %[efgaEFGA] formats are present, and die if
5345 * detected. This doesn't fix the problem, but it stops the
5346 * vsnprintf/vsprintf pulling doubles off the va_list when
5347 * __float128 NVs should be pulled off instead.
5348 *
5349 * If quadmath_format_needed() returns false, we are reasonably
5350 * certain that we can call vnsprintf() or vsprintf() safely. */
5351 if (!quadmath_valid && quadmath_format_needed(format))
5352 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5353
5354 }
5355#endif
5356 if (retval == -1)
5357#ifdef HAS_VSNPRINTF
5358 retval = vsnprintf(buffer, len, format, ap);
5359#else
5360 retval = vsprintf(buffer, format, ap);
5361#endif
5362 va_end(ap);
5363 /* vsprintf() shows failure with < 0 */
5364 if (retval < 0
5365#ifdef HAS_VSNPRINTF
5366 /* vsnprintf() shows failure with >= len */
5367 ||
5368 (len > 0 && (Size_t)retval >= len)
5369#endif
5370 )
5371 Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5372 return retval;
5373}
5374
5375/*
5376=for apidoc my_vsnprintf
5377
5378The C library C<vsnprintf> if available and standards-compliant.
5379However, if the C<vsnprintf> is not available, will unfortunately
5380use the unsafe C<vsprintf> which can overrun the buffer (there is an
5381overrun check, but that may be too late). Consider using
5382C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5383
5384=cut
5385*/
5386int
5387Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5388{
5389#ifdef USE_QUADMATH
5390 PERL_UNUSED_ARG(buffer);
5391 PERL_UNUSED_ARG(len);
5392 PERL_UNUSED_ARG(format);
5393 /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
5394 PERL_UNUSED_ARG((void*)ap);
5395 Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5396 return 0;
5397#else
5398 int retval;
5399#ifdef NEED_VA_COPY
5400 va_list apc;
5401
5402 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5403 Perl_va_copy(ap, apc);
5404# ifdef HAS_VSNPRINTF
5405 retval = vsnprintf(buffer, len, format, apc);
5406# else
5407 PERL_UNUSED_ARG(len);
5408 retval = vsprintf(buffer, format, apc);
5409# endif
5410 va_end(apc);
5411#else
5412# ifdef HAS_VSNPRINTF
5413 retval = vsnprintf(buffer, len, format, ap);
5414# else
5415 PERL_UNUSED_ARG(len);
5416 retval = vsprintf(buffer, format, ap);
5417# endif
5418#endif /* #ifdef NEED_VA_COPY */
5419 /* vsprintf() shows failure with < 0 */
5420 if (retval < 0
5421#ifdef HAS_VSNPRINTF
5422 /* vsnprintf() shows failure with >= len */
5423 ||
5424 (len > 0 && (Size_t)retval >= len)
5425#endif
5426 )
5427 Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5428 return retval;
5429#endif
5430}
5431
5432void
5433Perl_my_clearenv(pTHX)
5434{
5435#if ! defined(PERL_MICRO)
5436# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5437 PerlEnv_clearenv();
5438# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5439# if defined(USE_ENVIRON_ARRAY)
5440# if defined(USE_ITHREADS)
5441 /* only the parent thread can clobber the process environment, so no need
5442 * to use a mutex */
5443 if (PL_curinterp == aTHX)
5444# endif /* USE_ITHREADS */
5445 {
5446# if ! defined(PERL_USE_SAFE_PUTENV)
5447 if ( !PL_use_safe_putenv) {
5448 I32 i;
5449 if (environ == PL_origenviron)
5450 environ = (char**)safesysmalloc(sizeof(char*));
5451 else
5452 for (i = 0; environ[i]; i++)
5453 (void)safesysfree(environ[i]);
5454 }
5455 environ[0] = NULL;
5456# else /* PERL_USE_SAFE_PUTENV */
5457# if defined(HAS_CLEARENV)
5458 (void)clearenv();
5459# elif defined(HAS_UNSETENV)
5460 int bsiz = 80; /* Most envvar names will be shorter than this. */
5461 char *buf = (char*)safesysmalloc(bsiz);
5462 while (*environ != NULL) {
5463 char *e = strchr(*environ, '=');
5464 int l = e ? e - *environ : (int)strlen(*environ);
5465 if (bsiz < l + 1) {
5466 (void)safesysfree(buf);
5467 bsiz = l + 1; /* + 1 for the \0. */
5468 buf = (char*)safesysmalloc(bsiz);
5469 }
5470 memcpy(buf, *environ, l);
5471 buf[l] = '\0';
5472 (void)unsetenv(buf);
5473 }
5474 (void)safesysfree(buf);
5475# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5476 /* Just null environ and accept the leakage. */
5477 *environ = NULL;
5478# endif /* HAS_CLEARENV || HAS_UNSETENV */
5479# endif /* ! PERL_USE_SAFE_PUTENV */
5480 }
5481# endif /* USE_ENVIRON_ARRAY */
5482# endif /* PERL_IMPLICIT_SYS || WIN32 */
5483#endif /* PERL_MICRO */
5484}
5485
5486#ifdef PERL_IMPLICIT_CONTEXT
5487
5488
5489/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5490the global PL_my_cxt_index is incremented, and that value is assigned to
5491that module's static my_cxt_index (who's address is passed as an arg).
5492Then, for each interpreter this function is called for, it makes sure a
5493void* slot is available to hang the static data off, by allocating or
5494extending the interpreter's PL_my_cxt_list array */
5495
5496void *
5497Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
5498{
5499 void *p;
5500 int index;
5501
5502 PERL_ARGS_ASSERT_MY_CXT_INIT;
5503
5504 index = *indexp;
5505 /* do initial check without locking.
5506 * -1: not allocated or another thread currently allocating
5507 * other: already allocated by another thread
5508 */
5509 if (index == -1) {
5510 MUTEX_LOCK(&PL_my_ctx_mutex);
5511 /*now a stricter check with locking */
5512 index = *indexp;
5513 if (index == -1)
5514 /* this module hasn't been allocated an index yet */
5515 *indexp = PL_my_cxt_index++;
5516 index = *indexp;
5517 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5518 }
5519
5520 /* make sure the array is big enough */
5521 if (PL_my_cxt_size <= index) {
5522 if (PL_my_cxt_size) {
5523 IV new_size = PL_my_cxt_size;
5524 while (new_size <= index)
5525 new_size *= 2;
5526 Renew(PL_my_cxt_list, new_size, void *);
5527 PL_my_cxt_size = new_size;
5528 }
5529 else {
5530 PL_my_cxt_size = 16;
5531 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5532 }
5533 }
5534 /* newSV() allocates one more than needed */
5535 p = (void*)SvPVX(newSV(size-1));
5536 PL_my_cxt_list[index] = p;
5537 Zero(p, size, char);
5538 return p;
5539}
5540
5541#endif /* PERL_IMPLICIT_CONTEXT */
5542
5543
5544/* Perl_xs_handshake():
5545 implement the various XS_*_BOOTCHECK macros, which are added to .c
5546 files by ExtUtils::ParseXS, to check that the perl the module was built
5547 with is binary compatible with the running perl.
5548
5549 usage:
5550 Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5551 [U32 items, U32 ax], [char * api_version], [char * xs_version])
5552
5553 The meaning of the varargs is determined the U32 key arg (which is not
5554 a format string). The fields of key are assembled by using HS_KEY().
5555
5556 Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5557 "PerlInterpreter *" and represents the callers context; otherwise it is
5558 of type "CV *", and is the boot xsub's CV.
5559
5560 v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5561 for example, and IO.dll was linked with threaded perl524.dll, and both
5562 perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5563 successfully can load IO.dll into the process but simultaneously it
5564 loaded an interpreter of a different version into the process, and XS
5565 code will naturally pass SV*s created by perl524.dll for perl526.dll to
5566 use through perl526.dll's my_perl->Istack_base.
5567
5568 v_my_perl cannot be the first arg, since then 'key' will be out of
5569 place in a threaded vs non-threaded mixup; and analyzing the key
5570 number's bitfields won't reveal the problem, since it will be a valid
5571 key (unthreaded perl) on interp side, but croak will report the XS mod's
5572 key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5573 it's a threaded perl and an unthreaded XS module, threaded perl will
5574 look at an uninit C stack or an uninit register to get 'key'
5575 (remember that it assumes that the 1st arg is the interp cxt).
5576
5577 'file' is the source filename of the caller.
5578*/
5579
5580I32
5581Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
5582{
5583 va_list args;
5584 U32 items, ax;
5585 void * got;
5586 void * need;
5587#ifdef PERL_IMPLICIT_CONTEXT
5588 dTHX;
5589 tTHX xs_interp;
5590#else
5591 CV* cv;
5592 SV *** xs_spp;
5593#endif
5594 PERL_ARGS_ASSERT_XS_HANDSHAKE;
5595 va_start(args, file);
5596
5597 got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
5598 need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
5599 if (UNLIKELY(got != need))
5600 goto bad_handshake;
5601/* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5602 by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5603 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5604 dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5605 passed to the XS DLL */
5606#ifdef PERL_IMPLICIT_CONTEXT
5607 xs_interp = (tTHX)v_my_perl;
5608 got = xs_interp;
5609 need = my_perl;
5610#else
5611/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5612 loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5613 but the DynaLoder/Perl that started the process and loaded the XS DLL is
5614 unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5615 through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5616 location in the unthreaded perl binary) stored in CV * to figure out if this
5617 Perl_xs_handshake was called by the same pp_entersub */
5618 cv = (CV*)v_my_perl;
5619 xs_spp = (SV***)CvHSCXT(cv);
5620 got = xs_spp;
5621 need = &PL_stack_sp;
5622#endif
5623 if(UNLIKELY(got != need)) {
5624 bad_handshake:/* recycle branch and string from above */
5625 if(got != (void *)HSf_NOCHK)
5626 noperl_die("%s: loadable library and perl binaries are mismatched"
5627 " (got handshake key %p, needed %p)\n",
5628 file, got, need);
5629 }
5630
5631 if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
5632 SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5633 PL_xsubfilename = file; /* so the old name must be restored for
5634 additional XSUBs to register themselves */
5635 /* XSUBs can't be perl lang/perl5db.pl debugged
5636 if (PERLDB_LINE_OR_SAVESRC)
5637 (void)gv_fetchfile(file); */
5638 }
5639
5640 if(key & HSf_POPMARK) {
5641 ax = POPMARK;
5642 { SV **mark = PL_stack_base + ax++;
5643 { dSP;
5644 items = (I32)(SP - MARK);
5645 }
5646 }
5647 } else {
5648 items = va_arg(args, U32);
5649 ax = va_arg(args, U32);
5650 }
5651 {
5652 U32 apiverlen;
5653 assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
5654 if((apiverlen = HS_GETAPIVERLEN(key))) {
5655 char * api_p = va_arg(args, char*);
5656 if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5657 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5658 sizeof("v" PERL_API_VERSION_STRING)-1))
5659 Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
5660 api_p, SVfARG(PL_stack_base[ax + 0]),
5661 "v" PERL_API_VERSION_STRING);
5662 }
5663 }
5664 {
5665 U32 xsverlen;
5666 assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
5667 if((xsverlen = HS_GETXSVERLEN(key)))
5668 S_xs_version_bootcheck(aTHX_
5669 items, ax, va_arg(args, char*), xsverlen);
5670 }
5671 va_end(args);
5672 return ax;
5673}
5674
5675
5676STATIC void
5677S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5678 STRLEN xs_len)
5679{
5680 SV *sv;
5681 const char *vn = NULL;
5682 SV *const module = PL_stack_base[ax];
5683
5684 PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5685
5686 if (items >= 2) /* version supplied as bootstrap arg */
5687 sv = PL_stack_base[ax + 1];
5688 else {
5689 /* XXX GV_ADDWARN */
5690 vn = "XS_VERSION";
5691 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
5692 if (!sv || !SvOK(sv)) {
5693 vn = "VERSION";
5694 sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
5695 }
5696 }
5697 if (sv) {
5698 SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5699 SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5700 ? sv : sv_2mortal(new_version(sv));
5701 xssv = upg_version(xssv, 0);
5702 if ( vcmp(pmsv,xssv) ) {
5703 SV *string = vstringify(xssv);
5704 SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf
5705 " does not match ", SVfARG(module), SVfARG(string));
5706
5707 SvREFCNT_dec(string);
5708 string = vstringify(pmsv);
5709
5710 if (vn) {
5711 Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
5712 SVfARG(string));
5713 } else {
5714 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
5715 }
5716 SvREFCNT_dec(string);
5717
5718 Perl_sv_2mortal(aTHX_ xpt);
5719 Perl_croak_sv(aTHX_ xpt);
5720 }
5721 }
5722}
5723
5724/*
5725=for apidoc my_strlcat
5726
5727The C library C<strlcat> if available, or a Perl implementation of it.
5728This operates on C C<NUL>-terminated strings.
5729
5730C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
5731most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
5732unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5733practice this should not happen as it means that either C<size> is incorrect or
5734that C<dst> is not a proper C<NUL>-terminated string).
5735
5736Note that C<size> is the full size of the destination buffer and
5737the result is guaranteed to be C<NUL>-terminated if there is room. Note that