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