This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: further doc tweaks
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
1129b882
NC
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
a687059c 5 *
d48672a2
LW
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.
8d063cd8 8 *
8d063cd8 9 */
a0d0e21e
LW
10
11/*
4ac71550
TC
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"]
a0d0e21e 16 */
8d063cd8 17
166f8a29
DM
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
8d063cd8 24#include "EXTERN.h"
864dbfa3 25#define PERL_IN_UTIL_C
8d063cd8 26#include "perl.h"
62b28dd9 27
64ca3a65 28#ifndef PERL_MICRO
a687059c 29#include <signal.h>
36477c24
PP
30#ifndef SIG_ERR
31# define SIG_ERR ((Sighandler_t) -1)
32#endif
64ca3a65 33#endif
36477c24 34
172d2248
OS
35#ifdef __Lynx__
36/* Missing protos on LynxOS */
37int putenv(char *);
38#endif
39
ff68c719
PP
40#ifdef I_SYS_WAIT
41# include <sys/wait.h>
42#endif
43
868439a2
JH
44#ifdef HAS_SELECT
45# ifdef I_SYS_SELECT
46# include <sys/select.h>
47# endif
48#endif
49
8d063cd8 50#define FLUSH
8d063cd8 51
16cebae2
GS
52#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
53# define FD_CLOEXEC 1 /* NeXT needs this */
54#endif
55
a687059c
LW
56/* NOTE: Do not call the next three routines directly. Use the macros
57 * in handy.h, so that we can easily redefine everything to do tracking of
58 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 59 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW
60 */
61
ca8d8976
NC
62static char *
63S_write_no_mem(pTHX)
64{
97aff369 65 dVAR;
ca8d8976
NC
66 /* Can't use PerlIO to write as it allocates memory */
67 PerlLIO_write(PerlIO_fileno(Perl_error_log),
68 PL_no_mem, strlen(PL_no_mem));
69 my_exit(1);
1f440eb2 70 NORETURN_FUNCTION_END;
ca8d8976
NC
71}
72
26fa51c3
AMS
73/* paranoid version of system's malloc() */
74
bd4080b3 75Malloc_t
4f63d024 76Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 77{
54aff467 78 dTHX;
bd4080b3 79 Malloc_t ptr;
55497cff 80#ifdef HAS_64K_LIMIT
62b28dd9 81 if (size > 0xffff) {
bf49b057 82 PerlIO_printf(Perl_error_log,
16cebae2 83 "Allocation too large: %lx\n", size) FLUSH;
54aff467 84 my_exit(1);
62b28dd9 85 }
55497cff 86#endif /* HAS_64K_LIMIT */
e8dda941
JD
87#ifdef PERL_TRACK_MEMPOOL
88 size += sTHX;
89#endif
34de22dd
LW
90#ifdef DEBUGGING
91 if ((long)size < 0)
4f63d024 92 Perl_croak_nocontext("panic: malloc");
34de22dd 93#endif
12ae5dfc 94 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 95 PERL_ALLOC_CHECK(ptr);
97835f67 96 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
bd61b366 97 if (ptr != NULL) {
e8dda941 98#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
99 struct perl_memory_debug_header *const header
100 = (struct perl_memory_debug_header *)ptr;
9a083ecf
NC
101#endif
102
103#ifdef PERL_POISON
7e337ee0 104 PoisonNew(((char *)ptr), size, char);
9a083ecf 105#endif
7cb608b5 106
9a083ecf 107#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
108 header->interpreter = aTHX;
109 /* Link us into the list. */
110 header->prev = &PL_memory_debug_header;
111 header->next = PL_memory_debug_header.next;
112 PL_memory_debug_header.next = header;
113 header->next->prev = header;
cd1541b2 114# ifdef PERL_POISON
7cb608b5 115 header->size = size;
cd1541b2 116# endif
e8dda941
JD
117 ptr = (Malloc_t)((char*)ptr+sTHX);
118#endif
8d063cd8 119 return ptr;
e8dda941 120}
3280af22 121 else if (PL_nomemok)
bd61b366 122 return NULL;
8d063cd8 123 else {
0bd48802 124 return write_no_mem();
8d063cd8
LW
125 }
126 /*NOTREACHED*/
127}
128
f2517201 129/* paranoid version of system's realloc() */
8d063cd8 130
bd4080b3 131Malloc_t
4f63d024 132Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 133{
54aff467 134 dTHX;
bd4080b3 135 Malloc_t ptr;
9a34ef1d 136#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
6ad3d225 137 Malloc_t PerlMem_realloc();
ecfc5424 138#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 139
a1d180c4 140#ifdef HAS_64K_LIMIT
5f05dabc 141 if (size > 0xffff) {
bf49b057 142 PerlIO_printf(Perl_error_log,
5f05dabc 143 "Reallocation too large: %lx\n", size) FLUSH;
54aff467 144 my_exit(1);
5f05dabc 145 }
55497cff 146#endif /* HAS_64K_LIMIT */
7614df0c 147 if (!size) {
f2517201 148 safesysfree(where);
7614df0c
JD
149 return NULL;
150 }
151
378cc40b 152 if (!where)
f2517201 153 return safesysmalloc(size);
e8dda941
JD
154#ifdef PERL_TRACK_MEMPOOL
155 where = (Malloc_t)((char*)where-sTHX);
156 size += sTHX;
7cb608b5
NC
157 {
158 struct perl_memory_debug_header *const header
159 = (struct perl_memory_debug_header *)where;
160
161 if (header->interpreter != aTHX) {
162 Perl_croak_nocontext("panic: realloc from wrong pool");
163 }
164 assert(header->next->prev == header);
165 assert(header->prev->next == header);
cd1541b2 166# ifdef PERL_POISON
7cb608b5
NC
167 if (header->size > size) {
168 const MEM_SIZE freed_up = header->size - size;
169 char *start_of_freed = ((char *)where) + size;
7e337ee0 170 PoisonFree(start_of_freed, freed_up, char);
7cb608b5
NC
171 }
172 header->size = size;
cd1541b2 173# endif
7cb608b5 174 }
e8dda941 175#endif
34de22dd
LW
176#ifdef DEBUGGING
177 if ((long)size < 0)
4f63d024 178 Perl_croak_nocontext("panic: realloc");
34de22dd 179#endif
12ae5dfc 180 ptr = (Malloc_t)PerlMem_realloc(where,size);
da927450 181 PERL_ALLOC_CHECK(ptr);
a1d180c4 182
4fd0a9b8
NC
183 /* MUST do this fixup first, before doing ANYTHING else, as anything else
184 might allocate memory/free/move memory, and until we do the fixup, it
185 may well be chasing (and writing to) free memory. */
e8dda941 186#ifdef PERL_TRACK_MEMPOOL
4fd0a9b8 187 if (ptr != NULL) {
7cb608b5
NC
188 struct perl_memory_debug_header *const header
189 = (struct perl_memory_debug_header *)ptr;
190
9a083ecf
NC
191# ifdef PERL_POISON
192 if (header->size < size) {
193 const MEM_SIZE fresh = size - header->size;
194 char *start_of_fresh = ((char *)ptr) + size;
7e337ee0 195 PoisonNew(start_of_fresh, fresh, char);
9a083ecf
NC
196 }
197# endif
198
7cb608b5
NC
199 header->next->prev = header;
200 header->prev->next = header;
201
e8dda941 202 ptr = (Malloc_t)((char*)ptr+sTHX);
4fd0a9b8 203 }
e8dda941 204#endif
4fd0a9b8
NC
205
206 /* In particular, must do that fixup above before logging anything via
207 *printf(), as it can reallocate memory, which can cause SEGVs. */
208
209 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
210 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
211
212
213 if (ptr != NULL) {
8d063cd8 214 return ptr;
e8dda941 215 }
3280af22 216 else if (PL_nomemok)
bd61b366 217 return NULL;
8d063cd8 218 else {
0bd48802 219 return write_no_mem();
8d063cd8
LW
220 }
221 /*NOTREACHED*/
222}
223
f2517201 224/* safe version of system's free() */
8d063cd8 225
54310121 226Free_t
4f63d024 227Perl_safesysfree(Malloc_t where)
8d063cd8 228{
e8dda941 229#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
54aff467 230 dTHX;
97aff369
JH
231#else
232 dVAR;
155aba94 233#endif
97835f67 234 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 235 if (where) {
e8dda941
JD
236#ifdef PERL_TRACK_MEMPOOL
237 where = (Malloc_t)((char*)where-sTHX);
cd1541b2 238 {
7cb608b5
NC
239 struct perl_memory_debug_header *const header
240 = (struct perl_memory_debug_header *)where;
241
242 if (header->interpreter != aTHX) {
243 Perl_croak_nocontext("panic: free from wrong pool");
244 }
245 if (!header->prev) {
cd1541b2
NC
246 Perl_croak_nocontext("panic: duplicate free");
247 }
7cb608b5
NC
248 if (!(header->next) || header->next->prev != header
249 || header->prev->next != header) {
250 Perl_croak_nocontext("panic: bad free");
cd1541b2 251 }
7cb608b5
NC
252 /* Unlink us from the chain. */
253 header->next->prev = header->prev;
254 header->prev->next = header->next;
255# ifdef PERL_POISON
7e337ee0 256 PoisonNew(where, header->size, char);
cd1541b2 257# endif
7cb608b5
NC
258 /* Trigger the duplicate free warning. */
259 header->next = NULL;
260 }
e8dda941 261#endif
6ad3d225 262 PerlMem_free(where);
378cc40b 263 }
8d063cd8
LW
264}
265
f2517201 266/* safe version of system's calloc() */
1050c9ca 267
bd4080b3 268Malloc_t
4f63d024 269Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 270{
54aff467 271 dTHX;
bd4080b3 272 Malloc_t ptr;
ad7244db 273 MEM_SIZE total_size = 0;
1050c9ca 274
ad7244db 275 /* Even though calloc() for zero bytes is strange, be robust. */
19a94d75 276 if (size && (count <= MEM_SIZE_MAX / size))
ad7244db
JH
277 total_size = size * count;
278 else
f1f66076 279 Perl_croak_nocontext("%s", PL_memory_wrap);
ad7244db 280#ifdef PERL_TRACK_MEMPOOL
19a94d75 281 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
ad7244db
JH
282 total_size += sTHX;
283 else
f1f66076 284 Perl_croak_nocontext("%s", PL_memory_wrap);
ad7244db 285#endif
55497cff 286#ifdef HAS_64K_LIMIT
e1a95402 287 if (total_size > 0xffff) {
bf49b057 288 PerlIO_printf(Perl_error_log,
e1a95402 289 "Allocation too large: %lx\n", total_size) FLUSH;
54aff467 290 my_exit(1);
5f05dabc 291 }
55497cff 292#endif /* HAS_64K_LIMIT */
1050c9ca
PP
293#ifdef DEBUGGING
294 if ((long)size < 0 || (long)count < 0)
4f63d024 295 Perl_croak_nocontext("panic: calloc");
1050c9ca 296#endif
e8dda941 297#ifdef PERL_TRACK_MEMPOOL
e1a95402
NC
298 /* Have to use malloc() because we've added some space for our tracking
299 header. */
ad7244db
JH
300 /* malloc(0) is non-portable. */
301 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
e1a95402
NC
302#else
303 /* Use calloc() because it might save a memset() if the memory is fresh
304 and clean from the OS. */
ad7244db
JH
305 if (count && size)
306 ptr = (Malloc_t)PerlMem_calloc(count, size);
307 else /* calloc(0) is non-portable. */
308 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
e8dda941 309#endif
da927450 310 PERL_ALLOC_CHECK(ptr);
e1a95402 311 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
bd61b366 312 if (ptr != NULL) {
e8dda941 313#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC
314 {
315 struct perl_memory_debug_header *const header
316 = (struct perl_memory_debug_header *)ptr;
317
e1a95402 318 memset((void*)ptr, 0, total_size);
7cb608b5
NC
319 header->interpreter = aTHX;
320 /* Link us into the list. */
321 header->prev = &PL_memory_debug_header;
322 header->next = PL_memory_debug_header.next;
323 PL_memory_debug_header.next = header;
324 header->next->prev = header;
cd1541b2 325# ifdef PERL_POISON
e1a95402 326 header->size = total_size;
cd1541b2 327# endif
7cb608b5
NC
328 ptr = (Malloc_t)((char*)ptr+sTHX);
329 }
e8dda941 330#endif
1050c9ca
PP
331 return ptr;
332 }
3280af22 333 else if (PL_nomemok)
bd61b366 334 return NULL;
0bd48802 335 return write_no_mem();
1050c9ca
PP
336}
337
cae6d0e5
GS
338/* These must be defined when not using Perl's malloc for binary
339 * compatibility */
340
341#ifndef MYMALLOC
342
343Malloc_t Perl_malloc (MEM_SIZE nbytes)
344{
345 dTHXs;
077a72a9 346 return (Malloc_t)PerlMem_malloc(nbytes);
cae6d0e5
GS
347}
348
349Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
350{
351 dTHXs;
077a72a9 352 return (Malloc_t)PerlMem_calloc(elements, size);
cae6d0e5
GS
353}
354
355Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
356{
357 dTHXs;
077a72a9 358 return (Malloc_t)PerlMem_realloc(where, nbytes);
cae6d0e5
GS
359}
360
361Free_t Perl_mfree (Malloc_t where)
362{
363 dTHXs;
364 PerlMem_free(where);
365}
366
367#endif
368
8d063cd8
LW
369/* copy a string up to some (non-backslashed) delimiter, if any */
370
371char *
04c9e624 372Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
8d063cd8 373{
fc36a67e 374 register I32 tolen;
35da51f7 375
7918f24d
NC
376 PERL_ARGS_ASSERT_DELIMCPY;
377
fc36a67e 378 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b 379 if (*from == '\\') {
35da51f7 380 if (from[1] != delim) {
fc36a67e
PP
381 if (to < toend)
382 *to++ = *from;
383 tolen++;
fc36a67e 384 }
35da51f7 385 from++;
378cc40b 386 }
bedebaa5 387 else if (*from == delim)
8d063cd8 388 break;
fc36a67e
PP
389 if (to < toend)
390 *to++ = *from;
8d063cd8 391 }
bedebaa5
CS
392 if (to < toend)
393 *to = '\0';
fc36a67e 394 *retlen = tolen;
73d840c0 395 return (char *)from;
8d063cd8
LW
396}
397
398/* return ptr to little string in big string, NULL if not found */
378cc40b 399/* This routine was donated by Corey Satten. */
8d063cd8
LW
400
401char *
04c9e624 402Perl_instr(register const char *big, register const char *little)
378cc40b 403{
79072805 404 register I32 first;
378cc40b 405
7918f24d
NC
406 PERL_ARGS_ASSERT_INSTR;
407
a687059c 408 if (!little)
08105a92 409 return (char*)big;
a687059c 410 first = *little++;
378cc40b 411 if (!first)
08105a92 412 return (char*)big;
378cc40b 413 while (*big) {
66a1b24b 414 register const char *s, *x;
378cc40b
LW
415 if (*big++ != first)
416 continue;
417 for (x=big,s=little; *s; /**/ ) {
418 if (!*x)
bd61b366 419 return NULL;
4fc877ac 420 if (*s != *x)
378cc40b 421 break;
4fc877ac
AL
422 else {
423 s++;
424 x++;
378cc40b
LW
425 }
426 }
427 if (!*s)
08105a92 428 return (char*)(big-1);
378cc40b 429 }
bd61b366 430 return NULL;
378cc40b 431}
8d063cd8 432
a687059c
LW
433/* same as instr but allow embedded nulls */
434
435char *
04c9e624 436Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 437{
7918f24d 438 PERL_ARGS_ASSERT_NINSTR;
4c8626be
GA
439 if (little >= lend)
440 return (char*)big;
441 {
8ba22ff4 442 const char first = *little;
4c8626be 443 const char *s, *x;
8ba22ff4 444 bigend -= lend - little++;
4c8626be
GA
445 OUTER:
446 while (big <= bigend) {
b0ca24ee
JH
447 if (*big++ == first) {
448 for (x=big,s=little; s < lend; x++,s++) {
449 if (*s != *x)
450 goto OUTER;
451 }
452 return (char*)(big-1);
4c8626be 453 }
4c8626be 454 }
378cc40b 455 }
bd61b366 456 return NULL;
a687059c
LW
457}
458
459/* reverse of the above--find last substring */
460
461char *
04c9e624 462Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
a687059c 463{
08105a92 464 register const char *bigbeg;
e1ec3a88 465 register const I32 first = *little;
7452cf6a 466 register const char * const littleend = lend;
a687059c 467
7918f24d
NC
468 PERL_ARGS_ASSERT_RNINSTR;
469
260d78c9 470 if (little >= littleend)
08105a92 471 return (char*)bigend;
a687059c
LW
472 bigbeg = big;
473 big = bigend - (littleend - little++);
474 while (big >= bigbeg) {
66a1b24b 475 register const char *s, *x;
a687059c
LW
476 if (*big-- != first)
477 continue;
478 for (x=big+2,s=little; s < littleend; /**/ ) {
4fc877ac 479 if (*s != *x)
a687059c 480 break;
4fc877ac
AL
481 else {
482 x++;
483 s++;
a687059c
LW
484 }
485 }
486 if (s >= littleend)
08105a92 487 return (char*)(big+1);
378cc40b 488 }
bd61b366 489 return NULL;
378cc40b 490}
a687059c 491
cf93c79d
IZ
492/* As a space optimization, we do not compile tables for strings of length
493 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
494 special-cased in fbm_instr().
495
496 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
497
954c1994 498/*
ccfc67b7
JH
499=head1 Miscellaneous Functions
500
954c1994
GS
501=for apidoc fbm_compile
502
503Analyses the string in order to make fast searches on it using fbm_instr()
504-- the Boyer-Moore algorithm.
505
506=cut
507*/
508
378cc40b 509void
7506f9c3 510Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 511{
97aff369 512 dVAR;
0d46e09a 513 register const U8 *s;
79072805 514 register U32 i;
0b71040e 515 STRLEN len;
cb742848 516 U32 rarest = 0;
79072805
LW
517 U32 frequency = 256;
518
7918f24d
NC
519 PERL_ARGS_ASSERT_FBM_COMPILE;
520
c517dc2b 521 if (flags & FBMcf_TAIL) {
890ce7af 522 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 523 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH
524 if (mg && mg->mg_len >= 0)
525 mg->mg_len++;
526 }
9cbe880b 527 s = (U8*)SvPV_force_mutable(sv, len);
d1be9408 528 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 529 return;
cecf5685 530 SvUPGRADE(sv, SVt_PVGV);
78d0cf80 531 SvIOK_off(sv);
8eeaf79a
NC
532 SvNOK_off(sv);
533 SvVALID_on(sv);
02128f11 534 if (len > 2) {
9cbe880b 535 const unsigned char *sb;
66a1b24b 536 const U8 mlen = (len>255) ? 255 : (U8)len;
890ce7af 537 register U8 *table;
cf93c79d 538
d8419e03
NC
539 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
540 table
541 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
542 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
7506f9c3 543 memset((void*)table, mlen, 256);
02128f11 544 i = 0;
7506f9c3 545 sb = s - mlen + 1; /* first char (maybe) */
cf93c79d
IZ
546 while (s >= sb) {
547 if (table[*s] == mlen)
7506f9c3 548 table[*s] = (U8)i;
cf93c79d
IZ
549 s--, i++;
550 }
d0688fc4
NC
551 } else {
552 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
378cc40b 553 }
a0714e2c 554 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
378cc40b 555
9cbe880b 556 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
bbce6d69 557 for (i = 0; i < len; i++) {
22c35a8c 558 if (PL_freq[s[i]] < frequency) {
bbce6d69 559 rarest = i;
22c35a8c 560 frequency = PL_freq[s[i]];
378cc40b
LW
561 }
562 }
610460f9 563 BmFLAGS(sv) = (U8)flags;
79072805 564 BmRARE(sv) = s[rarest];
44a10c71 565 BmPREVIOUS(sv) = rarest;
cf93c79d
IZ
566 BmUSEFUL(sv) = 100; /* Initial value */
567 if (flags & FBMcf_TAIL)
568 SvTAIL_on(sv);
8eeaf79a
NC
569 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
570 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
378cc40b
LW
571}
572
cf93c79d
IZ
573/* If SvTAIL(littlestr), it has a fake '\n' at end. */
574/* If SvTAIL is actually due to \Z or \z, this gives false positives
575 if multiline */
576
954c1994
GS
577/*
578=for apidoc fbm_instr
579
580Returns the location of the SV in the string delimited by C<str> and
bd61b366 581C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
954c1994
GS
582does not have to be fbm_compiled, but the search will not be as fast
583then.
584
585=cut
586*/
587
378cc40b 588char *
864dbfa3 589Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 590{
a687059c 591 register unsigned char *s;
cf93c79d 592 STRLEN l;
9cbe880b
NC
593 register const unsigned char *little
594 = (const unsigned char *)SvPV_const(littlestr,l);
cf93c79d 595 register STRLEN littlelen = l;
e1ec3a88 596 register const I32 multiline = flags & FBMrf_MULTILINE;
cf93c79d 597
7918f24d
NC
598 PERL_ARGS_ASSERT_FBM_INSTR;
599
eb160463 600 if ((STRLEN)(bigend - big) < littlelen) {
a1d180c4 601 if ( SvTAIL(littlestr)
eb160463 602 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 603 && (littlelen == 1
12ae5dfc 604 || (*big == *little &&
27da23d5 605 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 606 return (char*)big;
bd61b366 607 return NULL;
cf93c79d 608 }
378cc40b 609
cf93c79d 610 if (littlelen <= 2) { /* Special-cased */
cf93c79d
IZ
611
612 if (littlelen == 1) {
613 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
614 /* Know that bigend != big. */
615 if (bigend[-1] == '\n')
616 return (char *)(bigend - 1);
617 return (char *) bigend;
618 }
619 s = big;
620 while (s < bigend) {
621 if (*s == *little)
622 return (char *)s;
623 s++;
624 }
625 if (SvTAIL(littlestr))
626 return (char *) bigend;
bd61b366 627 return NULL;
cf93c79d
IZ
628 }
629 if (!littlelen)
630 return (char*)big; /* Cannot be SvTAIL! */
631
632 /* littlelen is 2 */
633 if (SvTAIL(littlestr) && !multiline) {
634 if (bigend[-1] == '\n' && bigend[-2] == *little)
635 return (char*)bigend - 2;
636 if (bigend[-1] == *little)
637 return (char*)bigend - 1;
bd61b366 638 return NULL;
cf93c79d
IZ
639 }
640 {
641 /* This should be better than FBM if c1 == c2, and almost
642 as good otherwise: maybe better since we do less indirection.
643 And we save a lot of memory by caching no table. */
66a1b24b
AL
644 const unsigned char c1 = little[0];
645 const unsigned char c2 = little[1];
cf93c79d
IZ
646
647 s = big + 1;
648 bigend--;
649 if (c1 != c2) {
650 while (s <= bigend) {
651 if (s[0] == c2) {
652 if (s[-1] == c1)
653 return (char*)s - 1;
654 s += 2;
655 continue;
3fe6f2dc 656 }
cf93c79d
IZ
657 next_chars:
658 if (s[0] == c1) {
659 if (s == bigend)
660 goto check_1char_anchor;
661 if (s[1] == c2)
662 return (char*)s;
663 else {
664 s++;
665 goto next_chars;
666 }
667 }
668 else
669 s += 2;
670 }
671 goto check_1char_anchor;
672 }
673 /* Now c1 == c2 */
674 while (s <= bigend) {
675 if (s[0] == c1) {
676 if (s[-1] == c1)
677 return (char*)s - 1;
678 if (s == bigend)
679 goto check_1char_anchor;
680 if (s[1] == c1)
681 return (char*)s;
682 s += 3;
02128f11 683 }
c277df42 684 else
cf93c79d 685 s += 2;
c277df42 686 }
c277df42 687 }
cf93c79d
IZ
688 check_1char_anchor: /* One char and anchor! */
689 if (SvTAIL(littlestr) && (*bigend == *little))
690 return (char *)bigend; /* bigend is already decremented. */
bd61b366 691 return NULL;
d48672a2 692 }
cf93c79d 693 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
bbce6d69 694 s = bigend - littlelen;
a1d180c4 695 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ
696 /* Automatically of length > 2 */
697 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 698 {
bbce6d69 699 return (char*)s; /* how sweet it is */
7506f9c3
GS
700 }
701 if (s[1] == *little
702 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
703 {
cf93c79d 704 return (char*)s + 1; /* how sweet it is */
7506f9c3 705 }
bd61b366 706 return NULL;
02128f11 707 }
cecf5685 708 if (!SvVALID(littlestr)) {
c4420975 709 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ
710 (char*)little, (char*)little + littlelen);
711
712 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
713 /* Chop \n from littlestr: */
714 s = bigend - littlelen + 1;
7506f9c3
GS
715 if (*s == *little
716 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
717 {
3fe6f2dc 718 return (char*)s;
7506f9c3 719 }
bd61b366 720 return NULL;
a687059c 721 }
cf93c79d 722 return b;
a687059c 723 }
a1d180c4 724
3566a07d
NC
725 /* Do actual FBM. */
726 if (littlelen > (STRLEN)(bigend - big))
727 return NULL;
728
729 {
d8419e03
NC
730 register const unsigned char * const table
731 = little + littlelen + PERL_FBM_TABLE_OFFSET;
0d46e09a 732 register const unsigned char *oldlittle;
cf93c79d 733
cf93c79d
IZ
734 --littlelen; /* Last char found by table lookup */
735
736 s = big + littlelen;
737 little += littlelen; /* last char */
738 oldlittle = little;
739 if (s < bigend) {
740 register I32 tmp;
741
742 top2:
7506f9c3 743 if ((tmp = table[*s])) {
cf93c79d 744 if ((s += tmp) < bigend)
62b28dd9 745 goto top2;
cf93c79d
IZ
746 goto check_end;
747 }
748 else { /* less expensive than calling strncmp() */
66a1b24b 749 register unsigned char * const olds = s;
cf93c79d
IZ
750
751 tmp = littlelen;
752
753 while (tmp--) {
754 if (*--s == *--little)
755 continue;
cf93c79d
IZ
756 s = olds + 1; /* here we pay the price for failure */
757 little = oldlittle;
758 if (s < bigend) /* fake up continue to outer loop */
759 goto top2;
760 goto check_end;
761 }
762 return (char *)s;
a687059c 763 }
378cc40b 764 }
cf93c79d 765 check_end:
c8029a41 766 if ( s == bigend
8eeaf79a 767 && (BmFLAGS(littlestr) & FBMcf_TAIL)
12ae5dfc
JH
768 && memEQ((char *)(bigend - littlelen),
769 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 770 return (char*)bigend - littlelen;
bd61b366 771 return NULL;
378cc40b 772 }
378cc40b
LW
773}
774
c277df42
IZ
775/* start_shift, end_shift are positive quantities which give offsets
776 of ends of some substring of bigstr.
a0288114 777 If "last" we want the last occurrence.
c277df42 778 old_posp is the way of communication between consequent calls if
a1d180c4 779 the next call needs to find the .
c277df42 780 The initial *old_posp should be -1.
cf93c79d
IZ
781
782 Note that we take into account SvTAIL, so one can get extra
783 optimizations if _ALL flag is set.
c277df42
IZ
784 */
785
cf93c79d 786/* If SvTAIL is actually due to \Z or \z, this gives false positives
26fa51c3 787 if PL_multiline. In fact if !PL_multiline the authoritative answer
cf93c79d
IZ
788 is not supported yet. */
789
378cc40b 790char *
864dbfa3 791Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
378cc40b 792{
97aff369 793 dVAR;
0d46e09a 794 register const unsigned char *big;
79072805
LW
795 register I32 pos;
796 register I32 previous;
797 register I32 first;
0d46e09a 798 register const unsigned char *little;
c277df42 799 register I32 stop_pos;
0d46e09a 800 register const unsigned char *littleend;
c277df42 801 I32 found = 0;
378cc40b 802
7918f24d
NC
803 PERL_ARGS_ASSERT_SCREAMINSTR;
804
cecf5685
NC
805 assert(SvTYPE(littlestr) == SVt_PVGV);
806 assert(SvVALID(littlestr));
d372c834 807
c277df42 808 if (*old_posp == -1
3280af22 809 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
cf93c79d
IZ
810 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
811 cant_find:
a1d180c4 812 if ( BmRARE(littlestr) == '\n'
85c508c3 813 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
cfd0369c 814 little = (const unsigned char *)(SvPVX_const(littlestr));
cf93c79d
IZ
815 littleend = little + SvCUR(littlestr);
816 first = *little++;
817 goto check_tail;
818 }
bd61b366 819 return NULL;
cf93c79d
IZ
820 }
821
cfd0369c 822 little = (const unsigned char *)(SvPVX_const(littlestr));
79072805 823 littleend = little + SvCUR(littlestr);
378cc40b 824 first = *little++;
c277df42 825 /* The value of pos we can start at: */
79072805 826 previous = BmPREVIOUS(littlestr);
cfd0369c 827 big = (const unsigned char *)(SvPVX_const(bigstr));
c277df42
IZ
828 /* The value of pos we can stop at: */
829 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
cf93c79d 830 if (previous + start_shift > stop_pos) {
0fe87f7c
HS
831/*
832 stop_pos does not include SvTAIL in the count, so this check is incorrect
833 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
834*/
835#if 0
cf93c79d
IZ
836 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
837 goto check_tail;
0fe87f7c 838#endif
bd61b366 839 return NULL;
cf93c79d 840 }
c277df42 841 while (pos < previous + start_shift) {
3280af22 842 if (!(pos += PL_screamnext[pos]))
cf93c79d 843 goto cant_find;
378cc40b 844 }
de3bb511 845 big -= previous;
bbce6d69 846 do {
0d46e09a 847 register const unsigned char *s, *x;
ef64f398 848 if (pos >= stop_pos) break;
bbce6d69
PP
849 if (big[pos] != first)
850 continue;
851 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69
PP
852 if (*s++ != *x++) {
853 s--;
854 break;
378cc40b 855 }
bbce6d69 856 }
c277df42
IZ
857 if (s == littleend) {
858 *old_posp = pos;
859 if (!last) return (char *)(big+pos);
860 found = 1;
861 }
3280af22 862 } while ( pos += PL_screamnext[pos] );
a1d180c4 863 if (last && found)
cf93c79d 864 return (char *)(big+(*old_posp));
cf93c79d
IZ
865 check_tail:
866 if (!SvTAIL(littlestr) || (end_shift > 0))
bd61b366 867 return NULL;
cf93c79d 868 /* Ignore the trailing "\n". This code is not microoptimized */
cfd0369c 869 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
cf93c79d
IZ
870 stop_pos = littleend - little; /* Actual littlestr len */
871 if (stop_pos == 0)
872 return (char*)big;
873 big -= stop_pos;
874 if (*big == first
12ae5dfc
JH
875 && ((stop_pos == 1) ||
876 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
cf93c79d 877 return (char*)big;
bd61b366 878 return NULL;
8d063cd8
LW
879}
880
79072805 881I32
04c9e624 882Perl_ibcmp(const char *s1, const char *s2, register I32 len)
79072805 883{
e1ec3a88
AL
884 register const U8 *a = (const U8 *)s1;
885 register const U8 *b = (const U8 *)s2;
96a5add6 886
7918f24d
NC
887 PERL_ARGS_ASSERT_IBCMP;
888
79072805 889 while (len--) {
22c35a8c 890 if (*a != *b && *a != PL_fold[*b])
bbce6d69
PP
891 return 1;
892 a++,b++;
893 }
894 return 0;
895}
896
897I32
04c9e624 898Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
bbce6d69 899{
27da23d5 900 dVAR;
e1ec3a88
AL
901 register const U8 *a = (const U8 *)s1;
902 register const U8 *b = (const U8 *)s2;
96a5add6 903
7918f24d
NC
904 PERL_ARGS_ASSERT_IBCMP_LOCALE;
905
bbce6d69 906 while (len--) {
22c35a8c 907 if (*a != *b && *a != PL_fold_locale[*b])
bbce6d69
PP
908 return 1;
909 a++,b++;
79072805
LW
910 }
911 return 0;
912}
913
8d063cd8
LW
914/* copy a string to a safe spot */
915
954c1994 916/*
ccfc67b7
JH
917=head1 Memory Management
918
954c1994
GS
919=for apidoc savepv
920
61a925ed
AMS
921Perl's version of C<strdup()>. Returns a pointer to a newly allocated
922string which is a duplicate of C<pv>. The size of the string is
923determined by C<strlen()>. The memory allocated for the new string can
924be freed with the C<Safefree()> function.
954c1994
GS
925
926=cut
927*/
928
8d063cd8 929char *
efdfce31 930Perl_savepv(pTHX_ const char *pv)
8d063cd8 931{
96a5add6 932 PERL_UNUSED_CONTEXT;
e90e2364 933 if (!pv)
bd61b366 934 return NULL;
66a1b24b
AL
935 else {
936 char *newaddr;
937 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH
938 Newx(newaddr, pvlen, char);
939 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 940 }
8d063cd8
LW
941}
942
a687059c
LW
943/* same thing but with a known length */
944
954c1994
GS
945/*
946=for apidoc savepvn
947
61a925ed
AMS
948Perl's version of what C<strndup()> would be if it existed. Returns a
949pointer to a newly allocated string which is a duplicate of the first
cbf82dd0
NC
950C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
951the new string can be freed with the C<Safefree()> function.
954c1994
GS
952
953=cut
954*/
955
a687059c 956char *
efdfce31 957Perl_savepvn(pTHX_ const char *pv, register I32 len)
a687059c
LW
958{
959 register char *newaddr;
96a5add6 960 PERL_UNUSED_CONTEXT;
a687059c 961
a02a5408 962 Newx(newaddr,len+1,char);
92110913 963 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 964 if (pv) {
e90e2364
NC
965 /* might not be null terminated */
966 newaddr[len] = '\0';
07409e01 967 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS
968 }
969 else {
07409e01 970 return (char *) ZeroD(newaddr,len+1,char);
92110913 971 }
a687059c
LW
972}
973
05ec9bb3
NIS
974/*
975=for apidoc savesharedpv
976
61a925ed
AMS
977A version of C<savepv()> which allocates the duplicate string in memory
978which is shared between threads.
05ec9bb3
NIS
979
980=cut
981*/
982char *
efdfce31 983Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 984{
e90e2364 985 register char *newaddr;
490a0e98 986 STRLEN pvlen;
e90e2364 987 if (!pv)
bd61b366 988 return NULL;
e90e2364 989
490a0e98
NC
990 pvlen = strlen(pv)+1;
991 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 992 if (!newaddr) {
0bd48802 993 return write_no_mem();
05ec9bb3 994 }
10edeb5d 995 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS
996}
997
2e0de35c 998/*
d9095cec
NC
999=for apidoc savesharedpvn
1000
1001A version of C<savepvn()> which allocates the duplicate string in memory
1002which is shared between threads. (With the specific difference that a NULL
1003pointer is not acceptable)
1004
1005=cut
1006*/
1007char *
1008Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1009{
1010 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d
NC
1011
1012 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1013
d9095cec
NC
1014 if (!newaddr) {
1015 return write_no_mem();
1016 }
1017 newaddr[len] = '\0';
1018 return (char*)memcpy(newaddr, pv, len);
1019}
1020
1021/*
2e0de35c
NC
1022=for apidoc savesvpv
1023
6832267f 1024A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC
1025the passed in SV using C<SvPV()>
1026
1027=cut
1028*/
1029
1030char *
1031Perl_savesvpv(pTHX_ SV *sv)
1032{
1033 STRLEN len;
7452cf6a 1034 const char * const pv = SvPV_const(sv, len);
2e0de35c
NC
1035 register char *newaddr;
1036
7918f24d
NC
1037 PERL_ARGS_ASSERT_SAVESVPV;
1038
26866f99 1039 ++len;
a02a5408 1040 Newx(newaddr,len,char);
07409e01 1041 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1042}
05ec9bb3
NIS
1043
1044
cea2e8a9 1045/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1046
76e3520e 1047STATIC SV *
cea2e8a9 1048S_mess_alloc(pTHX)
fc36a67e 1049{
97aff369 1050 dVAR;
fc36a67e
PP
1051 SV *sv;
1052 XPVMG *any;
1053
e72dc28c 1054 if (!PL_dirty)
84bafc02 1055 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1056
0372dbb6
GS
1057 if (PL_mess_sv)
1058 return PL_mess_sv;
1059
fc36a67e 1060 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC
1061 Newx(sv, 1, SV);
1062 Newxz(any, 1, XPVMG);
fc36a67e
PP
1063 SvFLAGS(sv) = SVt_PVMG;
1064 SvANY(sv) = (void*)any;
6136c704 1065 SvPV_set(sv, NULL);
fc36a67e 1066 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1067 PL_mess_sv = sv;
fc36a67e
PP
1068 return sv;
1069}
1070
c5be433b 1071#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1072char *
1073Perl_form_nocontext(const char* pat, ...)
1074{
1075 dTHX;
c5be433b 1076 char *retval;
cea2e8a9 1077 va_list args;
7918f24d 1078 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1079 va_start(args, pat);
c5be433b 1080 retval = vform(pat, &args);
cea2e8a9 1081 va_end(args);
c5be433b 1082 return retval;
cea2e8a9 1083}
c5be433b 1084#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1085
7c9e965c 1086/*
ccfc67b7 1087=head1 Miscellaneous Functions
7c9e965c
JP
1088=for apidoc form
1089
1090Takes a sprintf-style format pattern and conventional
1091(non-SV) arguments and returns the formatted string.
1092
1093 (char *) Perl_form(pTHX_ const char* pat, ...)
1094
1095can be used any place a string (char *) is required:
1096
1097 char * s = Perl_form("%d.%d",major,minor);
1098
1099Uses a single private buffer so if you want to format several strings you
1100must explicitly copy the earlier strings away (and free the copies when you
1101are done).
1102
1103=cut
1104*/
1105
8990e307 1106char *
864dbfa3 1107Perl_form(pTHX_ const char* pat, ...)
8990e307 1108{
c5be433b 1109 char *retval;
46fc3d4c 1110 va_list args;
7918f24d 1111 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1112 va_start(args, pat);
c5be433b 1113 retval = vform(pat, &args);
46fc3d4c 1114 va_end(args);
c5be433b
GS
1115 return retval;
1116}
1117
1118char *
1119Perl_vform(pTHX_ const char *pat, va_list *args)
1120{
2d03de9c 1121 SV * const sv = mess_alloc();
7918f24d 1122 PERL_ARGS_ASSERT_VFORM;
4608196e 1123 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1124 return SvPVX(sv);
46fc3d4c 1125}
a687059c 1126
c5df3096
Z
1127/*
1128=for apidoc Am|SV *|mess|const char *pat|...
1129
1130Take a sprintf-style format pattern and argument list. These are used to
1131generate a string message. If the message does not end with a newline,
1132then it will be extended with some indication of the current location
1133in the code, as described for L</mess_sv>.
1134
1135Normally, the resulting message is returned in a new mortal SV.
1136During global destruction a single SV may be shared between uses of
1137this function.
1138
1139=cut
1140*/
1141
5a844595
GS
1142#if defined(PERL_IMPLICIT_CONTEXT)
1143SV *
1144Perl_mess_nocontext(const char *pat, ...)
1145{
1146 dTHX;
1147 SV *retval;
1148 va_list args;
7918f24d 1149 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS
1150 va_start(args, pat);
1151 retval = vmess(pat, &args);
1152 va_end(args);
1153 return retval;
1154}
1155#endif /* PERL_IMPLICIT_CONTEXT */
1156
06bf62c7 1157SV *
5a844595
GS
1158Perl_mess(pTHX_ const char *pat, ...)
1159{
1160 SV *retval;
1161 va_list args;
7918f24d 1162 PERL_ARGS_ASSERT_MESS;
5a844595
GS
1163 va_start(args, pat);
1164 retval = vmess(pat, &args);
1165 va_end(args);
1166 return retval;
1167}
1168
5f66b61c
AL
1169STATIC const COP*
1170S_closest_cop(pTHX_ const COP *cop, const OP *o)
ae7d165c 1171{
97aff369 1172 dVAR;
ae7d165c
PJ
1173 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1174
7918f24d
NC
1175 PERL_ARGS_ASSERT_CLOSEST_COP;
1176
fabdb6c0
AL
1177 if (!o || o == PL_op)
1178 return cop;
ae7d165c
PJ
1179
1180 if (o->op_flags & OPf_KIDS) {
5f66b61c 1181 const OP *kid;
fabdb6c0 1182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
5f66b61c 1183 const COP *new_cop;
ae7d165c
PJ
1184
1185 /* If the OP_NEXTSTATE has been optimised away we can still use it
1186 * the get the file and line number. */
1187
1188 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1189 cop = (const COP *)kid;
ae7d165c
PJ
1190
1191 /* Keep searching, and return when we've found something. */
1192
1193 new_cop = closest_cop(cop, kid);
fabdb6c0
AL
1194 if (new_cop)
1195 return new_cop;
ae7d165c
PJ
1196 }
1197 }
1198
1199 /* Nothing found. */
1200
5f66b61c 1201 return NULL;
ae7d165c
PJ
1202}
1203
c5df3096
Z
1204/*
1205=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1206
1207Expands a message, intended for the user, to include an indication of
1208the current location in the code, if the message does not already appear
1209to be complete.
1210
1211C<basemsg> is the initial message or object. If it is a reference, it
1212will be used as-is and will be the result of this function. Otherwise it
1213is used as a string, and if it already ends with a newline, it is taken
1214to be complete, and the result of this function will be the same string.
1215If the message does not end with a newline, then a segment such as C<at
1216foo.pl line 37> will be appended, and possibly other clauses indicating
1217the current state of execution. The resulting message will end with a
1218dot and a newline.
1219
1220Normally, the resulting message is returned in a new mortal SV.
1221During global destruction a single SV may be shared between uses of this
1222function. If C<consume> is true, then the function is permitted (but not
1223required) to modify and return C<basemsg> instead of allocating a new SV.
1224
1225=cut
1226*/
1227
5a844595 1228SV *
c5df3096 1229Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
46fc3d4c 1230{
97aff369 1231 dVAR;
c5df3096 1232 SV *sv;
46fc3d4c 1233
c5df3096
Z
1234 PERL_ARGS_ASSERT_MESS_SV;
1235
1236 if (SvROK(basemsg)) {
1237 if (consume) {
1238 sv = basemsg;
1239 }
1240 else {
1241 sv = mess_alloc();
1242 sv_setsv(sv, basemsg);
1243 }
1244 return sv;
1245 }
1246
1247 if (SvPOK(basemsg) && consume) {
1248 sv = basemsg;
1249 }
1250 else {
1251 sv = mess_alloc();
1252 sv_copypv(sv, basemsg);
1253 }
7918f24d 1254
46fc3d4c 1255 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ
1256 /*
1257 * Try and find the file and line for PL_op. This will usually be
1258 * PL_curcop, but it might be a cop that has been optimised away. We
1259 * can try to find such a cop by searching through the optree starting
1260 * from the sibling of PL_curcop.
1261 */
1262
e1ec3a88 1263 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
5f66b61c
AL
1264 if (!cop)
1265 cop = PL_curcop;
ae7d165c
PJ
1266
1267 if (CopLINE(cop))
ed094faf 1268 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1269 OutCopFILE(cop), (IV)CopLINE(cop));
191f87d5
DH
1270 /* Seems that GvIO() can be untrustworthy during global destruction. */
1271 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1272 && IoLINES(GvIOp(PL_last_in_gv)))
1273 {
e1ec3a88 1274 const bool line_mode = (RsSIMPLE(PL_rs) &&
95a20fc0 1275 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
57def98f 1276 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
5f66b61c 1277 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
edc2eac3
JH
1278 line_mode ? "line" : "chunk",
1279 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1280 }
5f66b61c
AL
1281 if (PL_dirty)
1282 sv_catpvs(sv, " during global destruction");
1283 sv_catpvs(sv, ".\n");
a687059c 1284 }
06bf62c7 1285 return sv;
a687059c
LW
1286}
1287
c5df3096
Z
1288/*
1289=for apidoc Am|SV *|vmess|const char *pat|va_list *args
1290
1291C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1292argument list. These are used to generate a string message. If the
1293message does not end with a newline, then it will be extended with
1294some indication of the current location in the code, as described for
1295L</mess_sv>.
1296
1297Normally, the resulting message is returned in a new mortal SV.
1298During global destruction a single SV may be shared between uses of
1299this function.
1300
1301=cut
1302*/
1303
1304SV *
1305Perl_vmess(pTHX_ const char *pat, va_list *args)
1306{
1307 dVAR;
1308 SV * const sv = mess_alloc();
1309
1310 PERL_ARGS_ASSERT_VMESS;
1311
1312 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1313 return mess_sv(sv, 1);
1314}
1315
7ff03255 1316void
7d0994e0 1317Perl_write_to_stderr(pTHX_ SV* msv)
7ff03255 1318{
27da23d5 1319 dVAR;
7ff03255
SG
1320 IO *io;
1321 MAGIC *mg;
1322
7918f24d
NC
1323 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1324
7ff03255
SG
1325 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1326 && (io = GvIO(PL_stderrgv))
daba3364 1327 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
7ff03255
SG
1328 {
1329 dSP;
1330 ENTER;
1331 SAVETMPS;
1332
1333 save_re_context();
1334 SAVESPTR(PL_stderrgv);
a0714e2c 1335 PL_stderrgv = NULL;
7ff03255
SG
1336
1337 PUSHSTACKi(PERLSI_MAGIC);
1338
1339 PUSHMARK(SP);
1340 EXTEND(SP,2);
daba3364 1341 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
7d0994e0 1342 PUSHs(msv);
7ff03255
SG
1343 PUTBACK;
1344 call_method("PRINT", G_SCALAR);
1345
1346 POPSTACK;
1347 FREETMPS;
1348 LEAVE;
1349 }
1350 else {
1351#ifdef USE_SFIO
1352 /* SFIO can really mess with your errno */
4ee39169 1353 dSAVED_ERRNO;
7ff03255 1354#endif
53c1dcc0 1355 PerlIO * const serr = Perl_error_log;
7d0994e0
GG
1356 STRLEN msglen;
1357 const char* message = SvPVx_const(msv, msglen);
7ff03255
SG
1358
1359 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1360 (void)PerlIO_flush(serr);
1361#ifdef USE_SFIO
4ee39169 1362 RESTORE_ERRNO;
7ff03255
SG
1363#endif
1364 }
1365}
1366
c5df3096
Z
1367/*
1368=head1 Warning and Dieing
1369*/
1370
1371/* Common code used in dieing and warning */
1372
1373STATIC SV *
1374S_with_queued_errors(pTHX_ SV *ex)
1375{
1376 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1377 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1378 sv_catsv(PL_errors, ex);
1379 ex = sv_mortalcopy(PL_errors);
1380 SvCUR_set(PL_errors, 0);
1381 }
1382 return ex;
1383}
3ab1ac99 1384
46d9c920 1385STATIC bool
c5df3096 1386S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
63315e18 1387{
97aff369 1388 dVAR;
63315e18
NC
1389 HV *stash;
1390 GV *gv;
1391 CV *cv;
46d9c920
NC
1392 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1393 /* sv_2cv might call Perl_croak() or Perl_warner() */
1394 SV * const oldhook = *hook;
1395
c5df3096
Z
1396 if (!oldhook)
1397 return FALSE;
63315e18 1398
63315e18 1399 ENTER;
46d9c920
NC
1400 SAVESPTR(*hook);
1401 *hook = NULL;
1402 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC
1403 LEAVE;
1404 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1405 dSP;
c5df3096 1406 SV *exarg;
63315e18
NC
1407
1408 ENTER;
1409 save_re_context();
46d9c920
NC
1410 if (warn) {
1411 SAVESPTR(*hook);
1412 *hook = NULL;
1413 }
c5df3096
Z
1414 exarg = newSVsv(ex);
1415 SvREADONLY_on(exarg);
1416 SAVEFREESV(exarg);
63315e18 1417
46d9c920 1418 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18 1419 PUSHMARK(SP);
c5df3096 1420 XPUSHs(exarg);
63315e18 1421 PUTBACK;
daba3364 1422 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC
1423 POPSTACK;
1424 LEAVE;
46d9c920 1425 return TRUE;
63315e18 1426 }
46d9c920 1427 return FALSE;
63315e18
NC
1428}
1429
c5df3096
Z
1430/*
1431=for apidoc Am|OP *|die_sv|SV *baseex
e07360fa 1432
c5df3096
Z
1433Behaves the same as L</croak_sv>, except for the return type.
1434It should be used only where the C<OP *> return type is required.
1435The function never actually returns.
e07360fa 1436
c5df3096
Z
1437=cut
1438*/
e07360fa 1439
c5df3096
Z
1440OP *
1441Perl_die_sv(pTHX_ SV *baseex)
36477c24 1442{
c5df3096
Z
1443 PERL_ARGS_ASSERT_DIE_SV;
1444 croak_sv(baseex);
ad09800f
GG
1445 /* NOTREACHED */
1446 return NULL;
36477c24
PP
1447}
1448
c5df3096
Z
1449/*
1450=for apidoc Am|OP *|die|const char *pat|...
1451
1452Behaves the same as L</croak>, except for the return type.
1453It should be used only where the C<OP *> return type is required.
1454The function never actually returns.
1455
1456=cut
1457*/
1458
c5be433b 1459#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1460OP *
1461Perl_die_nocontext(const char* pat, ...)
a687059c 1462{
cea2e8a9 1463 dTHX;
a687059c 1464 va_list args;
cea2e8a9 1465 va_start(args, pat);
c5df3096
Z
1466 vcroak(pat, &args);
1467 /* NOTREACHED */
cea2e8a9 1468 va_end(args);
c5df3096 1469 return NULL;
cea2e8a9 1470}
c5be433b 1471#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS
1472
1473OP *
1474Perl_die(pTHX_ const char* pat, ...)
1475{
cea2e8a9
GS
1476 va_list args;
1477 va_start(args, pat);
c5df3096
Z
1478 vcroak(pat, &args);
1479 /* NOTREACHED */
cea2e8a9 1480 va_end(args);
c5df3096 1481 return NULL;
cea2e8a9
GS
1482}
1483
c5df3096
Z
1484/*
1485=for apidoc Am|void|croak_sv|SV *baseex
1486
1487This is an XS interface to Perl's C<die> function.
1488
1489C<baseex> is the error message or object. If it is a reference, it
1490will be used as-is. Otherwise it is used as a string, and if it does
1491not end with a newline then it will be extended with some indication of
1492the current location in the code, as described for L</mess_sv>.
1493
1494The error message or object will be used as an exception, by default
1495returning control to the nearest enclosing C<eval>, but subject to
1496modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1497function never returns normally.
1498
1499To die with a simple string message, the L</croak> function may be
1500more convenient.
1501
1502=cut
1503*/
1504
c5be433b 1505void
c5df3096 1506Perl_croak_sv(pTHX_ SV *baseex)
cea2e8a9 1507{
c5df3096
Z
1508 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1509 PERL_ARGS_ASSERT_CROAK_SV;
1510 invoke_exception_hook(ex, FALSE);
1511 die_unwind(ex);
1512}
1513
1514/*
1515=for apidoc Am|void|vcroak|const char *pat|va_list *args
1516
1517This is an XS interface to Perl's C<die> function.
1518
1519C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1520argument list. These are used to generate a string message. If the
1521message does not end with a newline, then it will be extended with
1522some indication of the current location in the code, as described for
1523L</mess_sv>.
1524
1525The error message will be used as an exception, by default
1526returning control to the nearest enclosing C<eval>, but subject to
1527modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1528function never returns normally.
a687059c 1529
c5df3096
Z
1530For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1531(C<$@>) will be used as an error message or object instead of building an
1532error message from arguments. If you want to throw a non-string object,
1533or build an error message in an SV yourself, it is preferable to use
1534the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
5a844595 1535
c5df3096
Z
1536=cut
1537*/
1538
1539void
1540Perl_vcroak(pTHX_ const char* pat, va_list *args)
1541{
1542 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1543 invoke_exception_hook(ex, FALSE);
1544 die_unwind(ex);
a687059c
LW
1545}
1546
c5df3096
Z
1547/*
1548=for apidoc Am|void|croak|const char *pat|...
1549
1550This is an XS interface to Perl's C<die> function.
1551
1552Take a sprintf-style format pattern and argument list. These are used to
1553generate a string message. If the message does not end with a newline,
1554then it will be extended with some indication of the current location
1555in the code, as described for L</mess_sv>.
1556
1557The error message will be used as an exception, by default
1558returning control to the nearest enclosing C<eval>, but subject to
1559modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1560function never returns normally.
1561
1562For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1563(C<$@>) will be used as an error message or object instead of building an
1564error message from arguments. If you want to throw a non-string object,
1565or build an error message in an SV yourself, it is preferable to use
1566the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1567
1568=cut
1569*/
1570
c5be433b 1571#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1572void
cea2e8a9 1573Perl_croak_nocontext(const char *pat, ...)
a687059c 1574{
cea2e8a9 1575 dTHX;
a687059c 1576 va_list args;
cea2e8a9 1577 va_start(args, pat);
c5be433b 1578 vcroak(pat, &args);
cea2e8a9
GS
1579 /* NOTREACHED */
1580 va_end(args);
1581}
1582#endif /* PERL_IMPLICIT_CONTEXT */
1583
c5df3096
Z
1584void
1585Perl_croak(pTHX_ const char *pat, ...)
1586{
1587 va_list args;
1588 va_start(args, pat);
1589 vcroak(pat, &args);
1590 /* NOTREACHED */
1591 va_end(args);
1592}
1593
954c1994 1594/*
c5df3096 1595=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1596
c5df3096 1597This is an XS interface to Perl's C<warn> function.
954c1994 1598
c5df3096
Z
1599C<baseex> is the error message or object. If it is a reference, it
1600will be used as-is. Otherwise it is used as a string, and if it does
1601not end with a newline then it will be extended with some indication of
1602the current location in the code, as described for L</mess_sv>.
9983fa3c 1603
c5df3096
Z
1604The error message or object will by default be written to standard error,
1605but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1606
c5df3096
Z
1607To warn with a simple string message, the L</warn> function may be
1608more convenient.
954c1994
GS
1609
1610=cut
1611*/
1612
cea2e8a9 1613void
c5df3096 1614Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1615{
c5df3096
Z
1616 SV *ex = mess_sv(baseex, 0);
1617 PERL_ARGS_ASSERT_WARN_SV;
1618 if (!invoke_exception_hook(ex, TRUE))
1619 write_to_stderr(ex);
cea2e8a9
GS
1620}
1621
c5df3096
Z
1622/*
1623=for apidoc Am|void|vwarn|const char *pat|va_list *args
1624
1625This is an XS interface to Perl's C<warn> function.
1626
1627C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1628argument list. These are used to generate a string message. If the
1629message does not end with a newline, then it will be extended with
1630some indication of the current location in the code, as described for
1631L</mess_sv>.
1632
1633The error message or object will by default be written to standard error,
1634but this is subject to modification by a C<$SIG{__WARN__}> handler.
1635
1636Unlike with L</vcroak>, C<pat> is not permitted to be null.
1637
1638=cut
1639*/
1640
c5be433b
GS
1641void
1642Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1643{
c5df3096 1644 SV *ex = vmess(pat, args);
7918f24d 1645 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
1646 if (!invoke_exception_hook(ex, TRUE))
1647 write_to_stderr(ex);
1648}
7918f24d 1649
c5df3096
Z
1650/*
1651=for apidoc Am|void|warn|const char *pat|...
87582a92 1652
c5df3096
Z
1653This is an XS interface to Perl's C<warn> function.
1654
1655Take a sprintf-style format pattern and argument list. These are used to
1656generate a string message. If the message does not end with a newline,
1657then it will be extended with some indication of the current location
1658in the code, as described for L</mess_sv>.
1659
1660The error message or object will by default be written to standard error,
1661but this is subject to modification by a C<$SIG{__WARN__}> handler.
1662
1663Unlike with L</croak>, C<pat> is not permitted to be null.
1664
1665=cut
1666*/
8d063cd8 1667
c5be433b 1668#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1669void
1670Perl_warn_nocontext(const char *pat, ...)
1671{
1672 dTHX;
1673 va_list args;
7918f24d 1674 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1675 va_start(args, pat);
c5be433b 1676 vwarn(pat, &args);
cea2e8a9
GS
1677 va_end(args);
1678}
1679#endif /* PERL_IMPLICIT_CONTEXT */
1680
1681void
1682Perl_warn(pTHX_ const char *pat, ...)
1683{
1684 va_list args;
7918f24d 1685 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1686 va_start(args, pat);
c5be433b 1687 vwarn(pat, &args);
cea2e8a9
GS
1688 va_end(args);
1689}
1690
c5be433b
GS
1691#if defined(PERL_IMPLICIT_CONTEXT)
1692void
1693Perl_warner_nocontext(U32 err, const char *pat, ...)
1694{
27da23d5 1695 dTHX;
c5be433b 1696 va_list args;
7918f24d 1697 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
1698 va_start(args, pat);
1699 vwarner(err, pat, &args);
1700 va_end(args);
1701}
1702#endif /* PERL_IMPLICIT_CONTEXT */
1703
599cee73 1704void
9b387841
NC
1705Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1706{
1707 PERL_ARGS_ASSERT_CK_WARNER_D;
1708
1709 if (Perl_ckwarn_d(aTHX_ err)) {
1710 va_list args;
1711 va_start(args, pat);
1712 vwarner(err, pat, &args);
1713 va_end(args);
1714 }
1715}
1716
1717void
a2a5de95
NC
1718Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1719{
1720 PERL_ARGS_ASSERT_CK_WARNER;
1721
1722 if (Perl_ckwarn(aTHX_ err)) {
1723 va_list args;
1724 va_start(args, pat);
1725 vwarner(err, pat, &args);
1726 va_end(args);
1727 }
1728}
1729
1730void
864dbfa3 1731Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
1732{
1733 va_list args;
7918f24d 1734 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
1735 va_start(args, pat);
1736 vwarner(err, pat, &args);
1737 va_end(args);
1738}
1739
1740void
1741Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1742{
27da23d5 1743 dVAR;
7918f24d 1744 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1745 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1746 SV * const msv = vmess(pat, args);
599cee73 1747
c5df3096
Z
1748 invoke_exception_hook(msv, FALSE);
1749 die_unwind(msv);
599cee73
PM
1750 }
1751 else {
d13b0d77 1752 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
1753 }
1754}
1755
f54ba1c2
DM
1756/* implements the ckWARN? macros */
1757
1758bool
1759Perl_ckwarn(pTHX_ U32 w)
1760{
97aff369 1761 dVAR;
ad287e37
NC
1762 /* If lexical warnings have not been set, use $^W. */
1763 if (isLEXWARN_off)
1764 return PL_dowarn & G_WARN_ON;
1765
26c7b074 1766 return ckwarn_common(w);
f54ba1c2
DM
1767}
1768
1769/* implements the ckWARN?_d macro */
1770
1771bool
1772Perl_ckwarn_d(pTHX_ U32 w)
1773{
97aff369 1774 dVAR;
ad287e37
NC
1775 /* If lexical warnings have not been set then default classes warn. */
1776 if (isLEXWARN_off)
1777 return TRUE;
1778
26c7b074
NC
1779 return ckwarn_common(w);
1780}
1781
1782static bool
1783S_ckwarn_common(pTHX_ U32 w)
1784{
ad287e37
NC
1785 if (PL_curcop->cop_warnings == pWARN_ALL)
1786 return TRUE;
1787
1788 if (PL_curcop->cop_warnings == pWARN_NONE)
1789 return FALSE;
1790
98fe6610
NC
1791 /* Check the assumption that at least the first slot is non-zero. */
1792 assert(unpackWARN1(w));
1793
1794 /* Check the assumption that it is valid to stop as soon as a zero slot is
1795 seen. */
1796 if (!unpackWARN2(w)) {
1797 assert(!unpackWARN3(w));
1798 assert(!unpackWARN4(w));
1799 } else if (!unpackWARN3(w)) {
1800 assert(!unpackWARN4(w));
1801 }
1802
26c7b074
NC
1803 /* Right, dealt with all the special cases, which are implemented as non-
1804 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
1805 do {
1806 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1807 return TRUE;
1808 } while (w >>= WARNshift);
1809
1810 return FALSE;
f54ba1c2
DM
1811}
1812
72dc9ed5
NC
1813/* Set buffer=NULL to get a new one. */
1814STRLEN *
8ee4cf24 1815Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5
NC
1816 STRLEN size) {
1817 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
35da51f7 1818 PERL_UNUSED_CONTEXT;
7918f24d 1819 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 1820
10edeb5d
JH
1821 buffer = (STRLEN*)
1822 (specialWARN(buffer) ?
1823 PerlMemShared_malloc(len_wanted) :
1824 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
1825 buffer[0] = size;
1826 Copy(bits, (buffer + 1), size, char);
1827 return buffer;
1828}
f54ba1c2 1829
e6587932
DM
1830/* since we've already done strlen() for both nam and val
1831 * we can use that info to make things faster than
1832 * sprintf(s, "%s=%s", nam, val)
1833 */
1834#define my_setenv_format(s, nam, nlen, val, vlen) \
1835 Copy(nam, s, nlen, char); \
1836 *(s+nlen) = '='; \
1837 Copy(val, s+(nlen+1), vlen, char); \
1838 *(s+(nlen+1+vlen)) = '\0'
1839
c5d12488
JH
1840#ifdef USE_ENVIRON_ARRAY
1841 /* VMS' my_setenv() is in vms.c */
1842#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1843void
e1ec3a88 1844Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1845{
27da23d5 1846 dVAR;
4efc5df6
GS
1847#ifdef USE_ITHREADS
1848 /* only parent thread can modify process environment */
1849 if (PL_curinterp == aTHX)
1850#endif
1851 {
f2517201 1852#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1853 if (!PL_use_safe_putenv) {
c5d12488 1854 /* most putenv()s leak, so we manipulate environ directly */
3a9222be
JH
1855 register I32 i;
1856 register const I32 len = strlen(nam);
c5d12488
JH
1857 int nlen, vlen;
1858
3a9222be
JH
1859 /* where does it go? */
1860 for (i = 0; environ[i]; i++) {
1861 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1862 break;
1863 }
1864
c5d12488
JH
1865 if (environ == PL_origenviron) { /* need we copy environment? */
1866 I32 j;
1867 I32 max;
1868 char **tmpenv;
1869
1870 max = i;
1871 while (environ[max])
1872 max++;
1873 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1874 for (j=0; j<max; j++) { /* copy environment */
1875 const int len = strlen(environ[j]);
1876 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1877 Copy(environ[j], tmpenv[j], len+1, char);
1878 }
1879 tmpenv[max] = NULL;
1880 environ = tmpenv; /* tell exec where it is now */
1881 }
1882 if (!val) {
1883 safesysfree(environ[i]);
1884 while (environ[i]) {
1885 environ[i] = environ[i+1];
1886 i++;
a687059c 1887 }
c5d12488
JH
1888 return;
1889 }
1890 if (!environ[i]) { /* does not exist yet */
1891 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1892 environ[i+1] = NULL; /* make sure it's null terminated */
1893 }
1894 else
1895 safesysfree(environ[i]);
1896 nlen = strlen(nam);
1897 vlen = strlen(val);
1898
1899 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1900 /* all that work just for this */
1901 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1902 } else {
c5d12488 1903# endif
7ee146b1 1904# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB
1905# if defined(HAS_UNSETENV)
1906 if (val == NULL) {
1907 (void)unsetenv(nam);
1908 } else {
1909 (void)setenv(nam, val, 1);
1910 }
1911# else /* ! HAS_UNSETENV */
1912 (void)setenv(nam, val, 1);
1913# endif /* HAS_UNSETENV */
47dafe4d 1914# else
88f5bc07
AB
1915# if defined(HAS_UNSETENV)
1916 if (val == NULL) {
1917 (void)unsetenv(nam);
1918 } else {
c4420975
AL
1919 const int nlen = strlen(nam);
1920 const int vlen = strlen(val);
1921 char * const new_env =
88f5bc07
AB
1922 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1923 my_setenv_format(new_env, nam, nlen, val, vlen);
1924 (void)putenv(new_env);
1925 }
1926# else /* ! HAS_UNSETENV */
1927 char *new_env;
c4420975
AL
1928 const int nlen = strlen(nam);
1929 int vlen;
88f5bc07
AB
1930 if (!val) {
1931 val = "";
1932 }
1933 vlen = strlen(val);
1934 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1935 /* all that work just for this */
1936 my_setenv_format(new_env, nam, nlen, val, vlen);
1937 (void)putenv(new_env);
1938# endif /* HAS_UNSETENV */
47dafe4d 1939# endif /* __CYGWIN__ */
50acdf95
MS
1940#ifndef PERL_USE_SAFE_PUTENV
1941 }
1942#endif
4efc5df6 1943 }
8d063cd8
LW
1944}
1945
c5d12488 1946#else /* WIN32 || NETWARE */
68dc0745
PP
1947
1948void
72229eff 1949Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1950{
27da23d5 1951 dVAR;
c5d12488
JH
1952 register char *envstr;
1953 const int nlen = strlen(nam);
1954 int vlen;
e6587932 1955
c5d12488
JH
1956 if (!val) {
1957 val = "";
ac5c734f 1958 }
c5d12488
JH
1959 vlen = strlen(val);
1960 Newx(envstr, nlen+vlen+2, char);
1961 my_setenv_format(envstr, nam, nlen, val, vlen);
1962 (void)PerlEnv_putenv(envstr);
1963 Safefree(envstr);
3e3baf6d
TB
1964}
1965
c5d12488 1966#endif /* WIN32 || NETWARE */
3e3baf6d 1967
c5d12488 1968#endif /* !VMS && !EPOC*/
378cc40b 1969
16d20bd9 1970#ifdef UNLINK_ALL_VERSIONS
79072805 1971I32
6e732051 1972Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 1973{
35da51f7 1974 I32 retries = 0;
378cc40b 1975
7918f24d
NC
1976 PERL_ARGS_ASSERT_UNLNK;
1977
35da51f7
AL
1978 while (PerlLIO_unlink(f) >= 0)
1979 retries++;
1980 return retries ? 0 : -1;
378cc40b
LW
1981}
1982#endif
1983
7a3f2258 1984/* this is a drop-in replacement for bcopy() */
2253333f 1985#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1986char *
7a3f2258 1987Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b 1988{
2d03de9c 1989 char * const retval = to;
378cc40b 1990
7918f24d
NC
1991 PERL_ARGS_ASSERT_MY_BCOPY;
1992
7c0587c8
LW
1993 if (from - to >= 0) {
1994 while (len--)
1995 *to++ = *from++;
1996 }
1997 else {
1998 to += len;
1999 from += len;
2000 while (len--)
faf8582f 2001 *(--to) = *(--from);
7c0587c8 2002 }
378cc40b
LW
2003 return retval;
2004}
ffed7fef 2005#endif
378cc40b 2006
7a3f2258 2007/* this is a drop-in replacement for memset() */
fc36a67e
PP
2008#ifndef HAS_MEMSET
2009void *
7a3f2258 2010Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 2011{
2d03de9c 2012 char * const retval = loc;
fc36a67e 2013
7918f24d
NC
2014 PERL_ARGS_ASSERT_MY_MEMSET;
2015
fc36a67e
PP
2016 while (len--)
2017 *loc++ = ch;
2018 return retval;
2019}
2020#endif
2021
7a3f2258 2022/* this is a drop-in replacement for bzero() */
7c0587c8 2023#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2024char *
7a3f2258 2025Perl_my_bzero(register char *loc, register I32 len)
378cc40b 2026{
2d03de9c 2027 char * const retval = loc;
378cc40b 2028
7918f24d
NC
2029 PERL_ARGS_ASSERT_MY_BZERO;
2030
378cc40b
LW
2031 while (len--)
2032 *loc++ = 0;
2033 return retval;
2034}
2035#endif
7c0587c8 2036
7a3f2258 2037/* this is a drop-in replacement for memcmp() */
36477c24 2038#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2039I32
7a3f2258 2040Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 2041{
e1ec3a88
AL
2042 register const U8 *a = (const U8 *)s1;
2043 register const U8 *b = (const U8 *)s2;
79072805 2044 register I32 tmp;
7c0587c8 2045
7918f24d
NC
2046 PERL_ARGS_ASSERT_MY_MEMCMP;
2047
7c0587c8 2048 while (len--) {
27da23d5 2049 if ((tmp = *a++ - *b++))
7c0587c8
LW
2050 return tmp;
2051 }
2052 return 0;
2053}
36477c24 2054#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2055
fe14fcc3 2056#ifndef HAS_VPRINTF
d05d9be5
AD
2057/* This vsprintf replacement should generally never get used, since
2058 vsprintf was available in both System V and BSD 2.11. (There may
2059 be some cross-compilation or embedded set-ups where it is needed,
2060 however.)
2061
2062 If you encounter a problem in this function, it's probably a symptom
2063 that Configure failed to detect your system's vprintf() function.
2064 See the section on "item vsprintf" in the INSTALL file.
2065
2066 This version may compile on systems with BSD-ish <stdio.h>,
2067 but probably won't on others.
2068*/
a687059c 2069
85e6fe83 2070#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2071char *
2072#else
2073int
2074#endif
d05d9be5 2075vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2076{
2077 FILE fakebuf;
2078
d05d9be5
AD
2079#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2080 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2081 FILE_cnt(&fakebuf) = 32767;
2082#else
2083 /* These probably won't compile -- If you really need
2084 this, you'll have to figure out some other method. */
a687059c
LW
2085 fakebuf._ptr = dest;
2086 fakebuf._cnt = 32767;
d05d9be5 2087#endif
35c8bce7
LW
2088#ifndef _IOSTRG
2089#define _IOSTRG 0
2090#endif
a687059c
LW
2091 fakebuf._flag = _IOWRT|_IOSTRG;
2092 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2093#if defined(STDIO_PTR_LVALUE)
2094 *(FILE_ptr(&fakebuf)++) = '\0';
2095#else
2096 /* PerlIO has probably #defined away fputc, but we want it here. */
2097# ifdef fputc
2098# undef fputc /* XXX Should really restore it later */
2099# endif
2100 (void)fputc('\0', &fakebuf);
2101#endif
85e6fe83 2102#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2103 return(dest);
2104#else
2105 return 0; /* perl doesn't use return value */
2106#endif
2107}
2108
fe14fcc3 2109#endif /* HAS_VPRINTF */
a687059c
LW
2110
2111#ifdef MYSWAP
ffed7fef 2112#if BYTEORDER != 0x4321
a687059c 2113short
864dbfa3 2114Perl_my_swap(pTHX_ short s)
a687059c
LW
2115{
2116#if (BYTEORDER & 1) == 0
2117 short result;
2118
2119 result = ((s & 255) << 8) + ((s >> 8) & 255);
2120 return result;
2121#else
2122 return s;
2123#endif
2124}
2125
2126long
864dbfa3 2127Perl_my_htonl(pTHX_ long l)
a687059c
LW
2128{
2129 union {
2130 long result;
ffed7fef 2131 char c[sizeof(long)];
a687059c
LW
2132 } u;
2133
cef6ea9d
JH
2134#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2135#if BYTEORDER == 0x12345678
2136 u.result = 0;
2137#endif
a687059c
LW
2138 u.c[0] = (l >> 24) & 255;
2139 u.c[1] = (l >> 16) & 255;
2140 u.c[2] = (l >> 8) & 255;
2141 u.c[3] = l & 255;
2142 return u.result;
2143#else
ffed7fef 2144#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2145 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2146#else
79072805
LW
2147 register I32 o;
2148 register I32 s;
a687059c 2149
ffed7fef
LW
2150 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2151 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW
2152 }
2153 return u.result;
2154#endif
2155#endif
2156}
2157
2158long
864dbfa3 2159Perl_my_ntohl(pTHX_ long l)
a687059c
LW
2160{
2161 union {
2162 long l;
ffed7fef 2163 char c[sizeof(long)];
a687059c
LW
2164 } u;
2165
ffed7fef 2166#if BYTEORDER == 0x1234
a687059c
LW
2167 u.c[0] = (l >> 24) & 255;
2168 u.c[1] = (l >> 16) & 255;
2169 u.c[2] = (l >> 8) & 255;
2170 u.c[3] = l & 255;
2171 return u.l;
2172#else
ffed7fef 2173#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2174 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2175#else
79072805
LW
2176 register I32 o;
2177 register I32 s;
a687059c
LW
2178
2179 u.l = l;
2180 l = 0;
ffed7fef
LW
2181 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2182 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW
2183 }
2184 return l;
2185#endif
2186#endif
2187}
2188
ffed7fef 2189#endif /* BYTEORDER != 0x4321 */
988174c1
LW
2190#endif /* MYSWAP */
2191
2192/*
2193 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2194 * If these functions are defined,
2195 * the BYTEORDER is neither 0x1234 nor 0x4321.
2196 * However, this is not assumed.
2197 * -DWS
2198 */
2199
1109a392 2200#define HTOLE(name,type) \
988174c1 2201 type \
ba106d47 2202 name (register type n) \
988174c1
LW
2203 { \
2204 union { \
2205 type value; \
2206 char c[sizeof(type)]; \
2207 } u; \
bb7a0f54
MHM
2208 register U32 i; \
2209 register U32 s = 0; \
1109a392 2210 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW
2211 u.c[i] = (n >> s) & 0xFF; \
2212 } \
2213 return u.value; \
2214 }
2215
1109a392 2216#define LETOH(name,type) \
988174c1 2217 type \
ba106d47 2218 name (register type n) \
988174c1
LW
2219 { \
2220 union { \
2221 type value; \
2222 char c[sizeof(type)]; \
2223 } u; \
bb7a0f54
MHM
2224 register U32 i; \
2225 register U32 s = 0; \
988174c1
LW
2226 u.value = n; \
2227 n = 0; \
1109a392
MHM
2228 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2229 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW
2230 } \
2231 return n; \
2232 }
2233
1109a392
MHM
2234/*
2235 * Big-endian byte order functions.
2236 */
2237
2238#define HTOBE(name,type) \
2239 type \
2240 name (register type n) \
2241 { \
2242 union { \
2243 type value; \
2244 char c[sizeof(type)]; \
2245 } u; \
bb7a0f54
MHM
2246 register U32 i; \
2247 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM
2248 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2249 u.c[i] = (n >> s) & 0xFF; \
2250 } \
2251 return u.value; \
2252 }
2253
2254#define BETOH(name,type) \
2255 type \
2256 name (register type n) \
2257 { \
2258 union { \
2259 type value; \
2260 char c[sizeof(type)]; \
2261 } u; \
bb7a0f54
MHM
2262 register U32 i; \
2263 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM
2264 u.value = n; \
2265 n = 0; \
2266 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2267 n |= ((type)(u.c[i] & 0xFF)) << s; \
2268 } \
2269 return n; \
2270 }
2271
2272/*
2273 * If we just can't do it...
2274 */
2275
2276#define NOT_AVAIL(name,type) \
2277 type \
2278 name (register type n) \
2279 { \
2280 Perl_croak_nocontext(#name "() not available"); \
2281 return n; /* not reached */ \
2282 }
2283
2284
988174c1 2285#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 2286HTOLE(htovs,short)
988174c1
LW
2287#endif
2288#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 2289HTOLE(htovl,long)
988174c1
LW
2290#endif
2291#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 2292LETOH(vtohs,short)
988174c1
LW
2293#endif
2294#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM
2295LETOH(vtohl,long)
2296#endif
2297
2298#ifdef PERL_NEED_MY_HTOLE16
2299# if U16SIZE == 2
2300HTOLE(Perl_my_htole16,U16)
2301# else
2302NOT_AVAIL(Perl_my_htole16,U16)
2303# endif
2304#endif
2305#ifdef PERL_NEED_MY_LETOH16
2306# if U16SIZE == 2
2307LETOH(Perl_my_letoh16,U16)
2308# else
2309NOT_AVAIL(Perl_my_letoh16,U16)
2310# endif
2311#endif
2312#ifdef PERL_NEED_MY_HTOBE16
2313# if U16SIZE == 2
2314HTOBE(Perl_my_htobe16,U16)
2315# else
2316NOT_AVAIL(Perl_my_htobe16,U16)
2317# endif
2318#endif
2319#ifdef PERL_NEED_MY_BETOH16
2320# if U16SIZE == 2
2321BETOH(Perl_my_betoh16,U16)
2322# else
2323NOT_AVAIL(Perl_my_betoh16,U16)
2324# endif
2325#endif
2326
2327#ifdef PERL_NEED_MY_HTOLE32
2328# if U32SIZE == 4
2329HTOLE(Perl_my_htole32,U32)
2330# else
2331NOT_AVAIL(Perl_my_htole32,U32)
2332# endif
2333#endif
2334#ifdef PERL_NEED_MY_LETOH32
2335# if U32SIZE == 4
2336LETOH(Perl_my_letoh32,U32)
2337# else
2338NOT_AVAIL(Perl_my_letoh32,U32)
2339# endif
2340#endif
2341#ifdef PERL_NEED_MY_HTOBE32
2342# if U32SIZE == 4
2343HTOBE(Perl_my_htobe32,U32)
2344# else
2345NOT_AVAIL(Perl_my_htobe32,U32)
2346# endif
2347#endif
2348#ifdef PERL_NEED_MY_BETOH32
2349# if U32SIZE == 4
2350BETOH(Perl_my_betoh32,U32)
2351# else
2352NOT_AVAIL(Perl_my_betoh32,U32)
2353# endif
2354#endif
2355
2356#ifdef PERL_NEED_MY_HTOLE64
2357# if U64SIZE == 8
2358HTOLE(Perl_my_htole64,U64)
2359# else
2360NOT_AVAIL(Perl_my_htole64,U64)
2361# endif
2362#endif
2363#ifdef PERL_NEED_MY_LETOH64
2364# if U64SIZE == 8
2365LETOH(Perl_my_letoh64,U64)
2366# else
2367NOT_AVAIL(Perl_my_letoh64,U64)
2368# endif
2369#endif
2370#ifdef PERL_NEED_MY_HTOBE64
2371# if U64SIZE == 8
2372HTOBE(Perl_my_htobe64,U64)
2373# else
2374NOT_AVAIL(Perl_my_htobe64,U64)
2375# endif
2376#endif
2377#ifdef PERL_NEED_MY_BETOH64
2378# if U64SIZE == 8
2379BETOH(Perl_my_betoh64,U64)
2380# else
2381NOT_AVAIL(Perl_my_betoh64,U64)
2382# endif
988174c1 2383#endif
a687059c 2384
1109a392
MHM
2385#ifdef PERL_NEED_MY_HTOLES
2386HTOLE(Perl_my_htoles,short)
2387#endif
2388#ifdef PERL_NEED_MY_LETOHS
2389LETOH(Perl_my_letohs,short)
2390#endif
2391#ifdef PERL_NEED_MY_HTOBES
2392HTOBE(Perl_my_htobes,short)
2393#endif
2394#ifdef PERL_NEED_MY_BETOHS
2395BETOH(Perl_my_betohs,short)
2396#endif
2397
2398#ifdef PERL_NEED_MY_HTOLEI
2399HTOLE(Perl_my_htolei,int)
2400#endif
2401#ifdef PERL_NEED_MY_LETOHI
2402LETOH(Perl_my_letohi,int)
2403#endif
2404#ifdef PERL_NEED_MY_HTOBEI
2405HTOBE(Perl_my_htobei,int)
2406#endif
2407#ifdef PERL_NEED_MY_BETOHI
2408BETOH(Perl_my_betohi,int)
2409#endif
2410
2411#ifdef PERL_NEED_MY_HTOLEL
2412HTOLE(Perl_my_htolel,long)
2413#endif
2414#ifdef PERL_NEED_MY_LETOHL
2415LETOH(Perl_my_letohl,long)
2416#endif
2417#ifdef PERL_NEED_MY_HTOBEL
2418HTOBE(Perl_my_htobel,long)
2419#endif
2420#ifdef PERL_NEED_MY_BETOHL
2421BETOH(Perl_my_betohl,long)
2422#endif
2423
2424void
2425Perl_my_swabn(void *ptr, int n)
2426{
2427 register char *s = (char *)ptr;
2428 register char *e = s + (n-1);
2429 register char tc;
2430
7918f24d
NC
2431 PERL_ARGS_ASSERT_MY_SWABN;
2432
1109a392
MHM
2433 for (n /= 2; n > 0; s++, e--, n--) {
2434 tc = *s;
2435 *s = *e;
2436 *e = tc;
2437 }
2438}
2439
4a7d1889 2440PerlIO *
c9289b7b 2441Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2442{
e37778c2 2443#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
97aff369 2444 dVAR;
1f852d0d
NIS
2445 int p[2];
2446 register I32 This, that;
2447 register Pid_t pid;
2448 SV *sv;
2449 I32 did_pipes = 0;
2450 int pp[2];
2451
7918f24d
NC
2452 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2453
1f852d0d
NIS
2454 PERL_FLUSHALL_FOR_CHILD;
2455 This = (*mode == 'w');
2456 that = !This;
2457 if (PL_tainting) {
2458 taint_env();
2459 taint_proper("Insecure %s%s", "EXEC");
2460 }
2461 if (PerlProc_pipe(p) < 0)
4608196e 2462 return NULL;
1f852d0d
NIS
2463 /* Try for another pipe pair for error return */
2464 if (PerlProc_pipe(pp) >= 0)
2465 did_pipes = 1;
52e18b1f 2466 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2467 if (errno != EAGAIN) {
2468 PerlLIO_close(p[This]);
4e6dfe71 2469 PerlLIO_close(p[that]);
1f852d0d
NIS
2470 if (did_pipes) {
2471 PerlLIO_close(pp[0]);
2472 PerlLIO_close(pp[1]);
2473 }
4608196e 2474 return NULL;
1f852d0d 2475 }
a2a5de95 2476 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2477 sleep(5);
2478 }
2479 if (pid == 0) {
2480 /* Child */
1f852d0d
NIS
2481#undef THIS
2482#undef THAT
2483#define THIS that
2484#define THAT This
1f852d0d
NIS
2485 /* Close parent's end of error status pipe (if any) */
2486 if (did_pipes) {
2487 PerlLIO_close(pp[0]);
2488#if defined(HAS_FCNTL) && defined(F_SETFD)
2489 /* Close error pipe automatically if exec works */
2490 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2491#endif
2492 }
2493 /* Now dup our end of _the_ pipe to right position */
2494 if (p[THIS] != (*mode == 'r')) {
2495 PerlLIO_dup2(p[THIS], *mode == 'r');
2496 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2497 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2498 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2499 }
4e6dfe71
GS
2500 else
2501 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2502#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2503 /* No automatic close - do it by hand */
b7953727
JH
2504# ifndef NOFILE
2505# define NOFILE 20
2506# endif
a080fe3d
NIS
2507 {
2508 int fd;
2509
2510 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2511 if (fd != pp[1])
a080fe3d
NIS
2512 PerlLIO_close(fd);
2513 }
1f852d0d
NIS
2514 }
2515#endif
a0714e2c 2516 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2517 PerlProc__exit(1);
2518#undef THIS
2519#undef THAT
2520 }
2521 /* Parent */
52e18b1f 2522 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2523 if (did_pipes)
2524 PerlLIO_close(pp[1]);
2525 /* Keep the lower of the two fd numbers */
2526 if (p[that] < p[This]) {
2527 PerlLIO_dup2(p[This], p[that]);
2528 PerlLIO_close(p[This]);
2529 p[This] = p[that];
2530 }
4e6dfe71
GS
2531 else
2532 PerlLIO_close(p[that]); /* close child's end of pipe */
2533
1f852d0d 2534 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2535 SvUPGRADE(sv,SVt_IV);
45977657 2536 SvIV_set(sv, pid);
1f852d0d
NIS
2537 PL_forkprocess = pid;
2538 /* If we managed to get status pipe check for exec fail */
2539 if (did_pipes && pid > 0) {
2540 int errkid;
bb7a0f54
MHM
2541 unsigned n = 0;
2542 SSize_t n1;
1f852d0d
NIS
2543
2544 while (n < sizeof(int)) {
2545 n1 = PerlLIO_read(pp[0],
2546 (void*)(((char*)&errkid)+n),
2547 (sizeof(int)) - n);
2548 if (n1 <= 0)
2549 break;
2550 n += n1;
2551 }
2552 PerlLIO_close(pp[0]);
2553 did_pipes = 0;
2554 if (n) { /* Error */
2555 int pid2, status;
8c51524e 2556 PerlLIO_close(p[This]);
1f852d0d
NIS
2557 if (n != sizeof(int))
2558 Perl_croak(aTHX_ "panic: kid popen errno read");
2559 do {
2560 pid2 = wait4pid(pid, &status, 0);
2561 } while (pid2 == -1 && errno == EINTR);
2562 errno = errkid; /* Propagate errno from kid */
4608196e 2563 return NULL;
1f852d0d
NIS
2564 }
2565 }
2566 if (did_pipes)
2567 PerlLIO_close(pp[0]);
2568 return PerlIO_fdopen(p[This], mode);
2569#else
9d419b5f 2570# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2571 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2572# else
4a7d1889
NIS
2573 Perl_croak(aTHX_ "List form of piped open not implemented");
2574 return (PerlIO *) NULL;
9d419b5f 2575# endif
1f852d0d 2576#endif
4a7d1889
NIS
2577}
2578
5f05dabc 2579 /* VMS' my_popen() is in VMS.c, same with OS/2. */
e37778c2 2580#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
760ac839 2581PerlIO *
3dd43144 2582Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2583{
97aff369 2584 dVAR;
a687059c 2585 int p[2];
8ac85365 2586 register I32 This, that;
d8a83dd3 2587 register Pid_t pid;
79072805 2588 SV *sv;
bfce84ec 2589 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2590 I32 did_pipes = 0;
2591 int pp[2];
a687059c 2592
7918f24d
NC
2593 PERL_ARGS_ASSERT_MY_POPEN;
2594
45bc9206 2595 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2596#ifdef OS2
2597 if (doexec) {
23da6c43 2598 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2599 }
a1d180c4 2600#endif
8ac85365
NIS
2601 This = (*mode == 'w');
2602 that = !This;
3280af22 2603 if (doexec && PL_tainting) {
bbce6d69
PP
2604 taint_env();
2605 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2606 }
c2267164 2607 if (PerlProc_pipe(p) < 0)
4608196e 2608 return NULL;
e446cec8
IZ
2609 if (doexec && PerlProc_pipe(pp) >= 0)
2610 did_pipes = 1;
52e18b1f 2611 while ((pid = PerlProc_fork()) < 0) {
a687059c 2612 if (errno != EAGAIN) {
6ad3d225 2613 PerlLIO_close(p[This]);
b5ac89c3 2614 PerlLIO_close(p[that]);
e446cec8
IZ
2615 if (did_pipes) {
2616 PerlLIO_close(pp[0]);
2617 PerlLIO_close(pp[1]);
2618 }
a687059c 2619 if (!doexec)
b3647a36 2620 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2621 return NULL;
a687059c 2622 }
a2a5de95 2623 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2624 sleep(5);
2625 }
2626 if (pid == 0) {
79072805
LW
2627 GV* tmpgv;
2628
30ac6d9b
GS
2629#undef THIS
2630#undef THAT
a687059c 2631#define THIS that
8ac85365 2632#define THAT This
e446cec8
IZ
2633 if (did_pipes) {
2634 PerlLIO_close(pp[0]);
2635#if defined(HAS_FCNTL) && defined(F_SETFD)
2636 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2637#endif
2638 }
a687059c 2639 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2640 PerlLIO_dup2(p[THIS], *mode == 'r');
2641 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2642 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2643 PerlLIO_close(p[THAT]);
a687059c 2644 }
b5ac89c3
NIS
2645 else
2646 PerlLIO_close(p[THAT]);
4435c477 2647#ifndef OS2
a687059c 2648 if (doexec) {
a0d0e21e 2649#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2650#ifndef NOFILE
2651#define NOFILE 20
2652#endif
a080fe3d 2653 {
3aed30dc 2654 int fd;
a080fe3d
NIS
2655
2656 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2657 if (fd != pp[1])
3aed30dc 2658 PerlLIO_close(fd);
a080fe3d 2659 }
ae986130 2660#endif
a080fe3d
NIS
2661 /* may or may not use the shell */
2662 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2663 PerlProc__exit(1);
a687059c 2664 }
4435c477 2665#endif /* defined OS2 */
713cef20
IZ
2666
2667#ifdef PERLIO_USING_CRLF
2668 /* Since we circumvent IO layers when we manipulate low-level
2669 filedescriptors directly, need to manually switch to the
2670 default, binary, low-level mode; see PerlIOBuf_open(). */
2671 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2672#endif
2673
fafc274c 2674 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2675 SvREADONLY_off(GvSV(tmpgv));
7766f137 2676 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS
2677 SvREADONLY_on(GvSV(tmpgv));
2678 }
2679#ifdef THREADS_HAVE_PIDS
2680 PL_ppid = (IV)getppid();
2681#endif
3280af22 2682 PL_forkprocess = 0;
ca0c25f6 2683#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2684 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2685#endif
4608196e 2686 return NULL;
a687059c
LW
2687#undef THIS
2688#undef THAT
2689 }
b5ac89c3 2690 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2691 if (did_pipes)
2692 PerlLIO_close(pp[1]);
8ac85365 2693 if (p[that] < p[This]) {
6ad3d225
GS
2694 PerlLIO_dup2(p[This], p[that]);
2695 PerlLIO_close(p[This]);
8ac85365 2696 p[This] = p[that];
62b28dd9 2697 }
b5ac89c3
NIS
2698 else
2699 PerlLIO_close(p[that]);
2700
3280af22 2701 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2702 SvUPGRADE(sv,SVt_IV);
45977657 2703 SvIV_set(sv, pid);
3280af22 2704 PL_forkprocess = pid;
e446cec8
IZ
2705 if (did_pipes && pid > 0) {
2706 int errkid;
bb7a0f54
MHM
2707 unsigned n = 0;
2708 SSize_t n1;
e446cec8
IZ
2709
2710 while (n < sizeof(int)) {
2711 n1 = PerlLIO_read(pp[0],
2712 (void*)(((char*)&errkid)+n),
2713 (sizeof(int)) - n);
2714 if (n1 <= 0)
2715 break;
2716 n += n1;
2717 }
2f96c702
IZ
2718 PerlLIO_close(pp[0]);
2719 did_pipes = 0;
e446cec8 2720 if (n) { /* Error */
faa466a7 2721 int pid2, status;
8c51524e 2722 PerlLIO_close(p[This]);
e446cec8 2723 if (n != sizeof(int))
cea2e8a9 2724 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG
2725 do {
2726 pid2 = wait4pid(pid, &status, 0);
2727 } while (pid2 == -1 && errno == EINTR);
e446cec8 2728 errno = errkid; /* Propagate errno from kid */
4608196e 2729 return NULL;
e446cec8
IZ
2730 }
2731 }
2732 if (did_pipes)
2733 PerlLIO_close(pp[0]);
8ac85365 2734 return PerlIO_fdopen(p[This], mode);
a687059c 2735}
7c0587c8 2736#else
85ca448a 2737#if defined(atarist) || defined(EPOC)
7c0587c8 2738FILE *popen();
760ac839 2739PerlIO *
cef6ea9d 2740Perl_my_popen(pTHX_ const char *cmd, const char *mode)
7c0587c8 2741{
7918f24d 2742 PERL_ARGS_ASSERT_MY_POPEN;
45bc9206 2743 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS
2744 /* Call system's popen() to get a FILE *, then import it.
2745 used 0 for 2nd parameter to PerlIO_importFILE;
2746 apparently not used
2747 */
2748 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2749}
2b96b0a5
JH
2750#else
2751#if defined(DJGPP)
2752FILE *djgpp_popen();
2753PerlIO *
cef6ea9d 2754Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2755{
2756 PERL_FLUSHALL_FOR_CHILD;
2757 /* Call system's popen() to get a FILE *, then import it.
2758 used 0 for 2nd parameter to PerlIO_importFILE;
2759 apparently not used
2760 */
2761 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2762}
9c12f1e5
RGS
2763#else
2764#if defined(__LIBCATAMOUNT__)
2765PerlIO *
2766Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2767{
2768 return NULL;
2769}
2770#endif
2b96b0a5 2771#endif
7c0587c8
LW
2772#endif
2773
2774#endif /* !DOSISH */
a687059c 2775
52e18b1f
GS
2776/* this is called in parent before the fork() */
2777void
2778Perl_atfork_lock(void)
2779{
27da23d5 2780 dVAR;
3db8f154 2781#if defined(USE_ITHREADS)
52e18b1f
GS
2782 /* locks must be held in locking order (if any) */
2783# ifdef MYMALLOC
2784 MUTEX_LOCK(&PL_malloc_mutex);
2785# endif
2786 OP_REFCNT_LOCK;
2787#endif
2788}
2789
2790/* this is called in both parent and child after the fork() */
2791void
2792Perl_atfork_unlock(void)
2793{
27da23d5 2794 dVAR;
3db8f154 2795#if defined(USE_ITHREADS)
52e18b1f
GS
2796 /* locks must be released in same order as in atfork_lock() */
2797# ifdef MYMALLOC
2798 MUTEX_UNLOCK(&PL_malloc_mutex);
2799# endif
2800 OP_REFCNT_UNLOCK;
2801#endif
2802}
2803
2804Pid_t
2805Perl_my_fork(void)
2806{
2807#if defined(HAS_FORK)
2808 Pid_t pid;
3db8f154 2809#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2810 atfork_lock();
2811 pid = fork();
2812 atfork_unlock();
2813#else
2814 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2815 * handlers elsewhere in the code */
2816 pid = fork();
2817#endif
2818 return pid;
2819#else
2820 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2821 Perl_croak_nocontext("fork() not available");
b961a566 2822 return 0;
52e18b1f
GS
2823#endif /* HAS_FORK */
2824}
2825
748a9306 2826#ifdef DUMP_FDS
35ff7856 2827void
c9289b7b 2828Perl_dump_fds(pTHX_ const char *const s)
ae986130
LW
2829{
2830 int fd;
c623ac67 2831 Stat_t tmpstatbuf;
ae986130 2832
7918f24d
NC
2833 PERL_ARGS_ASSERT_DUMP_FDS;
2834
bf49b057 2835 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2836 for (fd = 0; fd < 32; fd++) {
6ad3d225 2837 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2838 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2839 }
bf49b057 2840 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2841 return;
ae986130 2842}
35ff7856 2843#endif /* DUMP_FDS */
ae986130 2844
fe14fcc3 2845#ifndef HAS_DUP2
fec02dd3 2846int
ba106d47 2847dup2(int oldfd, int newfd)
a687059c 2848{
a0d0e21e 2849#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2850 if (oldfd == newfd)
2851 return oldfd;
6ad3d225 2852 PerlLIO_close(newfd);
fec02dd3 2853 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2854#else
fc36a67e
PP
2855#define DUP2_MAX_FDS 256
2856 int fdtmp[DUP2_MAX_FDS];
79072805 2857 I32 fdx = 0;
ae986130
LW
2858 int fd;
2859
fe14fcc3 2860 if (oldfd == newfd)
fec02dd3 2861 return oldfd;
6ad3d225 2862 PerlLIO_close(newfd);
fc36a67e 2863 /* good enough for low fd's... */
6ad3d225 2864 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2865 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2866 PerlLIO_close(fd);
fc36a67e
PP
2867 fd = -1;
2868 break;
2869 }
ae986130 2870 fdtmp[fdx++] = fd;
fc36a67e 2871 }
ae986130 2872 while (fdx > 0)
6ad3d225 2873 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2874 return fd;
62b28dd9 2875#endif
a687059c
LW
2876}
2877#endif
2878
64ca3a65 2879#ifndef PERL_MICRO
ff68c719
PP
2880#ifdef HAS_SIGACTION
2881
2882Sighandler_t
864dbfa3 2883Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2884{
27da23d5 2885 dVAR;
ff68c719
PP
2886 struct sigaction act, oact;
2887
a10b1e10
JH
2888#ifdef USE_ITHREADS
2889 /* only "parent" interpreter can diddle signals */
2890 if (PL_curinterp != aTHX)
8aad04aa 2891 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2892#endif
2893
8aad04aa 2894 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2895 sigemptyset(&act.sa_mask);
2896 act.sa_flags = 0;
2897#ifdef SA_RESTART
4ffa73a3
JH
2898 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2899 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2900#endif
358837b8 2901#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2902 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2903 act.sa_flags |= SA_NOCLDWAIT;
2904#endif
ff68c719 2905 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2906 return (Sighandler_t) SIG_ERR;
ff68c719 2907 else
8aad04aa 2908 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2909}
2910
2911Sighandler_t
864dbfa3 2912Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2913{
2914 struct sigaction oact;
96a5add6 2915 PERL_UNUSED_CONTEXT;
ff68c719
PP
2916
2917 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2918 return (Sighandler_t) SIG_ERR;
ff68c719 2919 else
8aad04aa 2920 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2921}
2922
2923int
864dbfa3 2924Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2925{
27da23d5 2926 dVAR;
ff68c719
PP
2927 struct sigaction act;
2928
7918f24d
NC
2929 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2930
a10b1e10
JH
2931#ifdef USE_ITHREADS
2932 /* only "parent" interpreter can diddle signals */
2933 if (PL_curinterp != aTHX)
2934 return -1;
2935#endif
2936
8aad04aa 2937 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2938 sigemptyset(&act.sa_mask);
2939 act.sa_flags = 0;
2940#ifdef SA_RESTART
4ffa73a3
JH
2941 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2942 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2943#endif
36b5d377 2944#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2945 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2946 act.sa_flags |= SA_NOCLDWAIT;
2947#endif
ff68c719
PP
2948 return sigaction(signo, &act, save);
2949}
2950
2951int
864dbfa3 2952Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2953{
27da23d5 2954 dVAR;
a10b1e10
JH
2955#ifdef USE_ITHREADS
2956 /* only "parent" interpreter can diddle signals */
2957 if (PL_curinterp != aTHX)
2958 return -1;
2959#endif
2960
ff68c719
PP
2961 return sigaction(signo, save, (struct sigaction *)NULL);
2962}
2963
2964#else /* !HAS_SIGACTION */
2965
2966Sighandler_t
864dbfa3 2967Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2968{
39f1703b 2969#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2970 /* only "parent" interpreter can diddle signals */
2971 if (PL_curinterp != aTHX)
8aad04aa 2972 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2973#endif
2974
6ad3d225 2975 return PerlProc_signal(signo, handler);
ff68c719
PP
2976}
2977
fabdb6c0 2978static Signal_t
4e35701f 2979sig_trap(int signo)
ff68c719 2980{
27da23d5
JH
2981 dVAR;
2982 PL_sig_trapped++;
ff68c719
PP
2983}
2984
2985Sighandler_t
864dbfa3 2986Perl_rsignal_state(pTHX_ int signo)
ff68c719 2987{
27da23d5 2988 dVAR;
ff68c719
PP
2989 Sighandler_t oldsig;
2990
39f1703b 2991#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2992 /* only "parent" interpreter can diddle signals */
2993 if (PL_curinterp != aTHX)
8aad04aa 2994 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2995#endif
2996
27da23d5 2997 PL_sig_trapped = 0;
6ad3d225
GS
2998 oldsig = PerlProc_signal(signo, sig_trap);
2999 PerlProc_signal(signo, oldsig);
27da23d5 3000 if (PL_sig_trapped)
3aed30dc 3001 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
3002 return oldsig;
3003}
3004
3005int
864dbfa3 3006Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 3007{
39f1703b 3008#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3009 /* only "parent" interpreter can diddle signals */
3010 if (PL_curinterp != aTHX)
3011 return -1;
3012#endif
6ad3d225 3013 *save = PerlProc_signal(signo, handler);
8aad04aa 3014 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3015}
3016
3017int
864dbfa3 3018Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3019{
39f1703b 3020#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3021 /* only "parent" interpreter can diddle signals */
3022 if (PL_curinterp != aTHX)
3023 return -1;
3024#endif
8aad04aa 3025 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3026}
3027
3028#endif /* !HAS_SIGACTION */
64ca3a65 3029#endif /* !PERL_MICRO */
ff68c719 3030
5f05dabc 3031 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
e37778c2 3032#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
79072805 3033I32
864dbfa3 3034Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3035{
97aff369 3036 dVAR;
ff68c719 3037 Sigsave_t hstat, istat, qstat;
a687059c 3038 int status;
a0d0e21e 3039 SV **svp;
d8a83dd3
JH
3040 Pid_t pid;
3041 Pid_t pid2;
03136e13 3042 bool close_failed;
4ee39169 3043 dSAVEDERRNO;
a687059c 3044
3280af22 3045 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
25d92023 3046 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 3047 SvREFCNT_dec(*svp);
3280af22 3048 *svp = &PL_sv_undef;
ddcf38b7
IZ
3049#ifdef OS2
3050 if (pid == -1) { /* Opened by popen. */
3051 return my_syspclose(ptr);
3052 }
a1d180c4 3053#endif
f1618b10
CS
3054 close_failed = (PerlIO_close(ptr) == EOF);
3055 SAVE_ERRNO;
7c0587c8 3056#ifdef UTS
6ad3d225 3057 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 3058#endif
64ca3a65 3059#ifndef PERL_MICRO
8aad04aa
JH
3060 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3061 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3062 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 3063#endif
748a9306 3064 do {
1d3434b8
GS
3065 pid2 = wait4pid(pid, &status, 0);
3066 } while (pid2 == -1 && errno == EINTR);
64ca3a65 3067#ifndef PERL_MICRO
ff68c719
PP
3068 rsignal_restore(SIGHUP, &hstat);
3069 rsignal_restore(SIGINT, &istat);
3070 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 3071#endif
03136e13 3072 if (close_failed) {
4ee39169 3073 RESTORE_ERRNO;
03136e13
CS
3074 return -1;
3075 }
1d3434b8 3076 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 3077}
9c12f1e5
RGS
3078#else
3079#if defined(__LIBCATAMOUNT__)
3080I32
3081Perl_my_pclose(pTHX_ PerlIO *ptr)
3082{
3083 return -1;
3084}
3085#endif
4633a7c4
LW
3086#endif /* !DOSISH */
3087
e37778c2 3088#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3089I32
d8a83dd3 3090Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3091{
97aff369 3092 dVAR;
27da23d5 3093 I32 result = 0;
7918f24d 3094 PERL_ARGS_ASSERT_WAIT4PID;
b7953727
JH
3095 if (!pid)
3096 return -1;
ca0c25f6 3097#ifdef PERL_USES_PL_PIDSTATUS
b7953727 3098 {
3aed30dc 3099 if (pid > 0) {
12072db5
NC
3100 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3101 pid, rather than a string form. */
c4420975 3102 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
3103 if (svp && *svp != &PL_sv_undef) {
3104 *statusp = SvIVX(*svp);
12072db5
NC
3105 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3106 G_DISCARD);
3aed30dc
HS
3107 return pid;
3108 }
3109 }
3110 else {
3111 HE *entry;
3112
3113 hv_iterinit(PL_pidstatus);
3114 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3115 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3116 I32 len;
0bcc34c2 3117 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3118
12072db5
NC
3119 assert (len == sizeof(Pid_t));
3120 memcpy((char *)&pid, spid, len);
3aed30dc 3121 *statusp = SvIVX(sv);
7b9a3241
NC
3122 /* The hash iterator is currently on this entry, so simply
3123 calling hv_delete would trigger the lazy delete, which on
3124 aggregate does more work, beacuse next call to hv_iterinit()
3125 would spot the flag, and have to call the delete routine,
3126 while in the meantime any new entries can't re-use that
3127 memory. */
3128 hv_iterinit(PL_pidstatus);
7ea75b61 3129 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
3130 return pid;
3131 }
20188a90
LW
3132 }
3133 }
68a29c53 3134#endif
79072805 3135#ifdef HAS_WAITPID
367f3c24
IZ
3136# ifdef HAS_WAITPID_RUNTIME
3137 if (!HAS_WAITPID_RUNTIME)
3138 goto hard_way;
3139# endif
cddd4526 3140 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3141 goto finish;
367f3c24
IZ
3142#endif
3143#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 3144 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 3145 goto finish;
367f3c24 3146#endif
ca0c25f6 3147#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3148#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3149 hard_way:
27da23d5 3150#endif
a0d0e21e 3151 {
a0d0e21e 3152 if (flags)
cea2e8a9 3153 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3154 else {
76e3520e 3155 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3156 pidgone(result,*statusp);
3157 if (result < 0)
3158 *statusp = -1;
3159 }
a687059c
LW
3160 }
3161#endif
27da23d5 3162#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3163 finish:
27da23d5 3164#endif
cddd4526
NIS
3165 if (result < 0 && errno == EINTR) {
3166 PERL_ASYNC_CHECK();
48dbb59e 3167 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3168 }
3169 return result;
a687059c 3170}
2986a63f 3171#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3172
ca0c25f6 3173#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3174void
ed4173ef 3175S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3176{
79072805 3177 register SV *sv;
a687059c 3178
12072db5 3179 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3180 SvUPGRADE(sv,SVt_IV);
45977657 3181 SvIV_set(sv, status);
20188a90 3182 return;
a687059c 3183}
ca0c25f6 3184#endif
a687059c 3185
85ca448a 3186#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 3187int pclose();
ddcf38b7
IZ
3188#ifdef HAS_FORK
3189int /* Cannot prototype with I32
3190 in os2ish.h. */
ba106d47 3191my_syspclose(PerlIO *ptr)
ddcf38b7 3192#else
79072805 3193I32
864dbfa3 3194Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3195#endif
a687059c 3196{
760ac839 3197 /* Needs work for PerlIO ! */
c4420975 3198 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3199 const I32 result = pclose(f);
2b96b0a5
JH
3200 PerlIO_releaseFILE(ptr,f);
3201 return result;
3202}
3203#endif
3204
933fea7f 3205#if defined(DJGPP)
2b96b0a5
JH
3206int djgpp_pclose();
3207I32
3208Perl_my_pclose(pTHX_ PerlIO *ptr)
3209{
3210 /* Needs work for PerlIO ! */
c4420975 3211 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3212 I32 result = djgpp_pclose(f);
933fea7f 3213 result = (result << 8) & 0xff00;
760ac839
LW
3214 PerlIO_releaseFILE(ptr,f);
3215 return result;
a687059c 3216}
7c0587c8 3217#endif
9f68db38 3218
16fa5c11 3219#define PERL_REPEATCPY_LINEAR 4
9f68db38 3220void
16fa5c11 3221Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
9f68db38 3222{
7918f24d
NC
3223 PERL_ARGS_ASSERT_REPEATCPY;
3224
16fa5c11
VP
3225 if (len == 1)
3226 memset(to, *from, count);
3227 else if (count) {
3228 register char *p = to;
3229 I32 items, linear, half;
3230
3231 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3232 for (items = 0; items < linear; ++items) {
3233 register const char *q = from;
3234 I32 todo;
3235 for (todo = len; todo > 0; todo--)
3236 *p++ = *q++;
3237 }
3238
3239 half = count / 2;
3240 while (items <= half) {
3241 I32 size = items * len;
3242 memcpy(p, to, size);
3243 p += size;
3244 items *= 2;
9f68db38 3245 }
16fa5c11
VP
3246
3247 if (count > items)
3248 memcpy(p, to, (count - items) * len);
9f68db38
LW
3249 }
3250}
0f85fab0 3251
fe14fcc3 3252#ifndef HAS_RENAME
79072805 3253I32
4373e329 3254Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3255{
93a17b20
LW
3256 char *fa = strrchr(a,'/');
3257 char *fb = strrchr(b,'/');
c623ac67
GS
3258 Stat_t tmpstatbuf1;
3259 Stat_t tmpstatbuf2;
c4420975 3260 SV * const tmpsv = sv_newmortal();
62b28dd9 3261
7918f24d
NC
3262 PERL_ARGS_ASSERT_SAME_DIRENT;
3263
62b28dd9
LW
3264 if (fa)
3265 fa++;
3266 else
3267 fa = a;
3268 if (fb)
3269 fb++;
3270 else
3271 fb = b;
3272 if (strNE(a,b))
3273 return FALSE;
3274 if (fa == a)
76f68e9b 3275 sv_setpvs(tmpsv, ".");
62b28dd9 3276 else
46fc3d4c 3277 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3278 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3279 return FALSE;
3280 if (fb == b)
76f68e9b 3281 sv_setpvs(tmpsv, ".");
62b28dd9 3282 else
46fc3d4c 3283 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3284 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3285 return FALSE;
3286 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3287 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3288}
fe14fcc3
LW
3289#endif /* !HAS_RENAME */
3290
491527d0 3291char*
7f315aed
NC
3292Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3293 const char *const *const search_ext, I32 flags)
491527d0 3294{
97aff369 3295 dVAR;
bd61b366
SS
3296 const char *xfound = NULL;
3297 char *xfailed = NULL;
0f31cffe 3298 char tmpbuf[MAXPATHLEN];
491527d0 3299 register char *s;
5f74f29c 3300 I32 len = 0;
491527d0 3301 int retval;
39a02377 3302 char *bufend;
491527d0
GS
3303#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3304# define SEARCH_EXTS ".bat", ".cmd", NULL
3305# define MAX_EXT_LEN 4
3306#endif
3307#ifdef OS2
3308# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3309# define MAX_EXT_LEN 4
3310#endif
3311#ifdef VMS
3312# define SEARCH_EXTS ".pl", ".com", NULL
3313# define MAX_EXT_LEN 4
3314#endif
3315 /* additional extensions to try in each dir if scriptname not found */
3316#ifdef SEARCH_EXTS
0bcc34c2 3317 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3318 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3319 int extidx = 0, i = 0;
bd61b366 3320 const char *curext = NULL;
491527d0 3321#else
53c1dcc0 3322 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3323# define MAX_EXT_LEN 0
3324#endif
3325
7918f24d
NC
3326 PERL_ARGS_ASSERT_FIND_SCRIPT;
3327
491527d0
GS
3328 /*
3329 * If dosearch is true and if scriptname does not contain path
3330 * delimiters, search the PATH for scriptname.
3331 *
3332 * If SEARCH_EXTS is also defined, will look for each
3333 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3334 * while searching the PATH.
3335 *
3336 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3337 * proceeds as follows:
3338 * If DOSISH or VMSISH:
3339 * + look for ./scriptname{,.foo,.bar}
3340 * + search the PATH for scriptname{,.foo,.bar}
3341 *
3342 * If !DOSISH:
3343 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3344 * this will not look in '.' if it's not in the PATH)
3345 */
84486fc6 3346 tmpbuf[0] = '\0';
491527d0
GS
3347
3348#ifdef VMS
3349# ifdef ALWAYS_DEFTYPES
3350 len = strlen(scriptname);
3351 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3352 int idx = 0, deftypes = 1;
491527d0
GS
3353 bool seen_dot = 1;
3354
bd61b366 3355 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3356# else
3357 if (dosearch) {
c4420975 3358 int idx = 0, deftypes = 1;
491527d0
GS
3359 bool seen_dot = 1;
3360
bd61b366 3361 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3362# endif
3363 /* The first time through, just add SEARCH_EXTS to whatever we
3364 * already have, so we can check for default file types. */
3365 while (deftypes ||
84486fc6 3366 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3367 {
3368 if (deftypes) {
3369 deftypes = 0;
84486fc6 3370 *tmpbuf = '\0';
491527d0 3371 }
84486fc6
GS
3372 if ((strlen(tmpbuf) + strlen(scriptname)
3373 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3374 continue; /* don't search dir with too-long name */
6fca0082 3375 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3376#else /* !VMS */
3377
3378#ifdef DOSISH
3379 if (strEQ(scriptname, "-"))
3380 dosearch = 0;
3381 if (dosearch) { /* Look in '.' first. */
fe2774ed 3382 const char *cur = scriptname;
491527d0
GS
3383#ifdef SEARCH_EXTS
3384 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3385 while (ext[i])
3386 if (strEQ(ext[i++],curext)) {
3387 extidx = -1; /* already has an ext */
3388 break;
3389 }
3390 do {
3391#endif
3392 DEBUG_p(PerlIO_printf(Perl_debug_log,
3393 "Looking for %s\n",cur));
017f25f1
IZ
3394 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3395 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3396 dosearch = 0;
3397 scriptname = cur;
3398#ifdef SEARCH_EXTS
3399 break;
3400#endif
3401 }
3402#ifdef SEARCH_EXTS
3403 if (cur == scriptname) {
3404 len = strlen(scriptname);
84486fc6 3405 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3406 break;
9e4425f7
SH
3407 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3408 cur = tmpbuf;
491527d0
GS
3409 }
3410 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3411 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3412#endif
3413 }
3414#endif
3415
3416 if (dosearch && !strchr(scriptname, '/')
3417#ifdef DOSISH
3418 && !strchr(scriptname, '\\')
3419#endif
cd39f2b6 3420 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3421 {
491527d0 3422 bool seen_dot = 0;
92f0c265 3423
39a02377
DM
3424 bufend = s + strlen(s);
3425 while (s < bufend) {
491527d0
GS
3426#if defined(atarist) || defined(DOSISH)
3427 for (len = 0; *s
3428# ifdef atarist
3429 && *s != ','
3430# endif
3431 && *s != ';'; len++, s++) {
84486fc6
GS
3432 if (len < sizeof tmpbuf)
3433 tmpbuf[len] = *s;
491527d0 3434 }
84486fc6
GS
3435 if (len < sizeof tmpbuf)
3436 tmpbuf[len] = '\0';
491527d0 3437#else /* ! (atarist || DOSISH) */
39a02377 3438 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3439 ':',
3440 &len);
3441#endif /* ! (atarist || DOSISH) */
39a02377 3442 if (s < bufend)
491527d0 3443 s++;
84486fc6 3444 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3445 continue; /* don't search dir with too-long name */
3446 if (len
cd86ed9d 3447# if defined(atarist) || defined(DOSISH)
84486fc6
GS
3448 && tmpbuf[len - 1] != '/'
3449 && tmpbuf[len - 1] != '\\'
490a0e98 3450# endif
491527d0 3451 )
84486fc6
GS
3452 tmpbuf[len++] = '/';
3453 if (len == 2 && tmpbuf[0] == '.')
491527d0 3454 seen_dot = 1;
28f0d0ec 3455 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3456#endif /* !VMS */
3457
3458#ifdef SEARCH_EXTS
84486fc6 3459 len = strlen(tmpbuf);
491527d0
GS
3460 if (extidx > 0) /* reset after previous loop */
3461 extidx = 0;
3462 do {
3463#endif
84486fc6 3464 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3465 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ
3466 if (S_ISDIR(PL_statbuf.st_mode)) {
3467 retval = -1;
3468 }
491527d0
GS
3469#ifdef SEARCH_EXTS
3470 } while ( retval < 0 /* not there */
3471 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3472 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3473 );
3474#endif
3475 if (retval < 0)
3476 continue;
3280af22
NIS
3477 if (S_ISREG(PL_statbuf.st_mode)
3478 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3479#if !defined(DOSISH)
3280af22 3480 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS
3481#endif
3482 )
3483 {
3aed30dc 3484 xfound = tmpbuf; /* bingo! */
491527d0
GS
3485 break;
3486 }
3487 if (!xfailed)
84486fc6 3488 xfailed = savepv(tmpbuf);
491527d0
GS
3489 }
3490#ifndef DOSISH
017f25f1 3491 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3492 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3493 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS
3494#endif
3495 seen_dot = 1; /* Disable message. */
9ccb31f9
GS
3496 if (!xfound) {
3497 if (flags & 1) { /* do or die? */
3aed30dc 3498 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3499 (xfailed ? "execute" : "find"),
3500 (xfailed ? xfailed : scriptname),
3501 (xfailed ? "" : " on PATH"),
3502 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3503 }
bd61b366 3504 scriptname = NULL;
9ccb31f9 3505 }
43c5f42d 3506 Safefree(xfailed);
491527d0
GS
3507 scriptname = xfound;
3508 }
bd61b366 3509 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3510}
3511
ba869deb
GS
3512#ifndef PERL_GET_CONTEXT_DEFINED
3513
3514void *
3515Perl_get_context(void)
3516{
27da23d5 3517 dVAR;
3db8f154 3518#if defined(USE_ITHREADS)
ba869deb
GS
3519# ifdef OLD_PTHREADS_API
3520 pthread_addr_t t;
3521 if (pthread_getspecific(PL_thr_key, &t))
3522 Perl_croak_nocontext("panic: pthread_getspecific");
3523 return (void*)t;
3524# else
bce813aa 3525# ifdef I_MACH_CTHREADS
8b8b35ab 3526 return (void*)cthread_data(cthread_self());
bce813aa 3527# else
8b8b35ab
JH
3528 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3529# endif
c44d3fdb 3530# endif
ba869deb
GS
3531#else
3532 return (void*)NULL;
3533#endif
3534}
3535
3536void
3537Perl_set_context(void *t)
3538{
8772537c 3539 dVAR;
7918f24d 3540 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3541#if defined(USE_ITHREADS)
c44d3fdb
GS
3542# ifdef I_MACH_CTHREADS
3543 cthread_set_data(cthread_self(), t);
3544# else
ba869deb
GS
3545 if (pthread_setspecific(PL_thr_key, t))
3546 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3547# endif
b464bac0 3548#else
8772537c 3549 PERL_UNUSED_ARG(t);
ba869deb
GS
3550#endif
3551}
3552
3553#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3554
27da23d5 3555#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3556struct perl_vars *
864dbfa3 3557Perl_GetVars(pTHX)
22239a37 3558{
533c011a 3559 return &PL_Vars;
22239a37 3560}
31fb1209
NIS
3561#endif
3562
1cb0ed9b 3563char **
864dbfa3 3564Perl_get_op_names(pTHX)
31fb1209 3565{
96a5add6
AL
3566 PERL_UNUSED_CONTEXT;
3567 return (char **)PL_op_name;
31fb1209
NIS
3568}
3569
1cb0ed9b 3570char **
864dbfa3 3571Perl_get_op_descs(pTHX)
31fb1209 3572{
96a5add6
AL
3573 PERL_UNUSED_CONTEXT;
3574 return (char **)PL_op_desc;
31fb1209 3575}
9e6b2b00 3576
e1ec3a88 3577const char *
864dbfa3 3578Perl_get_no_modify(pTHX)
9e6b2b00 3579{
96a5add6
AL
3580 PERL_UNUSED_CONTEXT;
3581 return PL_no_modify;
9e6b2b00
GS
3582}
3583
3584U32 *
864dbfa3 3585Perl_get_opargs(pTHX)
9e6b2b00 3586{
96a5add6
AL
3587 PERL_UNUSED_CONTEXT;
3588 return (U32 *)PL_opargs;
9e6b2b00 3589}
51aa15f3 3590
0cb96387
GS
3591PPADDR_t*
3592Perl_get_ppaddr(pTHX)
3593{
96a5add6
AL
3594 dVAR;
3595 PERL_UNUSED_CONTEXT;
3596 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3597}
3598
a6c40364
GS
3599#ifndef HAS_GETENV_LEN
3600char *
bf4acbe4 3601Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3602{
8772537c 3603 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3604 PERL_UNUSED_CONTEXT;
7918f24d 3605 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS
3606 if (env_trans)
3607 *len = strlen(env_trans);
3608 return env_trans;
f675dbe5
CB
3609}
3610#endif
3611
dc9e4912
GS
3612
3613MGVTBL*
864dbfa3 3614Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3615{
7452cf6a 3616 const MGVTBL* result;
96a5add6