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