This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Attempt at improving the perlipc docs
[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
e6226b18
KW
881/*
882=for apidoc foldEQ
883
884Returns true if the leading len bytes of the strings s1 and s2 are the same
885case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
886match themselves and their opposite case counterparts. Non-cased and non-ASCII
887range bytes match only themselves.
888
889=cut
890*/
891
892
79072805 893I32
e6226b18 894Perl_foldEQ(const char *s1, const char *s2, register I32 len)
79072805 895{
e1ec3a88
AL
896 register const U8 *a = (const U8 *)s1;
897 register const U8 *b = (const U8 *)s2;
96a5add6 898
e6226b18 899 PERL_ARGS_ASSERT_FOLDEQ;
7918f24d 900
79072805 901 while (len--) {
22c35a8c 902 if (*a != *b && *a != PL_fold[*b])
e6226b18 903 return 0;
bbce6d69
PP
904 a++,b++;
905 }
e6226b18 906 return 1;
bbce6d69
PP
907}
908
e6226b18
KW
909/*
910=for apidoc foldEQ_locale
911
912Returns true if the leading len bytes of the strings s1 and s2 are the same
913case-insensitively in the current locale; false otherwise.
914
915=cut
916*/
917
bbce6d69 918I32
e6226b18 919Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
bbce6d69 920{
27da23d5 921 dVAR;
e1ec3a88
AL
922 register const U8 *a = (const U8 *)s1;
923 register const U8 *b = (const U8 *)s2;
96a5add6 924
e6226b18 925 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
7918f24d 926
bbce6d69 927 while (len--) {
22c35a8c 928 if (*a != *b && *a != PL_fold_locale[*b])
e6226b18 929 return 0;
bbce6d69 930 a++,b++;
79072805 931 }
e6226b18 932 return 1;
79072805
LW
933}
934
8d063cd8
LW
935/* copy a string to a safe spot */
936
954c1994 937/*
ccfc67b7
JH
938=head1 Memory Management
939
954c1994
GS
940=for apidoc savepv
941
61a925ed
AMS
942Perl's version of C<strdup()>. Returns a pointer to a newly allocated
943string which is a duplicate of C<pv>. The size of the string is
944determined by C<strlen()>. The memory allocated for the new string can
945be freed with the C<Safefree()> function.
954c1994
GS
946
947=cut
948*/
949
8d063cd8 950char *
efdfce31 951Perl_savepv(pTHX_ const char *pv)
8d063cd8 952{
96a5add6 953 PERL_UNUSED_CONTEXT;
e90e2364 954 if (!pv)
bd61b366 955 return NULL;
66a1b24b
AL
956 else {
957 char *newaddr;
958 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH
959 Newx(newaddr, pvlen, char);
960 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 961 }
8d063cd8
LW
962}
963
a687059c
LW
964/* same thing but with a known length */
965
954c1994
GS
966/*
967=for apidoc savepvn
968
61a925ed
AMS
969Perl's version of what C<strndup()> would be if it existed. Returns a
970pointer to a newly allocated string which is a duplicate of the first
cbf82dd0
NC
971C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
972the new string can be freed with the C<Safefree()> function.
954c1994
GS
973
974=cut
975*/
976
a687059c 977char *
efdfce31 978Perl_savepvn(pTHX_ const char *pv, register I32 len)
a687059c
LW
979{
980 register char *newaddr;
96a5add6 981 PERL_UNUSED_CONTEXT;
a687059c 982
a02a5408 983 Newx(newaddr,len+1,char);
92110913 984 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 985 if (pv) {
e90e2364
NC
986 /* might not be null terminated */
987 newaddr[len] = '\0';
07409e01 988 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS
989 }
990 else {
07409e01 991 return (char *) ZeroD(newaddr,len+1,char);
92110913 992 }
a687059c
LW
993}
994
05ec9bb3
NIS
995/*
996=for apidoc savesharedpv
997
61a925ed
AMS
998A version of C<savepv()> which allocates the duplicate string in memory
999which is shared between threads.
05ec9bb3
NIS
1000
1001=cut
1002*/
1003char *
efdfce31 1004Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 1005{
e90e2364 1006 register char *newaddr;
490a0e98 1007 STRLEN pvlen;
e90e2364 1008 if (!pv)
bd61b366 1009 return NULL;
e90e2364 1010
490a0e98
NC
1011 pvlen = strlen(pv)+1;
1012 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 1013 if (!newaddr) {
0bd48802 1014 return write_no_mem();
05ec9bb3 1015 }
10edeb5d 1016 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS
1017}
1018
2e0de35c 1019/*
d9095cec
NC
1020=for apidoc savesharedpvn
1021
1022A version of C<savepvn()> which allocates the duplicate string in memory
1023which is shared between threads. (With the specific difference that a NULL
1024pointer is not acceptable)
1025
1026=cut
1027*/
1028char *
1029Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1030{
1031 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d
NC
1032
1033 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1034
d9095cec
NC
1035 if (!newaddr) {
1036 return write_no_mem();
1037 }
1038 newaddr[len] = '\0';
1039 return (char*)memcpy(newaddr, pv, len);
1040}
1041
1042/*
2e0de35c
NC
1043=for apidoc savesvpv
1044
6832267f 1045A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC
1046the passed in SV using C<SvPV()>
1047
1048=cut
1049*/
1050
1051char *
1052Perl_savesvpv(pTHX_ SV *sv)
1053{
1054 STRLEN len;
7452cf6a 1055 const char * const pv = SvPV_const(sv, len);
2e0de35c
NC
1056 register char *newaddr;
1057
7918f24d
NC
1058 PERL_ARGS_ASSERT_SAVESVPV;
1059
26866f99 1060 ++len;
a02a5408 1061 Newx(newaddr,len,char);
07409e01 1062 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1063}
05ec9bb3
NIS
1064
1065
cea2e8a9 1066/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1067
76e3520e 1068STATIC SV *
cea2e8a9 1069S_mess_alloc(pTHX)
fc36a67e 1070{
97aff369 1071 dVAR;
fc36a67e
PP
1072 SV *sv;
1073 XPVMG *any;
1074
e72dc28c 1075 if (!PL_dirty)
84bafc02 1076 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1077
0372dbb6
GS
1078 if (PL_mess_sv)
1079 return PL_mess_sv;
1080
fc36a67e 1081 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC
1082 Newx(sv, 1, SV);
1083 Newxz(any, 1, XPVMG);
fc36a67e
PP
1084 SvFLAGS(sv) = SVt_PVMG;
1085 SvANY(sv) = (void*)any;
6136c704 1086 SvPV_set(sv, NULL);
fc36a67e 1087 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1088 PL_mess_sv = sv;
fc36a67e
PP
1089 return sv;
1090}
1091
c5be433b 1092#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1093char *
1094Perl_form_nocontext(const char* pat, ...)
1095{
1096 dTHX;
c5be433b 1097 char *retval;
cea2e8a9 1098 va_list args;
7918f24d 1099 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1100 va_start(args, pat);
c5be433b 1101 retval = vform(pat, &args);
cea2e8a9 1102 va_end(args);
c5be433b 1103 return retval;
cea2e8a9 1104}
c5be433b 1105#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1106
7c9e965c 1107/*
ccfc67b7 1108=head1 Miscellaneous Functions
7c9e965c
JP
1109=for apidoc form
1110
1111Takes a sprintf-style format pattern and conventional
1112(non-SV) arguments and returns the formatted string.
1113
1114 (char *) Perl_form(pTHX_ const char* pat, ...)
1115
1116can be used any place a string (char *) is required:
1117
1118 char * s = Perl_form("%d.%d",major,minor);
1119
1120Uses a single private buffer so if you want to format several strings you
1121must explicitly copy the earlier strings away (and free the copies when you
1122are done).
1123
1124=cut
1125*/
1126
8990e307 1127char *
864dbfa3 1128Perl_form(pTHX_ const char* pat, ...)
8990e307 1129{
c5be433b 1130 char *retval;
46fc3d4c 1131 va_list args;
7918f24d 1132 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1133 va_start(args, pat);
c5be433b 1134 retval = vform(pat, &args);
46fc3d4c 1135 va_end(args);
c5be433b
GS
1136 return retval;
1137}
1138
1139char *
1140Perl_vform(pTHX_ const char *pat, va_list *args)
1141{
2d03de9c 1142 SV * const sv = mess_alloc();
7918f24d 1143 PERL_ARGS_ASSERT_VFORM;
4608196e 1144 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1145 return SvPVX(sv);
46fc3d4c 1146}
a687059c 1147
c5df3096
Z
1148/*
1149=for apidoc Am|SV *|mess|const char *pat|...
1150
1151Take a sprintf-style format pattern and argument list. These are used to
1152generate a string message. If the message does not end with a newline,
1153then it will be extended with some indication of the current location
1154in the code, as described for L</mess_sv>.
1155
1156Normally, the resulting message is returned in a new mortal SV.
1157During global destruction a single SV may be shared between uses of
1158this function.
1159
1160=cut
1161*/
1162
5a844595
GS
1163#if defined(PERL_IMPLICIT_CONTEXT)
1164SV *
1165Perl_mess_nocontext(const char *pat, ...)
1166{
1167 dTHX;
1168 SV *retval;
1169 va_list args;
7918f24d 1170 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS
1171 va_start(args, pat);
1172 retval = vmess(pat, &args);
1173 va_end(args);
1174 return retval;
1175}
1176#endif /* PERL_IMPLICIT_CONTEXT */
1177
06bf62c7 1178SV *
5a844595
GS
1179Perl_mess(pTHX_ const char *pat, ...)
1180{
1181 SV *retval;
1182 va_list args;
7918f24d 1183 PERL_ARGS_ASSERT_MESS;
5a844595
GS
1184 va_start(args, pat);
1185 retval = vmess(pat, &args);
1186 va_end(args);
1187 return retval;
1188}
1189
5f66b61c
AL
1190STATIC const COP*
1191S_closest_cop(pTHX_ const COP *cop, const OP *o)
ae7d165c 1192{
97aff369 1193 dVAR;
ae7d165c
PJ
1194 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1195
7918f24d
NC
1196 PERL_ARGS_ASSERT_CLOSEST_COP;
1197
fabdb6c0
AL
1198 if (!o || o == PL_op)
1199 return cop;
ae7d165c
PJ
1200
1201 if (o->op_flags & OPf_KIDS) {
5f66b61c 1202 const OP *kid;
fabdb6c0 1203 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
5f66b61c 1204 const COP *new_cop;
ae7d165c
PJ
1205
1206 /* If the OP_NEXTSTATE has been optimised away we can still use it
1207 * the get the file and line number. */
1208
1209 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1210 cop = (const COP *)kid;
ae7d165c
PJ
1211
1212 /* Keep searching, and return when we've found something. */
1213
1214 new_cop = closest_cop(cop, kid);
fabdb6c0
AL
1215 if (new_cop)
1216 return new_cop;
ae7d165c
PJ
1217 }
1218 }
1219
1220 /* Nothing found. */
1221
5f66b61c 1222 return NULL;
ae7d165c
PJ
1223}
1224
c5df3096
Z
1225/*
1226=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1227
1228Expands a message, intended for the user, to include an indication of
1229the current location in the code, if the message does not already appear
1230to be complete.
1231
1232C<basemsg> is the initial message or object. If it is a reference, it
1233will be used as-is and will be the result of this function. Otherwise it
1234is used as a string, and if it already ends with a newline, it is taken
1235to be complete, and the result of this function will be the same string.
1236If the message does not end with a newline, then a segment such as C<at
1237foo.pl line 37> will be appended, and possibly other clauses indicating
1238the current state of execution. The resulting message will end with a
1239dot and a newline.
1240
1241Normally, the resulting message is returned in a new mortal SV.
1242During global destruction a single SV may be shared between uses of this
1243function. If C<consume> is true, then the function is permitted (but not
1244required) to modify and return C<basemsg> instead of allocating a new SV.
1245
1246=cut
1247*/
1248
5a844595 1249SV *
c5df3096 1250Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
46fc3d4c 1251{
97aff369 1252 dVAR;
c5df3096 1253 SV *sv;
46fc3d4c 1254
c5df3096
Z
1255 PERL_ARGS_ASSERT_MESS_SV;
1256
1257 if (SvROK(basemsg)) {
1258 if (consume) {
1259 sv = basemsg;
1260 }
1261 else {
1262 sv = mess_alloc();
1263 sv_setsv(sv, basemsg);
1264 }
1265 return sv;
1266 }
1267
1268 if (SvPOK(basemsg) && consume) {
1269 sv = basemsg;
1270 }
1271 else {
1272 sv = mess_alloc();
1273 sv_copypv(sv, basemsg);
1274 }
7918f24d 1275
46fc3d4c 1276 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ
1277 /*
1278 * Try and find the file and line for PL_op. This will usually be
1279 * PL_curcop, but it might be a cop that has been optimised away. We
1280 * can try to find such a cop by searching through the optree starting
1281 * from the sibling of PL_curcop.
1282 */
1283
e1ec3a88 1284 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
5f66b61c
AL
1285 if (!cop)
1286 cop = PL_curcop;
ae7d165c
PJ
1287
1288 if (CopLINE(cop))
ed094faf 1289 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1290 OutCopFILE(cop), (IV)CopLINE(cop));
191f87d5
DH
1291 /* Seems that GvIO() can be untrustworthy during global destruction. */
1292 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1293 && IoLINES(GvIOp(PL_last_in_gv)))
1294 {
e1ec3a88 1295 const bool line_mode = (RsSIMPLE(PL_rs) &&
95a20fc0 1296 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
57def98f 1297 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
5f66b61c 1298 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
edc2eac3
JH
1299 line_mode ? "line" : "chunk",
1300 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1301 }
5f66b61c
AL
1302 if (PL_dirty)
1303 sv_catpvs(sv, " during global destruction");
1304 sv_catpvs(sv, ".\n");
a687059c 1305 }
06bf62c7 1306 return sv;
a687059c
LW
1307}
1308
c5df3096
Z
1309/*
1310=for apidoc Am|SV *|vmess|const char *pat|va_list *args
1311
1312C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1313argument list. These are used to generate a string message. If the
1314message does not end with a newline, then it will be extended with
1315some indication of the current location in the code, as described for
1316L</mess_sv>.
1317
1318Normally, the resulting message is returned in a new mortal SV.
1319During global destruction a single SV may be shared between uses of
1320this function.
1321
1322=cut
1323*/
1324
1325SV *
1326Perl_vmess(pTHX_ const char *pat, va_list *args)
1327{
1328 dVAR;
1329 SV * const sv = mess_alloc();
1330
1331 PERL_ARGS_ASSERT_VMESS;
1332
1333 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1334 return mess_sv(sv, 1);
1335}
1336
7ff03255 1337void
7d0994e0 1338Perl_write_to_stderr(pTHX_ SV* msv)
7ff03255 1339{
27da23d5 1340 dVAR;
7ff03255
SG
1341 IO *io;
1342 MAGIC *mg;
1343
7918f24d
NC
1344 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1345
7ff03255
SG
1346 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1347 && (io = GvIO(PL_stderrgv))
daba3364 1348 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
7ff03255
SG
1349 {
1350 dSP;
1351 ENTER;
1352 SAVETMPS;
1353
1354 save_re_context();
1355 SAVESPTR(PL_stderrgv);
a0714e2c 1356 PL_stderrgv = NULL;
7ff03255
SG
1357
1358 PUSHSTACKi(PERLSI_MAGIC);
1359
1360 PUSHMARK(SP);
1361 EXTEND(SP,2);
daba3364 1362 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
7d0994e0 1363 PUSHs(msv);
7ff03255
SG
1364 PUTBACK;
1365 call_method("PRINT", G_SCALAR);
1366
1367 POPSTACK;
1368 FREETMPS;
1369 LEAVE;
1370 }
1371 else {
1372#ifdef USE_SFIO
1373 /* SFIO can really mess with your errno */
4ee39169 1374 dSAVED_ERRNO;
7ff03255 1375#endif
53c1dcc0 1376 PerlIO * const serr = Perl_error_log;
7d0994e0
GG
1377 STRLEN msglen;
1378 const char* message = SvPVx_const(msv, msglen);
7ff03255
SG
1379
1380 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1381 (void)PerlIO_flush(serr);
1382#ifdef USE_SFIO
4ee39169 1383 RESTORE_ERRNO;
7ff03255
SG
1384#endif
1385 }
1386}
1387
c5df3096
Z
1388/*
1389=head1 Warning and Dieing
1390*/
1391
1392/* Common code used in dieing and warning */
1393
1394STATIC SV *
1395S_with_queued_errors(pTHX_ SV *ex)
1396{
1397 PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1398 if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1399 sv_catsv(PL_errors, ex);
1400 ex = sv_mortalcopy(PL_errors);
1401 SvCUR_set(PL_errors, 0);
1402 }
1403 return ex;
1404}
3ab1ac99 1405
46d9c920 1406STATIC bool
c5df3096 1407S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
63315e18 1408{
97aff369 1409 dVAR;
63315e18
NC
1410 HV *stash;
1411 GV *gv;
1412 CV *cv;
46d9c920
NC
1413 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1414 /* sv_2cv might call Perl_croak() or Perl_warner() */
1415 SV * const oldhook = *hook;
1416
c5df3096
Z
1417 if (!oldhook)
1418 return FALSE;
63315e18 1419
63315e18 1420 ENTER;
46d9c920
NC
1421 SAVESPTR(*hook);
1422 *hook = NULL;
1423 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC
1424 LEAVE;
1425 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1426 dSP;
c5df3096 1427 SV *exarg;
63315e18
NC
1428
1429 ENTER;
1430 save_re_context();
46d9c920
NC
1431 if (warn) {
1432 SAVESPTR(*hook);
1433 *hook = NULL;
1434 }
c5df3096
Z
1435 exarg = newSVsv(ex);
1436 SvREADONLY_on(exarg);
1437 SAVEFREESV(exarg);
63315e18 1438
46d9c920 1439 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18 1440 PUSHMARK(SP);
c5df3096 1441 XPUSHs(exarg);
63315e18 1442 PUTBACK;
daba3364 1443 call_sv(MUTABLE_SV(cv), G_DISCARD);
63315e18
NC
1444 POPSTACK;
1445 LEAVE;
46d9c920 1446 return TRUE;
63315e18 1447 }
46d9c920 1448 return FALSE;
63315e18
NC
1449}
1450
c5df3096
Z
1451/*
1452=for apidoc Am|OP *|die_sv|SV *baseex
e07360fa 1453
c5df3096
Z
1454Behaves the same as L</croak_sv>, except for the return type.
1455It should be used only where the C<OP *> return type is required.
1456The function never actually returns.
e07360fa 1457
c5df3096
Z
1458=cut
1459*/
e07360fa 1460
c5df3096
Z
1461OP *
1462Perl_die_sv(pTHX_ SV *baseex)
36477c24 1463{
c5df3096
Z
1464 PERL_ARGS_ASSERT_DIE_SV;
1465 croak_sv(baseex);
ad09800f
GG
1466 /* NOTREACHED */
1467 return NULL;
36477c24
PP
1468}
1469
c5df3096
Z
1470/*
1471=for apidoc Am|OP *|die|const char *pat|...
1472
1473Behaves the same as L</croak>, except for the return type.
1474It should be used only where the C<OP *> return type is required.
1475The function never actually returns.
1476
1477=cut
1478*/
1479
c5be433b 1480#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1481OP *
1482Perl_die_nocontext(const char* pat, ...)
a687059c 1483{
cea2e8a9 1484 dTHX;
a687059c 1485 va_list args;
cea2e8a9 1486 va_start(args, pat);
c5df3096
Z
1487 vcroak(pat, &args);
1488 /* NOTREACHED */
cea2e8a9 1489 va_end(args);
c5df3096 1490 return NULL;
cea2e8a9 1491}
c5be433b 1492#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS
1493
1494OP *
1495Perl_die(pTHX_ const char* pat, ...)
1496{
cea2e8a9
GS
1497 va_list args;
1498 va_start(args, pat);
c5df3096
Z
1499 vcroak(pat, &args);
1500 /* NOTREACHED */
cea2e8a9 1501 va_end(args);
c5df3096 1502 return NULL;
cea2e8a9
GS
1503}
1504
c5df3096
Z
1505/*
1506=for apidoc Am|void|croak_sv|SV *baseex
1507
1508This is an XS interface to Perl's C<die> function.
1509
1510C<baseex> is the error message or object. If it is a reference, it
1511will be used as-is. Otherwise it is used as a string, and if it does
1512not end with a newline then it will be extended with some indication of
1513the current location in the code, as described for L</mess_sv>.
1514
1515The error message or object will be used as an exception, by default
1516returning control to the nearest enclosing C<eval>, but subject to
1517modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak_sv>
1518function never returns normally.
1519
1520To die with a simple string message, the L</croak> function may be
1521more convenient.
1522
1523=cut
1524*/
1525
c5be433b 1526void
c5df3096 1527Perl_croak_sv(pTHX_ SV *baseex)
cea2e8a9 1528{
c5df3096
Z
1529 SV *ex = with_queued_errors(mess_sv(baseex, 0));
1530 PERL_ARGS_ASSERT_CROAK_SV;
1531 invoke_exception_hook(ex, FALSE);
1532 die_unwind(ex);
1533}
1534
1535/*
1536=for apidoc Am|void|vcroak|const char *pat|va_list *args
1537
1538This is an XS interface to Perl's C<die> function.
1539
1540C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1541argument list. These are used to generate a string message. If the
1542message does not end with a newline, then it will be extended with
1543some indication of the current location in the code, as described for
1544L</mess_sv>.
1545
1546The error message will be used as an exception, by default
1547returning control to the nearest enclosing C<eval>, but subject to
1548modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1549function never returns normally.
a687059c 1550
c5df3096
Z
1551For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1552(C<$@>) will be used as an error message or object instead of building an
1553error message from arguments. If you want to throw a non-string object,
1554or build an error message in an SV yourself, it is preferable to use
1555the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
5a844595 1556
c5df3096
Z
1557=cut
1558*/
1559
1560void
1561Perl_vcroak(pTHX_ const char* pat, va_list *args)
1562{
1563 SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1564 invoke_exception_hook(ex, FALSE);
1565 die_unwind(ex);
a687059c
LW
1566}
1567
c5df3096
Z
1568/*
1569=for apidoc Am|void|croak|const char *pat|...
1570
1571This is an XS interface to Perl's C<die> function.
1572
1573Take a sprintf-style format pattern and argument list. These are used to
1574generate a string message. If the message does not end with a newline,
1575then it will be extended with some indication of the current location
1576in the code, as described for L</mess_sv>.
1577
1578The error message will be used as an exception, by default
1579returning control to the nearest enclosing C<eval>, but subject to
1580modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
1581function never returns normally.
1582
1583For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1584(C<$@>) will be used as an error message or object instead of building an
1585error message from arguments. If you want to throw a non-string object,
1586or build an error message in an SV yourself, it is preferable to use
1587the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1588
1589=cut
1590*/
1591
c5be433b 1592#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1593void
cea2e8a9 1594Perl_croak_nocontext(const char *pat, ...)
a687059c 1595{
cea2e8a9 1596 dTHX;
a687059c 1597 va_list args;
cea2e8a9 1598 va_start(args, pat);
c5be433b 1599 vcroak(pat, &args);
cea2e8a9
GS
1600 /* NOTREACHED */
1601 va_end(args);
1602}
1603#endif /* PERL_IMPLICIT_CONTEXT */
1604
c5df3096
Z
1605void
1606Perl_croak(pTHX_ const char *pat, ...)
1607{
1608 va_list args;
1609 va_start(args, pat);
1610 vcroak(pat, &args);
1611 /* NOTREACHED */
1612 va_end(args);
1613}
1614
954c1994 1615/*
c5df3096 1616=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1617
c5df3096 1618This is an XS interface to Perl's C<warn> function.
954c1994 1619
c5df3096
Z
1620C<baseex> is the error message or object. If it is a reference, it
1621will be used as-is. Otherwise it is used as a string, and if it does
1622not end with a newline then it will be extended with some indication of
1623the current location in the code, as described for L</mess_sv>.
9983fa3c 1624
c5df3096
Z
1625The error message or object will by default be written to standard error,
1626but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1627
c5df3096
Z
1628To warn with a simple string message, the L</warn> function may be
1629more convenient.
954c1994
GS
1630
1631=cut
1632*/
1633
cea2e8a9 1634void
c5df3096 1635Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1636{
c5df3096
Z
1637 SV *ex = mess_sv(baseex, 0);
1638 PERL_ARGS_ASSERT_WARN_SV;
1639 if (!invoke_exception_hook(ex, TRUE))
1640 write_to_stderr(ex);
cea2e8a9
GS
1641}
1642
c5df3096
Z
1643/*
1644=for apidoc Am|void|vwarn|const char *pat|va_list *args
1645
1646This is an XS interface to Perl's C<warn> function.
1647
1648C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1649argument list. These are used to generate a string message. If the
1650message does not end with a newline, then it will be extended with
1651some indication of the current location in the code, as described for
1652L</mess_sv>.
1653
1654The error message or object will by default be written to standard error,
1655but this is subject to modification by a C<$SIG{__WARN__}> handler.
1656
1657Unlike with L</vcroak>, C<pat> is not permitted to be null.
1658
1659=cut
1660*/
1661
c5be433b
GS
1662void
1663Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1664{
c5df3096 1665 SV *ex = vmess(pat, args);
7918f24d 1666 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
1667 if (!invoke_exception_hook(ex, TRUE))
1668 write_to_stderr(ex);
1669}
7918f24d 1670
c5df3096
Z
1671/*
1672=for apidoc Am|void|warn|const char *pat|...
87582a92 1673
c5df3096
Z
1674This is an XS interface to Perl's C<warn> function.
1675
1676Take a sprintf-style format pattern and argument list. These are used to
1677generate a string message. If the message does not end with a newline,
1678then it will be extended with some indication of the current location
1679in the code, as described for L</mess_sv>.
1680
1681The error message or object will by default be written to standard error,
1682but this is subject to modification by a C<$SIG{__WARN__}> handler.
1683
1684Unlike with L</croak>, C<pat> is not permitted to be null.
1685
1686=cut
1687*/
8d063cd8 1688
c5be433b 1689#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1690void
1691Perl_warn_nocontext(const char *pat, ...)
1692{
1693 dTHX;
1694 va_list args;
7918f24d 1695 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1696 va_start(args, pat);
c5be433b 1697 vwarn(pat, &args);
cea2e8a9
GS
1698 va_end(args);
1699}
1700#endif /* PERL_IMPLICIT_CONTEXT */
1701
1702void
1703Perl_warn(pTHX_ const char *pat, ...)
1704{
1705 va_list args;
7918f24d 1706 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1707 va_start(args, pat);
c5be433b 1708 vwarn(pat, &args);
cea2e8a9
GS
1709 va_end(args);
1710}
1711
c5be433b
GS
1712#if defined(PERL_IMPLICIT_CONTEXT)
1713void
1714Perl_warner_nocontext(U32 err, const char *pat, ...)
1715{
27da23d5 1716 dTHX;
c5be433b 1717 va_list args;
7918f24d 1718 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
1719 va_start(args, pat);
1720 vwarner(err, pat, &args);
1721 va_end(args);
1722}
1723#endif /* PERL_IMPLICIT_CONTEXT */
1724
599cee73 1725void
9b387841
NC
1726Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1727{
1728 PERL_ARGS_ASSERT_CK_WARNER_D;
1729
1730 if (Perl_ckwarn_d(aTHX_ err)) {
1731 va_list args;
1732 va_start(args, pat);
1733 vwarner(err, pat, &args);
1734 va_end(args);
1735 }
1736}
1737
1738void
a2a5de95
NC
1739Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1740{
1741 PERL_ARGS_ASSERT_CK_WARNER;
1742
1743 if (Perl_ckwarn(aTHX_ err)) {
1744 va_list args;
1745 va_start(args, pat);
1746 vwarner(err, pat, &args);
1747 va_end(args);
1748 }
1749}
1750
1751void
864dbfa3 1752Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
1753{
1754 va_list args;
7918f24d 1755 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
1756 va_start(args, pat);
1757 vwarner(err, pat, &args);
1758 va_end(args);
1759}
1760
1761void
1762Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1763{
27da23d5 1764 dVAR;
7918f24d 1765 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1766 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1767 SV * const msv = vmess(pat, args);
599cee73 1768
c5df3096
Z
1769 invoke_exception_hook(msv, FALSE);
1770 die_unwind(msv);
599cee73
PM
1771 }
1772 else {
d13b0d77 1773 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
1774 }
1775}
1776
f54ba1c2
DM
1777/* implements the ckWARN? macros */
1778
1779bool
1780Perl_ckwarn(pTHX_ U32 w)
1781{
97aff369 1782 dVAR;
ad287e37
NC
1783 /* If lexical warnings have not been set, use $^W. */
1784 if (isLEXWARN_off)
1785 return PL_dowarn & G_WARN_ON;
1786
26c7b074 1787 return ckwarn_common(w);
f54ba1c2
DM
1788}
1789
1790/* implements the ckWARN?_d macro */
1791
1792bool
1793Perl_ckwarn_d(pTHX_ U32 w)
1794{
97aff369 1795 dVAR;
ad287e37
NC
1796 /* If lexical warnings have not been set then default classes warn. */
1797 if (isLEXWARN_off)
1798 return TRUE;
1799
26c7b074
NC
1800 return ckwarn_common(w);
1801}
1802
1803static bool
1804S_ckwarn_common(pTHX_ U32 w)
1805{
ad287e37
NC
1806 if (PL_curcop->cop_warnings == pWARN_ALL)
1807 return TRUE;
1808
1809 if (PL_curcop->cop_warnings == pWARN_NONE)
1810 return FALSE;
1811
98fe6610
NC
1812 /* Check the assumption that at least the first slot is non-zero. */
1813 assert(unpackWARN1(w));
1814
1815 /* Check the assumption that it is valid to stop as soon as a zero slot is
1816 seen. */
1817 if (!unpackWARN2(w)) {
1818 assert(!unpackWARN3(w));
1819 assert(!unpackWARN4(w));
1820 } else if (!unpackWARN3(w)) {
1821 assert(!unpackWARN4(w));
1822 }
1823
26c7b074
NC
1824 /* Right, dealt with all the special cases, which are implemented as non-
1825 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
1826 do {
1827 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1828 return TRUE;
1829 } while (w >>= WARNshift);
1830
1831 return FALSE;
f54ba1c2
DM
1832}
1833
72dc9ed5
NC
1834/* Set buffer=NULL to get a new one. */
1835STRLEN *
8ee4cf24 1836Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5
NC
1837 STRLEN size) {
1838 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
35da51f7 1839 PERL_UNUSED_CONTEXT;
7918f24d 1840 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 1841
10edeb5d
JH
1842 buffer = (STRLEN*)
1843 (specialWARN(buffer) ?
1844 PerlMemShared_malloc(len_wanted) :
1845 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
1846 buffer[0] = size;
1847 Copy(bits, (buffer + 1), size, char);
1848 return buffer;
1849}
f54ba1c2 1850
e6587932
DM
1851/* since we've already done strlen() for both nam and val
1852 * we can use that info to make things faster than
1853 * sprintf(s, "%s=%s", nam, val)
1854 */
1855#define my_setenv_format(s, nam, nlen, val, vlen) \
1856 Copy(nam, s, nlen, char); \
1857 *(s+nlen) = '='; \
1858 Copy(val, s+(nlen+1), vlen, char); \
1859 *(s+(nlen+1+vlen)) = '\0'
1860
c5d12488
JH
1861#ifdef USE_ENVIRON_ARRAY
1862 /* VMS' my_setenv() is in vms.c */
1863#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1864void
e1ec3a88 1865Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1866{
27da23d5 1867 dVAR;
4efc5df6
GS
1868#ifdef USE_ITHREADS
1869 /* only parent thread can modify process environment */
1870 if (PL_curinterp == aTHX)
1871#endif
1872 {
f2517201 1873#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1874 if (!PL_use_safe_putenv) {
c5d12488 1875 /* most putenv()s leak, so we manipulate environ directly */
3a9222be
JH
1876 register I32 i;
1877 register const I32 len = strlen(nam);
c5d12488
JH
1878 int nlen, vlen;
1879
3a9222be
JH
1880 /* where does it go? */
1881 for (i = 0; environ[i]; i++) {
1882 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1883 break;
1884 }
1885
c5d12488
JH
1886 if (environ == PL_origenviron) { /* need we copy environment? */
1887 I32 j;
1888 I32 max;
1889 char **tmpenv;
1890
1891 max = i;
1892 while (environ[max])
1893 max++;
1894 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1895 for (j=0; j<max; j++) { /* copy environment */
1896 const int len = strlen(environ[j]);
1897 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1898 Copy(environ[j], tmpenv[j], len+1, char);
1899 }
1900 tmpenv[max] = NULL;
1901 environ = tmpenv; /* tell exec where it is now */
1902 }
1903 if (!val) {
1904 safesysfree(environ[i]);
1905 while (environ[i]) {
1906 environ[i] = environ[i+1];
1907 i++;
a687059c 1908 }
c5d12488
JH
1909 return;
1910 }
1911 if (!environ[i]) { /* does not exist yet */
1912 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1913 environ[i+1] = NULL; /* make sure it's null terminated */
1914 }
1915 else
1916 safesysfree(environ[i]);
1917 nlen = strlen(nam);
1918 vlen = strlen(val);
1919
1920 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1921 /* all that work just for this */
1922 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1923 } else {
c5d12488 1924# endif
7ee146b1 1925# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB
1926# if defined(HAS_UNSETENV)
1927 if (val == NULL) {
1928 (void)unsetenv(nam);
1929 } else {
1930 (void)setenv(nam, val, 1);
1931 }
1932# else /* ! HAS_UNSETENV */
1933 (void)setenv(nam, val, 1);
1934# endif /* HAS_UNSETENV */
47dafe4d 1935# else
88f5bc07
AB
1936# if defined(HAS_UNSETENV)
1937 if (val == NULL) {
1938 (void)unsetenv(nam);
1939 } else {
c4420975
AL
1940 const int nlen = strlen(nam);
1941 const int vlen = strlen(val);
1942 char * const new_env =
88f5bc07
AB
1943 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1944 my_setenv_format(new_env, nam, nlen, val, vlen);
1945 (void)putenv(new_env);
1946 }
1947# else /* ! HAS_UNSETENV */
1948 char *new_env;
c4420975
AL
1949 const int nlen = strlen(nam);
1950 int vlen;
88f5bc07
AB
1951 if (!val) {
1952 val = "";
1953 }
1954 vlen = strlen(val);
1955 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1956 /* all that work just for this */
1957 my_setenv_format(new_env, nam, nlen, val, vlen);
1958 (void)putenv(new_env);
1959# endif /* HAS_UNSETENV */
47dafe4d 1960# endif /* __CYGWIN__ */
50acdf95
MS
1961#ifndef PERL_USE_SAFE_PUTENV
1962 }
1963#endif
4efc5df6 1964 }
8d063cd8
LW
1965}
1966
c5d12488 1967#else /* WIN32 || NETWARE */
68dc0745
PP
1968
1969void
72229eff 1970Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1971{
27da23d5 1972 dVAR;
c5d12488
JH
1973 register char *envstr;
1974 const int nlen = strlen(nam);
1975 int vlen;
e6587932 1976
c5d12488
JH
1977 if (!val) {
1978 val = "";
ac5c734f 1979 }
c5d12488
JH
1980 vlen = strlen(val);
1981 Newx(envstr, nlen+vlen+2, char);
1982 my_setenv_format(envstr, nam, nlen, val, vlen);
1983 (void)PerlEnv_putenv(envstr);
1984 Safefree(envstr);
3e3baf6d
TB
1985}
1986
c5d12488 1987#endif /* WIN32 || NETWARE */
3e3baf6d 1988
c5d12488 1989#endif /* !VMS && !EPOC*/
378cc40b 1990
16d20bd9 1991#ifdef UNLINK_ALL_VERSIONS
79072805 1992I32
6e732051 1993Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 1994{
35da51f7 1995 I32 retries = 0;
378cc40b 1996
7918f24d
NC
1997 PERL_ARGS_ASSERT_UNLNK;
1998
35da51f7
AL
1999 while (PerlLIO_unlink(f) >= 0)
2000 retries++;
2001 return retries ? 0 : -1;
378cc40b
LW
2002}
2003#endif
2004
7a3f2258 2005/* this is a drop-in replacement for bcopy() */
2253333f 2006#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 2007char *
7a3f2258 2008Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b 2009{
2d03de9c 2010 char * const retval = to;
378cc40b 2011
7918f24d
NC
2012 PERL_ARGS_ASSERT_MY_BCOPY;
2013
7c0587c8
LW
2014 if (from - to >= 0) {
2015 while (len--)
2016 *to++ = *from++;
2017 }
2018 else {
2019 to += len;
2020 from += len;
2021 while (len--)
faf8582f 2022 *(--to) = *(--from);
7c0587c8 2023 }
378cc40b
LW
2024 return retval;
2025}
ffed7fef 2026#endif
378cc40b 2027
7a3f2258 2028/* this is a drop-in replacement for memset() */
fc36a67e
PP
2029#ifndef HAS_MEMSET
2030void *
7a3f2258 2031Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 2032{
2d03de9c 2033 char * const retval = loc;
fc36a67e 2034
7918f24d
NC
2035 PERL_ARGS_ASSERT_MY_MEMSET;
2036
fc36a67e
PP
2037 while (len--)
2038 *loc++ = ch;
2039 return retval;
2040}
2041#endif
2042
7a3f2258 2043/* this is a drop-in replacement for bzero() */
7c0587c8 2044#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2045char *
7a3f2258 2046Perl_my_bzero(register char *loc, register I32 len)
378cc40b 2047{
2d03de9c 2048 char * const retval = loc;
378cc40b 2049
7918f24d
NC
2050 PERL_ARGS_ASSERT_MY_BZERO;
2051
378cc40b
LW
2052 while (len--)
2053 *loc++ = 0;
2054 return retval;
2055}
2056#endif
7c0587c8 2057
7a3f2258 2058/* this is a drop-in replacement for memcmp() */
36477c24 2059#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2060I32
7a3f2258 2061Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 2062{
e1ec3a88
AL
2063 register const U8 *a = (const U8 *)s1;
2064 register const U8 *b = (const U8 *)s2;
79072805 2065 register I32 tmp;
7c0587c8 2066
7918f24d
NC
2067 PERL_ARGS_ASSERT_MY_MEMCMP;
2068
7c0587c8 2069 while (len--) {
27da23d5 2070 if ((tmp = *a++ - *b++))
7c0587c8
LW
2071 return tmp;
2072 }
2073 return 0;
2074}
36477c24 2075#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2076
fe14fcc3 2077#ifndef HAS_VPRINTF
d05d9be5
AD
2078/* This vsprintf replacement should generally never get used, since
2079 vsprintf was available in both System V and BSD 2.11. (There may
2080 be some cross-compilation or embedded set-ups where it is needed,
2081 however.)
2082
2083 If you encounter a problem in this function, it's probably a symptom
2084 that Configure failed to detect your system's vprintf() function.
2085 See the section on "item vsprintf" in the INSTALL file.
2086
2087 This version may compile on systems with BSD-ish <stdio.h>,
2088 but probably won't on others.
2089*/
a687059c 2090
85e6fe83 2091#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2092char *
2093#else
2094int
2095#endif
d05d9be5 2096vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2097{
2098 FILE fakebuf;
2099
d05d9be5
AD
2100#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2101 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2102 FILE_cnt(&fakebuf) = 32767;
2103#else
2104 /* These probably won't compile -- If you really need
2105 this, you'll have to figure out some other method. */
a687059c
LW
2106 fakebuf._ptr = dest;
2107 fakebuf._cnt = 32767;
d05d9be5 2108#endif
35c8bce7
LW
2109#ifndef _IOSTRG
2110#define _IOSTRG 0
2111#endif
a687059c
LW
2112 fakebuf._flag = _IOWRT|_IOSTRG;
2113 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2114#if defined(STDIO_PTR_LVALUE)
2115 *(FILE_ptr(&fakebuf)++) = '\0';
2116#else
2117 /* PerlIO has probably #defined away fputc, but we want it here. */
2118# ifdef fputc
2119# undef fputc /* XXX Should really restore it later */
2120# endif
2121 (void)fputc('\0', &fakebuf);
2122#endif
85e6fe83 2123#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2124 return(dest);
2125#else
2126 return 0; /* perl doesn't use return value */
2127#endif
2128}
2129
fe14fcc3 2130#endif /* HAS_VPRINTF */
a687059c
LW
2131
2132#ifdef MYSWAP
ffed7fef 2133#if BYTEORDER != 0x4321
a687059c 2134short
864dbfa3 2135Perl_my_swap(pTHX_ short s)
a687059c
LW
2136{
2137#if (BYTEORDER & 1) == 0
2138 short result;
2139
2140 result = ((s & 255) << 8) + ((s >> 8) & 255);
2141 return result;
2142#else
2143 return s;
2144#endif
2145}
2146
2147long
864dbfa3 2148Perl_my_htonl(pTHX_ long l)
a687059c
LW
2149{
2150 union {
2151 long result;
ffed7fef 2152 char c[sizeof(long)];
a687059c
LW
2153 } u;
2154
cef6ea9d
JH
2155#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2156#if BYTEORDER == 0x12345678
2157 u.result = 0;
2158#endif
a687059c
LW
2159 u.c[0] = (l >> 24) & 255;
2160 u.c[1] = (l >> 16) & 255;
2161 u.c[2] = (l >> 8) & 255;
2162 u.c[3] = l & 255;
2163 return u.result;
2164#else
ffed7fef 2165#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2166 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2167#else
79072805
LW
2168 register I32 o;
2169 register I32 s;
a687059c 2170
ffed7fef
LW
2171 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2172 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW
2173 }
2174 return u.result;
2175#endif
2176#endif
2177}
2178
2179long
864dbfa3 2180Perl_my_ntohl(pTHX_ long l)
a687059c
LW
2181{
2182 union {
2183 long l;
ffed7fef 2184 char c[sizeof(long)];
a687059c
LW
2185 } u;
2186
ffed7fef 2187#if BYTEORDER == 0x1234
a687059c
LW
2188 u.c[0] = (l >> 24) & 255;
2189 u.c[1] = (l >> 16) & 255;
2190 u.c[2] = (l >> 8) & 255;
2191 u.c[3] = l & 255;
2192 return u.l;
2193#else
ffed7fef 2194#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2195 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2196#else
79072805
LW
2197 register I32 o;
2198 register I32 s;
a687059c
LW
2199
2200 u.l = l;
2201 l = 0;
ffed7fef
LW
2202 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2203 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW
2204 }
2205 return l;
2206#endif
2207#endif
2208}
2209
ffed7fef 2210#endif /* BYTEORDER != 0x4321 */
988174c1
LW
2211#endif /* MYSWAP */
2212
2213/*
2214 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2215 * If these functions are defined,
2216 * the BYTEORDER is neither 0x1234 nor 0x4321.
2217 * However, this is not assumed.
2218 * -DWS
2219 */
2220
1109a392 2221#define HTOLE(name,type) \
988174c1 2222 type \
ba106d47 2223 name (register type n) \
988174c1
LW
2224 { \
2225 union { \
2226 type value; \
2227 char c[sizeof(type)]; \
2228 } u; \
bb7a0f54
MHM
2229 register U32 i; \
2230 register U32 s = 0; \
1109a392 2231 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW
2232 u.c[i] = (n >> s) & 0xFF; \
2233 } \
2234 return u.value; \
2235 }
2236
1109a392 2237#define LETOH(name,type) \
988174c1 2238 type \
ba106d47 2239 name (register type n) \
988174c1
LW
2240 { \
2241 union { \
2242 type value; \
2243 char c[sizeof(type)]; \
2244 } u; \
bb7a0f54
MHM
2245 register U32 i; \
2246 register U32 s = 0; \
988174c1
LW
2247 u.value = n; \
2248 n = 0; \
1109a392
MHM
2249 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2250 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW
2251 } \
2252 return n; \
2253 }
2254
1109a392
MHM
2255/*
2256 * Big-endian byte order functions.
2257 */
2258
2259#define HTOBE(name,type) \
2260 type \
2261 name (register type n) \
2262 { \
2263 union { \
2264 type value; \
2265 char c[sizeof(type)]; \
2266 } u; \
bb7a0f54
MHM
2267 register U32 i; \
2268 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM
2269 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2270 u.c[i] = (n >> s) & 0xFF; \
2271 } \
2272 return u.value; \
2273 }
2274
2275#define BETOH(name,type) \
2276 type \
2277 name (register type n) \
2278 { \
2279 union { \
2280 type value; \
2281 char c[sizeof(type)]; \
2282 } u; \
bb7a0f54
MHM
2283 register U32 i; \
2284 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM
2285 u.value = n; \
2286 n = 0; \
2287 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2288 n |= ((type)(u.c[i] & 0xFF)) << s; \
2289 } \
2290 return n; \
2291 }
2292
2293/*
2294 * If we just can't do it...
2295 */
2296
2297#define NOT_AVAIL(name,type) \
2298 type \
2299 name (register type n) \
2300 { \
2301 Perl_croak_nocontext(#name "() not available"); \
2302 return n; /* not reached */ \
2303 }
2304
2305
988174c1 2306#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 2307HTOLE(htovs,short)
988174c1
LW
2308#endif
2309#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 2310HTOLE(htovl,long)
988174c1
LW
2311#endif
2312#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 2313LETOH(vtohs,short)
988174c1
LW
2314#endif
2315#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM
2316LETOH(vtohl,long)
2317#endif
2318
2319#ifdef PERL_NEED_MY_HTOLE16
2320# if U16SIZE == 2
2321HTOLE(Perl_my_htole16,U16)
2322# else
2323NOT_AVAIL(Perl_my_htole16,U16)
2324# endif
2325#endif
2326#ifdef PERL_NEED_MY_LETOH16
2327# if U16SIZE == 2
2328LETOH(Perl_my_letoh16,U16)
2329# else
2330NOT_AVAIL(Perl_my_letoh16,U16)
2331# endif
2332#endif
2333#ifdef PERL_NEED_MY_HTOBE16
2334# if U16SIZE == 2
2335HTOBE(Perl_my_htobe16,U16)
2336# else
2337NOT_AVAIL(Perl_my_htobe16,U16)
2338# endif
2339#endif
2340#ifdef PERL_NEED_MY_BETOH16
2341# if U16SIZE == 2
2342BETOH(Perl_my_betoh16,U16)
2343# else
2344NOT_AVAIL(Perl_my_betoh16,U16)
2345# endif
2346#endif
2347
2348#ifdef PERL_NEED_MY_HTOLE32
2349# if U32SIZE == 4
2350HTOLE(Perl_my_htole32,U32)
2351# else
2352NOT_AVAIL(Perl_my_htole32,U32)
2353# endif
2354#endif
2355#ifdef PERL_NEED_MY_LETOH32
2356# if U32SIZE == 4
2357LETOH(Perl_my_letoh32,U32)
2358# else
2359NOT_AVAIL(Perl_my_letoh32,U32)
2360# endif
2361#endif
2362#ifdef PERL_NEED_MY_HTOBE32
2363# if U32SIZE == 4
2364HTOBE(Perl_my_htobe32,U32)
2365# else
2366NOT_AVAIL(Perl_my_htobe32,U32)
2367# endif
2368#endif
2369#ifdef PERL_NEED_MY_BETOH32
2370# if U32SIZE == 4
2371BETOH(Perl_my_betoh32,U32)
2372# else
2373NOT_AVAIL(Perl_my_betoh32,U32)
2374# endif
2375#endif
2376
2377#ifdef PERL_NEED_MY_HTOLE64
2378# if U64SIZE == 8
2379HTOLE(Perl_my_htole64,U64)
2380# else
2381NOT_AVAIL(Perl_my_htole64,U64)
2382# endif
2383#endif
2384#ifdef PERL_NEED_MY_LETOH64
2385# if U64SIZE == 8
2386LETOH(Perl_my_letoh64,U64)
2387# else
2388NOT_AVAIL(Perl_my_letoh64,U64)
2389# endif
2390#endif
2391#ifdef PERL_NEED_MY_HTOBE64
2392# if U64SIZE == 8
2393HTOBE(Perl_my_htobe64,U64)
2394# else
2395NOT_AVAIL(Perl_my_htobe64,U64)
2396# endif
2397#endif
2398#ifdef PERL_NEED_MY_BETOH64
2399# if U64SIZE == 8
2400BETOH(Perl_my_betoh64,U64)
2401# else
2402NOT_AVAIL(Perl_my_betoh64,U64)
2403# endif
988174c1 2404#endif
a687059c 2405
1109a392
MHM
2406#ifdef PERL_NEED_MY_HTOLES
2407HTOLE(Perl_my_htoles,short)
2408#endif
2409#ifdef PERL_NEED_MY_LETOHS
2410LETOH(Perl_my_letohs,short)
2411#endif
2412#ifdef PERL_NEED_MY_HTOBES
2413HTOBE(Perl_my_htobes,short)
2414#endif
2415#ifdef PERL_NEED_MY_BETOHS
2416BETOH(Perl_my_betohs,short)
2417#endif
2418
2419#ifdef PERL_NEED_MY_HTOLEI
2420HTOLE(Perl_my_htolei,int)
2421#endif
2422#ifdef PERL_NEED_MY_LETOHI
2423LETOH(Perl_my_letohi,int)
2424#endif
2425#ifdef PERL_NEED_MY_HTOBEI
2426HTOBE(Perl_my_htobei,int)
2427#endif
2428#ifdef PERL_NEED_MY_BETOHI
2429BETOH(Perl_my_betohi,int)
2430#endif
2431
2432#ifdef PERL_NEED_MY_HTOLEL
2433HTOLE(Perl_my_htolel,long)
2434#endif
2435#ifdef PERL_NEED_MY_LETOHL
2436LETOH(Perl_my_letohl,long)
2437#endif
2438#ifdef PERL_NEED_MY_HTOBEL
2439HTOBE(Perl_my_htobel,long)
2440#endif
2441#ifdef PERL_NEED_MY_BETOHL
2442BETOH(Perl_my_betohl,long)
2443#endif
2444
2445void
2446Perl_my_swabn(void *ptr, int n)
2447{
2448 register char *s = (char *)ptr;
2449 register char *e = s + (n-1);
2450 register char tc;
2451
7918f24d
NC
2452 PERL_ARGS_ASSERT_MY_SWABN;
2453
1109a392
MHM
2454 for (n /= 2; n > 0; s++, e--, n--) {
2455 tc = *s;
2456 *s = *e;
2457 *e = tc;
2458 }
2459}
2460
4a7d1889 2461PerlIO *
c9289b7b 2462Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2463{
e37778c2 2464#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
97aff369 2465 dVAR;
1f852d0d
NIS
2466 int p[2];
2467 register I32 This, that;
2468 register Pid_t pid;
2469 SV *sv;
2470 I32 did_pipes = 0;
2471 int pp[2];
2472
7918f24d
NC
2473 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2474
1f852d0d
NIS
2475 PERL_FLUSHALL_FOR_CHILD;
2476 This = (*mode == 'w');
2477 that = !This;
2478 if (PL_tainting) {
2479 taint_env();
2480 taint_proper("Insecure %s%s", "EXEC");
2481 }
2482 if (PerlProc_pipe(p) < 0)
4608196e 2483 return NULL;
1f852d0d
NIS
2484 /* Try for another pipe pair for error return */
2485 if (PerlProc_pipe(pp) >= 0)
2486 did_pipes = 1;
52e18b1f 2487 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2488 if (errno != EAGAIN) {
2489 PerlLIO_close(p[This]);
4e6dfe71 2490 PerlLIO_close(p[that]);
1f852d0d
NIS
2491 if (did_pipes) {
2492 PerlLIO_close(pp[0]);
2493 PerlLIO_close(pp[1]);
2494 }
4608196e 2495 return NULL;
1f852d0d 2496 }
a2a5de95 2497 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2498 sleep(5);
2499 }
2500 if (pid == 0) {
2501 /* Child */
1f852d0d
NIS
2502#undef THIS
2503#undef THAT
2504#define THIS that
2505#define THAT This
1f852d0d
NIS
2506 /* Close parent's end of error status pipe (if any) */
2507 if (did_pipes) {
2508 PerlLIO_close(pp[0]);
2509#if defined(HAS_FCNTL) && defined(F_SETFD)
2510 /* Close error pipe automatically if exec works */
2511 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2512#endif
2513 }
2514 /* Now dup our end of _the_ pipe to right position */
2515 if (p[THIS] != (*mode == 'r')) {
2516 PerlLIO_dup2(p[THIS], *mode == 'r');
2517 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2518 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2519 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2520 }
4e6dfe71
GS
2521 else
2522 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2523#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2524 /* No automatic close - do it by hand */
b7953727
JH
2525# ifndef NOFILE
2526# define NOFILE 20
2527# endif
a080fe3d
NIS
2528 {
2529 int fd;
2530
2531 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2532 if (fd != pp[1])
a080fe3d
NIS
2533 PerlLIO_close(fd);
2534 }
1f852d0d
NIS
2535 }
2536#endif
a0714e2c 2537 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2538 PerlProc__exit(1);
2539#undef THIS
2540#undef THAT
2541 }
2542 /* Parent */
52e18b1f 2543 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2544 if (did_pipes)
2545 PerlLIO_close(pp[1]);
2546 /* Keep the lower of the two fd numbers */
2547 if (p[that] < p[This]) {
2548 PerlLIO_dup2(p[This], p[that]);
2549 PerlLIO_close(p[This]);
2550 p[This] = p[that];
2551 }
4e6dfe71
GS
2552 else
2553 PerlLIO_close(p[that]); /* close child's end of pipe */
2554
1f852d0d 2555 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2556 SvUPGRADE(sv,SVt_IV);
45977657 2557 SvIV_set(sv, pid);
1f852d0d
NIS
2558 PL_forkprocess = pid;
2559 /* If we managed to get status pipe check for exec fail */
2560 if (did_pipes && pid > 0) {
2561 int errkid;
bb7a0f54
MHM
2562 unsigned n = 0;
2563 SSize_t n1;
1f852d0d
NIS
2564
2565 while (n < sizeof(int)) {
2566 n1 = PerlLIO_read(pp[0],
2567 (void*)(((char*)&errkid)+n),
2568 (sizeof(int)) - n);
2569 if (n1 <= 0)
2570 break;
2571 n += n1;
2572 }
2573 PerlLIO_close(pp[0]);
2574 did_pipes = 0;
2575 if (n) { /* Error */
2576 int pid2, status;
8c51524e 2577 PerlLIO_close(p[This]);
1f852d0d
NIS
2578 if (n != sizeof(int))
2579 Perl_croak(aTHX_ "panic: kid popen errno read");
2580 do {
2581 pid2 = wait4pid(pid, &status, 0);
2582 } while (pid2 == -1 && errno == EINTR);
2583 errno = errkid; /* Propagate errno from kid */
4608196e 2584 return NULL;
1f852d0d
NIS
2585 }
2586 }
2587 if (did_pipes)
2588 PerlLIO_close(pp[0]);
2589 return PerlIO_fdopen(p[This], mode);
2590#else
9d419b5f 2591# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2592 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2593# else
4a7d1889
NIS
2594 Perl_croak(aTHX_ "List form of piped open not implemented");
2595 return (PerlIO *) NULL;
9d419b5f 2596# endif
1f852d0d 2597#endif
4a7d1889
NIS
2598}
2599
5f05dabc 2600 /* VMS' my_popen() is in VMS.c, same with OS/2. */
e37778c2 2601#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
760ac839 2602PerlIO *
3dd43144 2603Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2604{
97aff369 2605 dVAR;
a687059c 2606 int p[2];
8ac85365 2607 register I32 This, that;
d8a83dd3 2608 register Pid_t pid;
79072805 2609 SV *sv;
bfce84ec 2610 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2611 I32 did_pipes = 0;
2612 int pp[2];
a687059c 2613
7918f24d
NC
2614 PERL_ARGS_ASSERT_MY_POPEN;
2615
45bc9206 2616 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2617#ifdef OS2
2618 if (doexec) {
23da6c43 2619 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2620 }
a1d180c4 2621#endif
8ac85365
NIS
2622 This = (*mode == 'w');
2623 that = !This;
3280af22 2624 if (doexec && PL_tainting) {
bbce6d69
PP
2625 taint_env();
2626 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2627 }
c2267164 2628 if (PerlProc_pipe(p) < 0)
4608196e 2629 return NULL;
e446cec8
IZ
2630 if (doexec && PerlProc_pipe(pp) >= 0)
2631 did_pipes = 1;
52e18b1f 2632 while ((pid = PerlProc_fork()) < 0) {
a687059c 2633 if (errno != EAGAIN) {
6ad3d225 2634 PerlLIO_close(p[This]);
b5ac89c3 2635 PerlLIO_close(p[that]);
e446cec8
IZ
2636 if (did_pipes) {
2637 PerlLIO_close(pp[0]);
2638 PerlLIO_close(pp[1]);
2639 }
a687059c 2640 if (!doexec)
b3647a36 2641 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2642 return NULL;
a687059c 2643 }
a2a5de95 2644 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2645 sleep(5);
2646 }
2647 if (pid == 0) {
79072805
LW
2648 GV* tmpgv;
2649
30ac6d9b
GS
2650#undef THIS
2651#undef THAT
a687059c 2652#define THIS that
8ac85365 2653#define THAT This
e446cec8
IZ
2654 if (did_pipes) {
2655 PerlLIO_close(pp[0]);
2656#if defined(HAS_FCNTL) && defined(F_SETFD)
2657 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2658#endif
2659 }
a687059c 2660 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2661 PerlLIO_dup2(p[THIS], *mode == 'r');
2662 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2663 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2664 PerlLIO_close(p[THAT]);
a687059c 2665 }
b5ac89c3
NIS
2666 else
2667 PerlLIO_close(p[THAT]);
4435c477 2668#ifndef OS2
a687059c 2669 if (doexec) {
a0d0e21e 2670#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2671#ifndef NOFILE
2672#define NOFILE 20
2673#endif
a080fe3d 2674 {
3aed30dc 2675 int fd;
a080fe3d
NIS
2676
2677 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2678 if (fd != pp[1])
3aed30dc 2679 PerlLIO_close(fd);
a080fe3d 2680 }
ae986130 2681#endif
a080fe3d
NIS
2682 /* may or may not use the shell */
2683 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2684 PerlProc__exit(1);
a687059c 2685 }
4435c477 2686#endif /* defined OS2 */
713cef20
IZ
2687
2688#ifdef PERLIO_USING_CRLF
2689 /* Since we circumvent IO layers when we manipulate low-level
2690 filedescriptors directly, need to manually switch to the
2691 default, binary, low-level mode; see PerlIOBuf_open(). */
2692 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2693#endif
2694
fafc274c 2695 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2696 SvREADONLY_off(GvSV(tmpgv));
7766f137 2697 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS
2698 SvREADONLY_on(GvSV(tmpgv));
2699 }
2700#ifdef THREADS_HAVE_PIDS
2701 PL_ppid = (IV)getppid();
2702#endif
3280af22 2703 PL_forkprocess = 0;
ca0c25f6 2704#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2705 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2706#endif
4608196e 2707 return NULL;
a687059c
LW
2708#undef THIS
2709#undef THAT
2710 }
b5ac89c3 2711 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2712 if (did_pipes)
2713 PerlLIO_close(pp[1]);
8ac85365 2714 if (p[that] < p[This]) {
6ad3d225
GS
2715 PerlLIO_dup2(p[This], p[that]);
2716 PerlLIO_close(p[This]);
8ac85365 2717 p[This] = p[that];
62b28dd9 2718 }
b5ac89c3
NIS
2719 else
2720 PerlLIO_close(p[that]);
2721
3280af22 2722 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2723 SvUPGRADE(sv,SVt_IV);
45977657 2724 SvIV_set(sv, pid);
3280af22 2725 PL_forkprocess = pid;
e446cec8
IZ
2726 if (did_pipes && pid > 0) {
2727 int errkid;
bb7a0f54
MHM
2728 unsigned n = 0;
2729 SSize_t n1;
e446cec8
IZ
2730
2731 while (n < sizeof(int)) {
2732 n1 = PerlLIO_read(pp[0],
2733 (void*)(((char*)&errkid)+n),
2734 (sizeof(int)) - n);
2735 if (n1 <= 0)
2736 break;
2737 n += n1;
2738 }
2f96c702
IZ
2739 PerlLIO_close(pp[0]);
2740 did_pipes = 0;
e446cec8 2741 if (n) { /* Error */
faa466a7 2742 int pid2, status;
8c51524e 2743 PerlLIO_close(p[This]);
e446cec8 2744 if (n != sizeof(int))
cea2e8a9 2745 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG
2746 do {
2747 pid2 = wait4pid(pid, &status, 0);
2748 } while (pid2 == -1 && errno == EINTR);
e446cec8 2749 errno = errkid; /* Propagate errno from kid */
4608196e 2750 return NULL;
e446cec8
IZ
2751 }
2752 }
2753 if (did_pipes)
2754 PerlLIO_close(pp[0]);
8ac85365 2755 return PerlIO_fdopen(p[This], mode);
a687059c 2756}
7c0587c8 2757#else
85ca448a 2758#if defined(atarist) || defined(EPOC)
7c0587c8 2759FILE *popen();
760ac839 2760PerlIO *
cef6ea9d 2761Perl_my_popen(pTHX_ const char *cmd, const char *mode)
7c0587c8 2762{
7918f24d 2763 PERL_ARGS_ASSERT_MY_POPEN;
45bc9206 2764 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS
2765 /* Call system's popen() to get a FILE *, then import it.
2766 used 0 for 2nd parameter to PerlIO_importFILE;
2767 apparently not used
2768 */
2769 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2770}
2b96b0a5
JH
2771#else
2772#if defined(DJGPP)
2773FILE *djgpp_popen();
2774PerlIO *
cef6ea9d 2775Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2776{
2777 PERL_FLUSHALL_FOR_CHILD;
2778 /* Call system's popen() to get a FILE *, then import it.
2779 used 0 for 2nd parameter to PerlIO_importFILE;
2780 apparently not used
2781 */
2782 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2783}
9c12f1e5
RGS
2784#else
2785#if defined(__LIBCATAMOUNT__)
2786PerlIO *
2787Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2788{
2789 return NULL;
2790}
2791#endif
2b96b0a5 2792#endif
7c0587c8
LW
2793#endif
2794
2795#endif /* !DOSISH */
a687059c 2796
52e18b1f
GS
2797/* this is called in parent before the fork() */
2798void
2799Perl_atfork_lock(void)
2800{
27da23d5 2801 dVAR;
3db8f154 2802#if defined(USE_ITHREADS)
52e18b1f
GS
2803 /* locks must be held in locking order (if any) */
2804# ifdef MYMALLOC
2805 MUTEX_LOCK(&PL_malloc_mutex);
2806# endif
2807 OP_REFCNT_LOCK;
2808#endif
2809}
2810
2811/* this is called in both parent and child after the fork() */
2812void
2813Perl_atfork_unlock(void)
2814{
27da23d5 2815 dVAR;
3db8f154 2816#if defined(USE_ITHREADS)
52e18b1f
GS
2817 /* locks must be released in same order as in atfork_lock() */
2818# ifdef MYMALLOC
2819 MUTEX_UNLOCK(&PL_malloc_mutex);
2820# endif
2821 OP_REFCNT_UNLOCK;
2822#endif
2823}
2824
2825Pid_t
2826Perl_my_fork(void)
2827{
2828#if defined(HAS_FORK)
2829 Pid_t pid;
3db8f154 2830#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2831 atfork_lock();
2832 pid = fork();
2833 atfork_unlock();
2834#else
2835 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2836 * handlers elsewhere in the code */
2837 pid = fork();
2838#endif
2839 return pid;
2840#else
2841 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2842 Perl_croak_nocontext("fork() not available");
b961a566 2843 return 0;
52e18b1f
GS
2844#endif /* HAS_FORK */
2845}
2846
748a9306 2847#ifdef DUMP_FDS
35ff7856 2848void
c9289b7b 2849Perl_dump_fds(pTHX_ const char *const s)
ae986130
LW
2850{
2851 int fd;
c623ac67 2852 Stat_t tmpstatbuf;
ae986130 2853
7918f24d
NC
2854 PERL_ARGS_ASSERT_DUMP_FDS;
2855
bf49b057 2856 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2857 for (fd = 0; fd < 32; fd++) {
6ad3d225 2858 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2859 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2860 }
bf49b057 2861 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2862 return;
ae986130 2863}
35ff7856 2864#endif /* DUMP_FDS */
ae986130 2865
fe14fcc3 2866#ifndef HAS_DUP2
fec02dd3 2867int
ba106d47 2868dup2(int oldfd, int newfd)
a687059c 2869{
a0d0e21e 2870#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2871 if (oldfd == newfd)
2872 return oldfd;
6ad3d225 2873 PerlLIO_close(newfd);
fec02dd3 2874 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2875#else
fc36a67e
PP
2876#define DUP2_MAX_FDS 256
2877 int fdtmp[DUP2_MAX_FDS];
79072805 2878 I32 fdx = 0;
ae986130
LW
2879 int fd;
2880
fe14fcc3 2881 if (oldfd == newfd)
fec02dd3 2882 return oldfd;
6ad3d225 2883 PerlLIO_close(newfd);
fc36a67e 2884 /* good enough for low fd's... */
6ad3d225 2885 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2886 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2887 PerlLIO_close(fd);
fc36a67e
PP
2888 fd = -1;
2889 break;
2890 }
ae986130 2891 fdtmp[fdx++] = fd;
fc36a67e 2892 }
ae986130 2893 while (fdx > 0)
6ad3d225 2894 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2895 return fd;
62b28dd9 2896#endif
a687059c
LW
2897}
2898#endif
2899
64ca3a65 2900#ifndef PERL_MICRO
ff68c719
PP
2901#ifdef HAS_SIGACTION
2902
2903Sighandler_t
864dbfa3 2904Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2905{
27da23d5 2906 dVAR;
ff68c719
PP
2907 struct sigaction act, oact;
2908
a10b1e10
JH
2909#ifdef USE_ITHREADS
2910 /* only "parent" interpreter can diddle signals */
2911 if (PL_curinterp != aTHX)
8aad04aa 2912 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2913#endif
2914
8aad04aa 2915 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2916 sigemptyset(&act.sa_mask);
2917 act.sa_flags = 0;
2918#ifdef SA_RESTART
4ffa73a3
JH
2919 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2920 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2921#endif
358837b8 2922#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2923 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2924 act.sa_flags |= SA_NOCLDWAIT;
2925#endif
ff68c719 2926 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2927 return (Sighandler_t) SIG_ERR;
ff68c719 2928 else
8aad04aa 2929 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2930}
2931
2932Sighandler_t
864dbfa3 2933Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2934{
2935 struct sigaction oact;
96a5add6 2936 PERL_UNUSED_CONTEXT;
ff68c719
PP
2937
2938 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2939 return (Sighandler_t) SIG_ERR;
ff68c719 2940 else
8aad04aa 2941 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2942}
2943
2944int
864dbfa3 2945Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2946{
27da23d5 2947 dVAR;
ff68c719
PP
2948 struct sigaction act;
2949
7918f24d
NC
2950 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2951
a10b1e10
JH
2952#ifdef USE_ITHREADS
2953 /* only "parent" interpreter can diddle signals */
2954 if (PL_curinterp != aTHX)
2955 return -1;
2956#endif
2957
8aad04aa 2958 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2959 sigemptyset(&act.sa_mask);
2960 act.sa_flags = 0;
2961#ifdef SA_RESTART
4ffa73a3
JH
2962 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2963 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2964#endif
36b5d377 2965#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2966 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2967 act.sa_flags |= SA_NOCLDWAIT;
2968#endif
ff68c719
PP
2969 return sigaction(signo, &act, save);
2970}
2971
2972int
864dbfa3 2973Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2974{
27da23d5 2975 dVAR;
a10b1e10
JH
2976#ifdef USE_ITHREADS
2977 /* only "parent" interpreter can diddle signals */
2978 if (PL_curinterp != aTHX)
2979 return -1;
2980#endif
2981
ff68c719
PP
2982 return sigaction(signo, save, (struct sigaction *)NULL);
2983}
2984
2985#else /* !HAS_SIGACTION */
2986
2987Sighandler_t
864dbfa3 2988Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2989{
39f1703b 2990#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2991 /* only "parent" interpreter can diddle signals */
2992 if (PL_curinterp != aTHX)
8aad04aa 2993 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2994#endif
2995
6ad3d225 2996 return PerlProc_signal(signo, handler);
ff68c719
PP
2997}
2998
fabdb6c0 2999static Signal_t
4e35701f 3000sig_trap(int signo)
ff68c719 3001{
27da23d5
JH
3002 dVAR;
3003 PL_sig_trapped++;
ff68c719
PP
3004}
3005
3006Sighandler_t
864dbfa3 3007Perl_rsignal_state(pTHX_ int signo)
ff68c719 3008{
27da23d5 3009 dVAR;
ff68c719
PP
3010 Sighandler_t oldsig;
3011
39f1703b 3012#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3013 /* only "parent" interpreter can diddle signals */
3014 if (PL_curinterp != aTHX)
8aad04aa 3015 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
3016#endif
3017
27da23d5 3018 PL_sig_trapped = 0;
6ad3d225
GS
3019 oldsig = PerlProc_signal(signo, sig_trap);
3020 PerlProc_signal(signo, oldsig);
27da23d5 3021 if (PL_sig_trapped)
3aed30dc 3022 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
3023 return oldsig;
3024}
3025
3026int
864dbfa3 3027Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 3028{
39f1703b 3029#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3030 /* only "parent" interpreter can diddle signals */
3031 if (PL_curinterp != aTHX)
3032 return -1;
3033#endif
6ad3d225 3034 *save = PerlProc_signal(signo, handler);
8aad04aa 3035 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3036}
3037
3038int
864dbfa3 3039Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 3040{
39f1703b 3041#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
3042 /* only "parent" interpreter can diddle signals */
3043 if (PL_curinterp != aTHX)
3044 return -1;
3045#endif
8aad04aa 3046 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
3047}
3048
3049#endif /* !HAS_SIGACTION */
64ca3a65 3050#endif /* !PERL_MICRO */
ff68c719 3051
5f05dabc 3052 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
e37778c2 3053#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
79072805 3054I32
864dbfa3 3055Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 3056{
97aff369 3057 dVAR;
ff68c719 3058 Sigsave_t hstat, istat, qstat;
a687059c 3059 int status;
a0d0e21e 3060 SV **svp;
d8a83dd3
JH
3061 Pid_t pid;
3062 Pid_t pid2;
03136e13 3063 bool close_failed;
4ee39169 3064 dSAVEDERRNO;
a687059c 3065
3280af22 3066 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
25d92023 3067 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 3068 SvREFCNT_dec(*svp);
3280af22 3069 *svp = &PL_sv_undef;
ddcf38b7
IZ
3070#ifdef OS2
3071 if (pid == -1) { /* Opened by popen. */
3072 return my_syspclose(ptr);
3073 }
a1d180c4 3074#endif
f1618b10
CS
3075 close_failed = (PerlIO_close(ptr) == EOF);
3076 SAVE_ERRNO;
7c0587c8 3077#ifdef UTS
6ad3d225 3078 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 3079#endif
64ca3a65 3080#ifndef PERL_MICRO
8aad04aa
JH
3081 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
3082 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
3083 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 3084#endif
748a9306 3085 do {
1d3434b8
GS
3086 pid2 = wait4pid(pid, &status, 0);
3087 } while (pid2 == -1 && errno == EINTR);
64ca3a65 3088#ifndef PERL_MICRO
ff68c719
PP
3089 rsignal_restore(SIGHUP, &hstat);
3090 rsignal_restore(SIGINT, &istat);
3091 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 3092#endif
03136e13 3093 if (close_failed) {
4ee39169 3094 RESTORE_ERRNO;
03136e13
CS
3095 return -1;
3096 }
1d3434b8 3097 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 3098}
9c12f1e5
RGS
3099#else
3100#if defined(__LIBCATAMOUNT__)
3101I32
3102Perl_my_pclose(pTHX_ PerlIO *ptr)
3103{
3104 return -1;
3105}
3106#endif
4633a7c4
LW
3107#endif /* !DOSISH */
3108
e37778c2 3109#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 3110I32
d8a83dd3 3111Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 3112{
97aff369 3113 dVAR;
27da23d5 3114 I32 result = 0;
7918f24d 3115 PERL_ARGS_ASSERT_WAIT4PID;
b7953727
JH
3116 if (!pid)
3117 return -1;
ca0c25f6 3118#ifdef PERL_USES_PL_PIDSTATUS
b7953727 3119 {
3aed30dc 3120 if (pid > 0) {
12072db5
NC
3121 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3122 pid, rather than a string form. */
c4420975 3123 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
3124 if (svp && *svp != &PL_sv_undef) {
3125 *statusp = SvIVX(*svp);
12072db5
NC
3126 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3127 G_DISCARD);
3aed30dc
HS
3128 return pid;
3129 }
3130 }
3131 else {
3132 HE *entry;
3133
3134 hv_iterinit(PL_pidstatus);
3135 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 3136 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 3137 I32 len;
0bcc34c2 3138 const char * const spid = hv_iterkey(entry,&len);
27da23d5 3139
12072db5
NC
3140 assert (len == sizeof(Pid_t));
3141 memcpy((char *)&pid, spid, len);
3aed30dc 3142 *statusp = SvIVX(sv);
7b9a3241
NC
3143 /* The hash iterator is currently on this entry, so simply
3144 calling hv_delete would trigger the lazy delete, which on
3145 aggregate does more work, beacuse next call to hv_iterinit()
3146 would spot the flag, and have to call the delete routine,
3147 while in the meantime any new entries can't re-use that
3148 memory. */
3149 hv_iterinit(PL_pidstatus);
7ea75b61 3150 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
3151 return pid;
3152 }
20188a90
LW
3153 }
3154 }
68a29c53 3155#endif
79072805 3156#ifdef HAS_WAITPID
367f3c24
IZ
3157# ifdef HAS_WAITPID_RUNTIME
3158 if (!HAS_WAITPID_RUNTIME)
3159 goto hard_way;
3160# endif
cddd4526 3161 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 3162 goto finish;
367f3c24
IZ
3163#endif
3164#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 3165 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 3166 goto finish;
367f3c24 3167#endif
ca0c25f6 3168#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 3169#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 3170 hard_way:
27da23d5 3171#endif
a0d0e21e 3172 {
a0d0e21e 3173 if (flags)
cea2e8a9 3174 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 3175 else {
76e3520e 3176 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
3177 pidgone(result,*statusp);
3178 if (result < 0)
3179 *statusp = -1;
3180 }
a687059c
LW
3181 }
3182#endif
27da23d5 3183#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3184 finish:
27da23d5 3185#endif
cddd4526
NIS
3186 if (result < 0 && errno == EINTR) {
3187 PERL_ASYNC_CHECK();
48dbb59e 3188 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
3189 }
3190 return result;
a687059c 3191}
2986a63f 3192#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3193
ca0c25f6 3194#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3195void
ed4173ef 3196S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3197{
79072805 3198 register SV *sv;
a687059c 3199
12072db5 3200 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3201 SvUPGRADE(sv,SVt_IV);
45977657 3202 SvIV_set(sv, status);
20188a90 3203 return;
a687059c 3204}
ca0c25f6 3205#endif
a687059c 3206
85ca448a 3207#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 3208int pclose();
ddcf38b7
IZ
3209#ifdef HAS_FORK
3210int /* Cannot prototype with I32
3211 in os2ish.h. */
ba106d47 3212my_syspclose(PerlIO *ptr)
ddcf38b7 3213#else
79072805 3214I32
864dbfa3 3215Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3216#endif
a687059c 3217{
760ac839 3218 /* Needs work for PerlIO ! */
c4420975 3219 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3220 const I32 result = pclose(f);
2b96b0a5
JH
3221 PerlIO_releaseFILE(ptr,f);
3222 return result;
3223}
3224#endif
3225
933fea7f 3226#if defined(DJGPP)
2b96b0a5
JH
3227int djgpp_pclose();
3228I32
3229Perl_my_pclose(pTHX_ PerlIO *ptr)
3230{
3231 /* Needs work for PerlIO ! */
c4420975 3232 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3233 I32 result = djgpp_pclose(f);
933fea7f 3234 result = (result << 8) & 0xff00;
760ac839
LW
3235 PerlIO_releaseFILE(ptr,f);
3236 return result;
a687059c 3237}
7c0587c8 3238#endif
9f68db38 3239
16fa5c11 3240#define PERL_REPEATCPY_LINEAR 4
9f68db38 3241void
16fa5c11 3242Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
9f68db38 3243{
7918f24d
NC
3244 PERL_ARGS_ASSERT_REPEATCPY;
3245
16fa5c11
VP
3246 if (len == 1)
3247 memset(to, *from, count);
3248 else if (count) {
3249 register char *p = to;
3250 I32 items, linear, half;
3251
3252 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3253 for (items = 0; items < linear; ++items) {
3254 register const char *q = from;
3255 I32 todo;
3256 for (todo = len; todo > 0; todo--)
3257 *p++ = *q++;
3258 }
3259
3260 half = count / 2;
3261 while (items <= half) {
3262 I32 size = items * len;
3263 memcpy(p, to, size);
3264 p += size;
3265 items *= 2;
9f68db38 3266 }
16fa5c11
VP
3267
3268 if (count > items)
3269 memcpy(p, to, (count - items) * len);
9f68db38
LW
3270 }
3271}
0f85fab0 3272
fe14fcc3 3273#ifndef HAS_RENAME
79072805 3274I32
4373e329 3275Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3276{
93a17b20
LW
3277 char *fa = strrchr(a,'/');
3278 char *fb = strrchr(b,'/');
c623ac67
GS
3279 Stat_t tmpstatbuf1;
3280 Stat_t tmpstatbuf2;
c4420975 3281 SV * const tmpsv = sv_newmortal();
62b28dd9 3282
7918f24d
NC
3283 PERL_ARGS_ASSERT_SAME_DIRENT;
3284
62b28dd9
LW
3285 if (fa)
3286 fa++;
3287 else
3288 fa = a;
3289 if (fb)
3290 fb++;
3291 else
3292 fb = b;
3293 if (strNE(a,b))
3294 return FALSE;
3295 if (fa == a)
76f68e9b 3296 sv_setpvs(tmpsv, ".");
62b28dd9 3297 else
46fc3d4c 3298 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3299 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
3300 return FALSE;
3301 if (fb == b)
76f68e9b 3302 sv_setpvs(tmpsv, ".");
62b28dd9 3303 else
46fc3d4c 3304 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3305 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
3306 return FALSE;
3307 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3308 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3309}
fe14fcc3
LW
3310#endif /* !HAS_RENAME */
3311
491527d0 3312char*
7f315aed
NC
3313Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3314 const char *const *const search_ext, I32 flags)
491527d0 3315{
97aff369 3316 dVAR;
bd61b366
SS
3317 const char *xfound = NULL;
3318 char *xfailed = NULL;
0f31cffe 3319 char tmpbuf[MAXPATHLEN];
491527d0 3320 register char *s;
5f74f29c 3321 I32 len = 0;
491527d0 3322 int retval;
39a02377 3323 char *bufend;
491527d0
GS
3324#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3325# define SEARCH_EXTS ".bat", ".cmd", NULL
3326# define MAX_EXT_LEN 4
3327#endif
3328#ifdef OS2
3329# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3330# define MAX_EXT_LEN 4
3331#endif
3332#ifdef VMS
3333# define SEARCH_EXTS ".pl", ".com", NULL
3334# define MAX_EXT_LEN 4
3335#endif
3336 /* additional extensions to try in each dir if scriptname not found */
3337#ifdef SEARCH_EXTS
0bcc34c2 3338 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3339 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3340 int extidx = 0, i = 0;
bd61b366 3341 const char *curext = NULL;
491527d0 3342#else
53c1dcc0 3343 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3344# define MAX_EXT_LEN 0
3345#endif
3346
7918f24d
NC
3347 PERL_ARGS_ASSERT_FIND_SCRIPT;
3348
491527d0
GS
3349 /*
3350 * If dosearch is true and if scriptname does not contain path
3351 * delimiters, search the PATH for scriptname.
3352 *
3353 * If SEARCH_EXTS is also defined, will look for each
3354 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3355 * while searching the PATH.
3356 *
3357 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3358 * proceeds as follows:
3359 * If DOSISH or VMSISH:
3360 * + look for ./scriptname{,.foo,.bar}
3361 * + search the PATH for scriptname{,.foo,.bar}
3362 *
3363 * If !DOSISH:
3364 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3365 * this will not look in '.' if it's not in the PATH)
3366 */
84486fc6 3367 tmpbuf[0] = '\0';
491527d0
GS
3368
3369#ifdef VMS
3370# ifdef ALWAYS_DEFTYPES
3371 len = strlen(scriptname);
3372 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3373 int idx = 0, deftypes = 1;
491527d0
GS
3374 bool seen_dot = 1;
3375
bd61b366 3376 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3377# else
3378 if (dosearch) {
c4420975 3379 int idx = 0, deftypes = 1;
491527d0
GS
3380 bool seen_dot = 1;
3381
bd61b366 3382 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3383# endif
3384 /* The first time through, just add SEARCH_EXTS to whatever we
3385 * already have, so we can check for default file types. */
3386 while (deftypes ||
84486fc6 3387 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3388 {
3389 if (deftypes) {
3390 deftypes = 0;
84486fc6 3391 *tmpbuf = '\0';
491527d0 3392 }
84486fc6
GS
3393 if ((strlen(tmpbuf) + strlen(scriptname)
3394 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3395 continue; /* don't search dir with too-long name */
6fca0082 3396 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3397#else /* !VMS */
3398
3399#ifdef DOSISH
3400 if (strEQ(scriptname, "-"))
3401 dosearch = 0;
3402 if (dosearch) { /* Look in '.' first. */
fe2774ed 3403 const char *cur = scriptname;
491527d0
GS
3404#ifdef SEARCH_EXTS
3405 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3406 while (ext[i])
3407 if (strEQ(ext[i++],curext)) {
3408 extidx = -1; /* already has an ext */
3409 break;
3410 }
3411 do {
3412#endif
3413 DEBUG_p(PerlIO_printf(Perl_debug_log,
3414 "Looking for %s\n",cur));
017f25f1
IZ
3415 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3416 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3417 dosearch = 0;
3418 scriptname = cur;
3419#ifdef SEARCH_EXTS
3420 break;
3421#endif
3422 }
3423#ifdef SEARCH_EXTS
3424 if (cur == scriptname) {
3425 len = strlen(scriptname);
84486fc6 3426 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3427 break;
9e4425f7
SH
3428 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3429 cur = tmpbuf;
491527d0
GS
3430 }
3431 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3432 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3433#endif
3434 }
3435#endif
3436
3437 if (dosearch && !strchr(scriptname, '/')
3438#ifdef DOSISH
3439 && !strchr(scriptname, '\\')
3440#endif
cd39f2b6 3441 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3442 {
491527d0 3443 bool seen_dot = 0;
92f0c265 3444
39a02377
DM
3445 bufend = s + strlen(s);
3446 while (s < bufend) {
491527d0
GS
3447#if defined(atarist) || defined(DOSISH)
3448 for (len = 0; *s
3449# ifdef atarist
3450 && *s != ','
3451# endif
3452 && *s != ';'; len++, s++) {
84486fc6
GS
3453 if (len < sizeof tmpbuf)
3454 tmpbuf[len] = *s;
491527d0 3455 }
84486fc6
GS
3456 if (len < sizeof tmpbuf)
3457 tmpbuf[len] = '\0';
491527d0 3458#else /* ! (atarist || DOSISH) */
39a02377 3459 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3460 ':',
3461 &len);
3462#endif /* ! (atarist || DOSISH) */
39a02377 3463 if (s < bufend)
491527d0 3464 s++;
84486fc6 3465 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3466 continue; /* don't search dir with too-long name */
3467 if (len
cd86ed9d 3468# if defined(atarist) || defined(DOSISH)
84486fc6
GS
3469 && tmpbuf[len - 1] != '/'
3470 && tmpbuf[len - 1] != '\\'
490a0e98 3471# endif
491527d0 3472 )
84486fc6
GS
3473 tmpbuf[len++] = '/';
3474 if (len == 2 && tmpbuf[0] == '.')
491527d0 3475 seen_dot = 1;
28f0d0ec 3476 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3477#endif /* !VMS */
3478
3479#ifdef SEARCH_EXTS
84486fc6 3480 len = strlen(tmpbuf);
491527d0
GS
3481 if (extidx > 0) /* reset after previous loop */
3482 extidx = 0;
3483 do {
3484#endif
84486fc6 3485 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3486 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ
3487 if (S_ISDIR(PL_statbuf.st_mode)) {
3488 retval = -1;
3489 }
491527d0
GS
3490#ifdef SEARCH_EXTS
3491 } while ( retval < 0 /* not there */
3492 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3493 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3494 );
3495#endif
3496 if (retval < 0)
3497 continue;
3280af22
NIS
3498 if (S_ISREG(PL_statbuf.st_mode)
3499 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3500#if !defined(DOSISH)
3280af22 3501 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS
3502#endif
3503 )
3504 {
3aed30dc 3505 xfound = tmpbuf; /* bingo! */
491527d0
GS
3506 break;
3507 }
3508 if (!xfailed)
84486fc6 3509 xfailed = savepv(tmpbuf);
491527d0
GS
3510 }
3511#ifndef DOSISH
017f25f1 3512 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3513 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3514 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS
3515#endif
3516 seen_dot = 1; /* Disable message. */
9ccb31f9
GS
3517 if (!xfound) {
3518 if (flags & 1) { /* do or die? */
3aed30dc 3519 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3520 (xfailed ? "execute" : "find"),
3521 (xfailed ? xfailed : scriptname),
3522 (xfailed ? "" : " on PATH"),
3523 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3524 }
bd61b366 3525 scriptname = NULL;
9ccb31f9 3526 }
43c5f42d 3527 Safefree(xfailed);
491527d0
GS
3528 scriptname = xfound;
3529 }
bd61b366 3530 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3531}
3532
ba869deb
GS
3533#ifndef PERL_GET_CONTEXT_DEFINED
3534
3535void *
3536Perl_get_context(void)
3537{
27da23d5 3538 dVAR;
3db8f154 3539#if defined(USE_ITHREADS)
ba869deb
GS
3540# ifdef OLD_PTHREADS_API
3541 pthread_addr_t t;
3542 if (pthread_getspecific(PL_thr_key, &t))
3543 Perl_croak_nocontext("panic: pthread_getspecific");
3544 return (void*)t;
3545# else
bce813aa 3546# ifdef I_MACH_CTHREADS
8b8b35ab 3547 return (void*)cthread_data(cthread_self());
bce813aa 3548# else
8b8b35ab
JH
3549 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3550# endif
c44d3fdb 3551# endif
ba869deb
GS
3552#else
3553 return (void*)NULL;
3554#endif
3555}
3556
3557void
3558Perl_set_context(void *t)
3559{
8772537c 3560 dVAR;
7918f24d 3561 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3562#if defined(USE_ITHREADS)
c44d3fdb
GS
3563# ifdef I_MACH_CTHREADS
3564 cthread_set_data(cthread_self(), t);
3565# else
ba869deb
GS
3566 if (pthread_setspecific(PL_thr_key, t))
3567 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3568# endif
b464bac0 3569#else
8772537c 3570 PERL_UNUSED_ARG(t);
ba869deb
GS
3571#endif
3572}
3573
3574#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3575
27da23d5 3576#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3577struct perl_vars *
864dbfa3 3578Perl_GetVars(pTHX)
22239a37 3579{
533c011a 3580 return &PL_Vars;
22239a37 3581}
31fb1209
NIS
3582#endif
3583
1cb0ed9b 3584char **
864dbfa3 3585Perl_get_op_names(pTHX)
31fb1209 3586{
96a5add6
AL
3587 PERL_UNUSED_CONTEXT;
3588 return (char **)PL_op_name;
31fb1209
NIS
3589}
3590
1cb0ed9b 3591char **
864dbfa3 3592Perl_get_op_descs(pTHX)
31fb1209 3593{
96a5add6
AL
3594 PERL_UNUSED_CONTEXT;
3595 return (char **)PL_op_desc;
31fb1209 3596}
9e6b2b00 3597
e1ec3a88 3598const char *
864dbfa3 3599Perl_get_no_modify(pTHX)
9e6b2b00 3600{
96a5add6
AL
3601 PERL_UNUSED_CONTEXT;
3602 return PL_no_modify;
9e6b2b00
GS
3603}
3604
3605U32 *
864dbfa3 3606Perl_get_opargs(pTHX)
9e6b2b00 3607{
96a5add6
AL
3608 PERL_UNUSED_CONTEXT;
3609 return (U32 *)PL_opargs;
9e6b2b00 3610}
51aa15f3 3611
0cb96387
GS
3612PPADDR_t*
3613Perl_get_ppaddr(pTHX)
3614{
96a5add6
AL
3615 dVAR;
3616 PERL_UNUSED_CONTEXT;
3617 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3618}