This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Quiet warning in a DEBUG print
[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
43387ee1 300 Perl_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
43387ee1 305 Perl_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 }
66379c06
FC
542 if (!SvPOK(sv) || SvNIOKp(sv) || SvIsCOW(sv))
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
43387ee1
AD
1617/* saves machine code for a common noreturn idiom typically used in Newx*() */
1618void
1619Perl_croak_memory_wrap(void)
1620{
1621 Perl_croak_nocontext("%s",PL_memory_wrap);
1622}
1623
1624
3d04513d
DD
1625/* does not return, used only in POPSTACK */
1626void
1627Perl_croak_popstack(void)
1628{
1629 dTHX;
1630 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1631 my_exit(1);
1632}
1633
6ad8f254 1634/*
c5df3096 1635=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1636
c5df3096 1637This is an XS interface to Perl's C<warn> function.
954c1994 1638
c5df3096
Z
1639C<baseex> is the error message or object. If it is a reference, it
1640will be used as-is. Otherwise it is used as a string, and if it does
1641not end with a newline then it will be extended with some indication of
1642the current location in the code, as described for L</mess_sv>.
9983fa3c 1643
c5df3096
Z
1644The error message or object will by default be written to standard error,
1645but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1646
c5df3096
Z
1647To warn with a simple string message, the L</warn> function may be
1648more convenient.
954c1994
GS
1649
1650=cut
1651*/
1652
cea2e8a9 1653void
c5df3096 1654Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1655{
c5df3096
Z
1656 SV *ex = mess_sv(baseex, 0);
1657 PERL_ARGS_ASSERT_WARN_SV;
1658 if (!invoke_exception_hook(ex, TRUE))
1659 write_to_stderr(ex);
cea2e8a9
GS
1660}
1661
c5df3096
Z
1662/*
1663=for apidoc Am|void|vwarn|const char *pat|va_list *args
1664
1665This is an XS interface to Perl's C<warn> function.
1666
1667C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1668argument list. These are used to generate a string message. If the
1669message does not end with a newline, then it will be extended with
1670some indication of the current location in the code, as described for
1671L</mess_sv>.
1672
1673The error message or object will by default be written to standard error,
1674but this is subject to modification by a C<$SIG{__WARN__}> handler.
1675
1676Unlike with L</vcroak>, C<pat> is not permitted to be null.
1677
1678=cut
1679*/
1680
c5be433b
GS
1681void
1682Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1683{
c5df3096 1684 SV *ex = vmess(pat, args);
7918f24d 1685 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
1686 if (!invoke_exception_hook(ex, TRUE))
1687 write_to_stderr(ex);
1688}
7918f24d 1689
c5df3096
Z
1690/*
1691=for apidoc Am|void|warn|const char *pat|...
87582a92 1692
c5df3096
Z
1693This is an XS interface to Perl's C<warn> function.
1694
1695Take a sprintf-style format pattern and argument list. These are used to
1696generate a string message. If the message does not end with a newline,
1697then it will be extended with some indication of the current location
1698in the code, as described for L</mess_sv>.
1699
1700The error message or object will by default be written to standard error,
1701but this is subject to modification by a C<$SIG{__WARN__}> handler.
1702
1703Unlike with L</croak>, C<pat> is not permitted to be null.
1704
1705=cut
1706*/
8d063cd8 1707
c5be433b 1708#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1709void
1710Perl_warn_nocontext(const char *pat, ...)
1711{
1712 dTHX;
1713 va_list args;
7918f24d 1714 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1715 va_start(args, pat);
c5be433b 1716 vwarn(pat, &args);
cea2e8a9
GS
1717 va_end(args);
1718}
1719#endif /* PERL_IMPLICIT_CONTEXT */
1720
1721void
1722Perl_warn(pTHX_ const char *pat, ...)
1723{
1724 va_list args;
7918f24d 1725 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1726 va_start(args, pat);
c5be433b 1727 vwarn(pat, &args);
cea2e8a9
GS
1728 va_end(args);
1729}
1730
c5be433b
GS
1731#if defined(PERL_IMPLICIT_CONTEXT)
1732void
1733Perl_warner_nocontext(U32 err, const char *pat, ...)
1734{
27da23d5 1735 dTHX;
c5be433b 1736 va_list args;
7918f24d 1737 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
1738 va_start(args, pat);
1739 vwarner(err, pat, &args);
1740 va_end(args);
1741}
1742#endif /* PERL_IMPLICIT_CONTEXT */
1743
599cee73 1744void
9b387841
NC
1745Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1746{
1747 PERL_ARGS_ASSERT_CK_WARNER_D;
1748
1749 if (Perl_ckwarn_d(aTHX_ err)) {
1750 va_list args;
1751 va_start(args, pat);
1752 vwarner(err, pat, &args);
1753 va_end(args);
1754 }
1755}
1756
1757void
a2a5de95
NC
1758Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1759{
1760 PERL_ARGS_ASSERT_CK_WARNER;
1761
1762 if (Perl_ckwarn(aTHX_ err)) {
1763 va_list args;
1764 va_start(args, pat);
1765 vwarner(err, pat, &args);
1766 va_end(args);
1767 }
1768}
1769
1770void
864dbfa3 1771Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
1772{
1773 va_list args;
7918f24d 1774 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
1775 va_start(args, pat);
1776 vwarner(err, pat, &args);
1777 va_end(args);
1778}
1779
1780void
1781Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1782{
27da23d5 1783 dVAR;
7918f24d 1784 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1785 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1786 SV * const msv = vmess(pat, args);
599cee73 1787
c5df3096
Z
1788 invoke_exception_hook(msv, FALSE);
1789 die_unwind(msv);
599cee73
PM
1790 }
1791 else {
d13b0d77 1792 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
1793 }
1794}
1795
f54ba1c2
DM
1796/* implements the ckWARN? macros */
1797
1798bool
1799Perl_ckwarn(pTHX_ U32 w)
1800{
97aff369 1801 dVAR;
ad287e37
NC
1802 /* If lexical warnings have not been set, use $^W. */
1803 if (isLEXWARN_off)
1804 return PL_dowarn & G_WARN_ON;
1805
26c7b074 1806 return ckwarn_common(w);
f54ba1c2
DM
1807}
1808
1809/* implements the ckWARN?_d macro */
1810
1811bool
1812Perl_ckwarn_d(pTHX_ U32 w)
1813{
97aff369 1814 dVAR;
ad287e37
NC
1815 /* If lexical warnings have not been set then default classes warn. */
1816 if (isLEXWARN_off)
1817 return TRUE;
1818
26c7b074
NC
1819 return ckwarn_common(w);
1820}
1821
1822static bool
1823S_ckwarn_common(pTHX_ U32 w)
1824{
ad287e37
NC
1825 if (PL_curcop->cop_warnings == pWARN_ALL)
1826 return TRUE;
1827
1828 if (PL_curcop->cop_warnings == pWARN_NONE)
1829 return FALSE;
1830
98fe6610
NC
1831 /* Check the assumption that at least the first slot is non-zero. */
1832 assert(unpackWARN1(w));
1833
1834 /* Check the assumption that it is valid to stop as soon as a zero slot is
1835 seen. */
1836 if (!unpackWARN2(w)) {
1837 assert(!unpackWARN3(w));
1838 assert(!unpackWARN4(w));
1839 } else if (!unpackWARN3(w)) {
1840 assert(!unpackWARN4(w));
1841 }
1842
26c7b074
NC
1843 /* Right, dealt with all the special cases, which are implemented as non-
1844 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
1845 do {
1846 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1847 return TRUE;
1848 } while (w >>= WARNshift);
1849
1850 return FALSE;
f54ba1c2
DM
1851}
1852
72dc9ed5
NC
1853/* Set buffer=NULL to get a new one. */
1854STRLEN *
8ee4cf24 1855Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 1856 STRLEN size) {
5af88345
FC
1857 const MEM_SIZE len_wanted =
1858 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 1859 PERL_UNUSED_CONTEXT;
7918f24d 1860 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 1861
10edeb5d
JH
1862 buffer = (STRLEN*)
1863 (specialWARN(buffer) ?
1864 PerlMemShared_malloc(len_wanted) :
1865 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
1866 buffer[0] = size;
1867 Copy(bits, (buffer + 1), size, char);
5af88345
FC
1868 if (size < WARNsize)
1869 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
1870 return buffer;
1871}
f54ba1c2 1872
e6587932
DM
1873/* since we've already done strlen() for both nam and val
1874 * we can use that info to make things faster than
1875 * sprintf(s, "%s=%s", nam, val)
1876 */
1877#define my_setenv_format(s, nam, nlen, val, vlen) \
1878 Copy(nam, s, nlen, char); \
1879 *(s+nlen) = '='; \
1880 Copy(val, s+(nlen+1), vlen, char); \
1881 *(s+(nlen+1+vlen)) = '\0'
1882
c5d12488
JH
1883#ifdef USE_ENVIRON_ARRAY
1884 /* VMS' my_setenv() is in vms.c */
1885#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1886void
e1ec3a88 1887Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1888{
27da23d5 1889 dVAR;
4efc5df6
GS
1890#ifdef USE_ITHREADS
1891 /* only parent thread can modify process environment */
1892 if (PL_curinterp == aTHX)
1893#endif
1894 {
f2517201 1895#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1896 if (!PL_use_safe_putenv) {
c5d12488 1897 /* most putenv()s leak, so we manipulate environ directly */
eb578fdb
KW
1898 I32 i;
1899 const I32 len = strlen(nam);
c5d12488
JH
1900 int nlen, vlen;
1901
3a9222be
JH
1902 /* where does it go? */
1903 for (i = 0; environ[i]; i++) {
1904 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1905 break;
1906 }
1907
c5d12488
JH
1908 if (environ == PL_origenviron) { /* need we copy environment? */
1909 I32 j;
1910 I32 max;
1911 char **tmpenv;
1912
1913 max = i;
1914 while (environ[max])
1915 max++;
1916 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1917 for (j=0; j<max; j++) { /* copy environment */
1918 const int len = strlen(environ[j]);
1919 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1920 Copy(environ[j], tmpenv[j], len+1, char);
1921 }
1922 tmpenv[max] = NULL;
1923 environ = tmpenv; /* tell exec where it is now */
1924 }
1925 if (!val) {
1926 safesysfree(environ[i]);
1927 while (environ[i]) {
1928 environ[i] = environ[i+1];
1929 i++;
a687059c 1930 }
c5d12488
JH
1931 return;
1932 }
1933 if (!environ[i]) { /* does not exist yet */
1934 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1935 environ[i+1] = NULL; /* make sure it's null terminated */
1936 }
1937 else
1938 safesysfree(environ[i]);
1939 nlen = strlen(nam);
1940 vlen = strlen(val);
1941
1942 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1943 /* all that work just for this */
1944 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1945 } else {
c5d12488 1946# endif
739a0b84 1947# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB
1948# if defined(HAS_UNSETENV)
1949 if (val == NULL) {
1950 (void)unsetenv(nam);
1951 } else {
1952 (void)setenv(nam, val, 1);
1953 }
1954# else /* ! HAS_UNSETENV */
1955 (void)setenv(nam, val, 1);
1956# endif /* HAS_UNSETENV */
47dafe4d 1957# else
88f5bc07
AB
1958# if defined(HAS_UNSETENV)
1959 if (val == NULL) {
ba88ff58
MJ
1960 if (environ) /* old glibc can crash with null environ */
1961 (void)unsetenv(nam);
88f5bc07 1962 } else {
c4420975
AL
1963 const int nlen = strlen(nam);
1964 const int vlen = strlen(val);
1965 char * const new_env =
88f5bc07
AB
1966 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1967 my_setenv_format(new_env, nam, nlen, val, vlen);
1968 (void)putenv(new_env);
1969 }
1970# else /* ! HAS_UNSETENV */
1971 char *new_env;
c4420975
AL
1972 const int nlen = strlen(nam);
1973 int vlen;
88f5bc07
AB
1974 if (!val) {
1975 val = "";
1976 }
1977 vlen = strlen(val);
1978 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1979 /* all that work just for this */
1980 my_setenv_format(new_env, nam, nlen, val, vlen);
1981 (void)putenv(new_env);
1982# endif /* HAS_UNSETENV */
47dafe4d 1983# endif /* __CYGWIN__ */
50acdf95
MS
1984#ifndef PERL_USE_SAFE_PUTENV
1985 }
1986#endif
4efc5df6 1987 }
8d063cd8
LW
1988}
1989
c5d12488 1990#else /* WIN32 || NETWARE */
68dc0745
PP
1991
1992void
72229eff 1993Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1994{
27da23d5 1995 dVAR;
eb578fdb 1996 char *envstr;
c5d12488
JH
1997 const int nlen = strlen(nam);
1998 int vlen;
e6587932 1999
c5d12488
JH
2000 if (!val) {
2001 val = "";
ac5c734f 2002 }
c5d12488
JH
2003 vlen = strlen(val);
2004 Newx(envstr, nlen+vlen+2, char);
2005 my_setenv_format(envstr, nam, nlen, val, vlen);
2006 (void)PerlEnv_putenv(envstr);
2007 Safefree(envstr);
3e3baf6d
TB
2008}
2009
c5d12488 2010#endif /* WIN32 || NETWARE */
3e3baf6d 2011
739a0b84 2012#endif /* !VMS */
378cc40b 2013
16d20bd9 2014#ifdef UNLINK_ALL_VERSIONS
79072805 2015I32
6e732051 2016Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2017{
35da51f7 2018 I32 retries = 0;
378cc40b 2019
7918f24d
NC
2020 PERL_ARGS_ASSERT_UNLNK;
2021
35da51f7
AL
2022 while (PerlLIO_unlink(f) >= 0)
2023 retries++;
2024 return retries ? 0 : -1;
378cc40b
LW
2025}
2026#endif
2027
7a3f2258 2028/* this is a drop-in replacement for bcopy() */
2253333f 2029#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 2030char *
5aaab254 2031Perl_my_bcopy(const char *from, char *to, I32 len)
378cc40b 2032{
2d03de9c 2033 char * const retval = to;
378cc40b 2034
7918f24d
NC
2035 PERL_ARGS_ASSERT_MY_BCOPY;
2036
223f01db
KW
2037 assert(len >= 0);
2038
7c0587c8
LW
2039 if (from - to >= 0) {
2040 while (len--)
2041 *to++ = *from++;
2042 }
2043 else {
2044 to += len;
2045 from += len;
2046 while (len--)
faf8582f 2047 *(--to) = *(--from);
7c0587c8 2048 }
378cc40b
LW
2049 return retval;
2050}
ffed7fef 2051#endif
378cc40b 2052
7a3f2258 2053/* this is a drop-in replacement for memset() */
fc36a67e
PP
2054#ifndef HAS_MEMSET
2055void *
5aaab254 2056Perl_my_memset(char *loc, I32 ch, I32 len)
fc36a67e 2057{
2d03de9c 2058 char * const retval = loc;
fc36a67e 2059
7918f24d
NC
2060 PERL_ARGS_ASSERT_MY_MEMSET;
2061
223f01db
KW
2062 assert(len >= 0);
2063
fc36a67e
PP
2064 while (len--)
2065 *loc++ = ch;
2066 return retval;
2067}
2068#endif
2069
7a3f2258 2070/* this is a drop-in replacement for bzero() */
7c0587c8 2071#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2072char *
5aaab254 2073Perl_my_bzero(char *loc, I32 len)
378cc40b 2074{
2d03de9c 2075 char * const retval = loc;
378cc40b 2076
7918f24d
NC
2077 PERL_ARGS_ASSERT_MY_BZERO;
2078
223f01db
KW
2079 assert(len >= 0);
2080
378cc40b
LW
2081 while (len--)
2082 *loc++ = 0;
2083 return retval;
2084}
2085#endif
7c0587c8 2086
7a3f2258 2087/* this is a drop-in replacement for memcmp() */
36477c24 2088#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2089I32
5aaab254 2090Perl_my_memcmp(const char *s1, const char *s2, I32 len)
7c0587c8 2091{
eb578fdb
KW
2092 const U8 *a = (const U8 *)s1;
2093 const U8 *b = (const U8 *)s2;
2094 I32 tmp;
7c0587c8 2095
7918f24d
NC
2096 PERL_ARGS_ASSERT_MY_MEMCMP;
2097
223f01db
KW
2098 assert(len >= 0);
2099
7c0587c8 2100 while (len--) {
27da23d5 2101 if ((tmp = *a++ - *b++))
7c0587c8
LW
2102 return tmp;
2103 }
2104 return 0;
2105}
36477c24 2106#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2107
fe14fcc3 2108#ifndef HAS_VPRINTF
d05d9be5
AD
2109/* This vsprintf replacement should generally never get used, since
2110 vsprintf was available in both System V and BSD 2.11. (There may
2111 be some cross-compilation or embedded set-ups where it is needed,
2112 however.)
2113
2114 If you encounter a problem in this function, it's probably a symptom
2115 that Configure failed to detect your system's vprintf() function.
2116 See the section on "item vsprintf" in the INSTALL file.
2117
2118 This version may compile on systems with BSD-ish <stdio.h>,
2119 but probably won't on others.
2120*/
a687059c 2121
85e6fe83 2122#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2123char *
2124#else
2125int
2126#endif
d05d9be5 2127vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2128{
2129 FILE fakebuf;
2130
d05d9be5
AD
2131#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2132 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2133 FILE_cnt(&fakebuf) = 32767;
2134#else
2135 /* These probably won't compile -- If you really need
2136 this, you'll have to figure out some other method. */
a687059c
LW
2137 fakebuf._ptr = dest;
2138 fakebuf._cnt = 32767;
d05d9be5 2139#endif
35c8bce7
LW
2140#ifndef _IOSTRG
2141#define _IOSTRG 0
2142#endif
a687059c
LW
2143 fakebuf._flag = _IOWRT|_IOSTRG;
2144 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2145#if defined(STDIO_PTR_LVALUE)
2146 *(FILE_ptr(&fakebuf)++) = '\0';
2147#else
2148 /* PerlIO has probably #defined away fputc, but we want it here. */
2149# ifdef fputc
2150# undef fputc /* XXX Should really restore it later */
2151# endif
2152 (void)fputc('\0', &fakebuf);
2153#endif
85e6fe83 2154#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2155 return(dest);
2156#else
2157 return 0; /* perl doesn't use return value */
2158#endif
2159}
2160
fe14fcc3 2161#endif /* HAS_VPRINTF */
a687059c 2162
4a7d1889 2163PerlIO *
c9289b7b 2164Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2165{
739a0b84 2166#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
97aff369 2167 dVAR;
1f852d0d 2168 int p[2];
eb578fdb
KW
2169 I32 This, that;
2170 Pid_t pid;
1f852d0d
NIS
2171 SV *sv;
2172 I32 did_pipes = 0;
2173 int pp[2];
2174
7918f24d
NC
2175 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2176
1f852d0d
NIS
2177 PERL_FLUSHALL_FOR_CHILD;
2178 This = (*mode == 'w');
2179 that = !This;
284167a5 2180 if (TAINTING_get) {
1f852d0d
NIS
2181 taint_env();
2182 taint_proper("Insecure %s%s", "EXEC");
2183 }
2184 if (PerlProc_pipe(p) < 0)
4608196e 2185 return NULL;
1f852d0d
NIS
2186 /* Try for another pipe pair for error return */
2187 if (PerlProc_pipe(pp) >= 0)
2188 did_pipes = 1;
52e18b1f 2189 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2190 if (errno != EAGAIN) {
2191 PerlLIO_close(p[This]);
4e6dfe71 2192 PerlLIO_close(p[that]);
1f852d0d
NIS
2193 if (did_pipes) {
2194 PerlLIO_close(pp[0]);
2195 PerlLIO_close(pp[1]);
2196 }
4608196e 2197 return NULL;
1f852d0d 2198 }
a2a5de95 2199 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2200 sleep(5);
2201 }
2202 if (pid == 0) {
2203 /* Child */
1f852d0d
NIS
2204#undef THIS
2205#undef THAT
2206#define THIS that
2207#define THAT This
1f852d0d
NIS
2208 /* Close parent's end of error status pipe (if any) */
2209 if (did_pipes) {
2210 PerlLIO_close(pp[0]);
2211#if defined(HAS_FCNTL) && defined(F_SETFD)
2212 /* Close error pipe automatically if exec works */
2213 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2214#endif
2215 }
2216 /* Now dup our end of _the_ pipe to right position */
2217 if (p[THIS] != (*mode == 'r')) {
2218 PerlLIO_dup2(p[THIS], *mode == 'r');
2219 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2220 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2221 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2222 }
4e6dfe71
GS
2223 else
2224 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2225#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2226 /* No automatic close - do it by hand */
b7953727
JH
2227# ifndef NOFILE
2228# define NOFILE 20
2229# endif
a080fe3d
NIS
2230 {
2231 int fd;
2232
2233 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2234 if (fd != pp[1])
a080fe3d
NIS
2235 PerlLIO_close(fd);
2236 }
1f852d0d
NIS
2237 }
2238#endif
a0714e2c 2239 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2240 PerlProc__exit(1);
2241#undef THIS
2242#undef THAT
2243 }
2244 /* Parent */
52e18b1f 2245 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2246 if (did_pipes)
2247 PerlLIO_close(pp[1]);
2248 /* Keep the lower of the two fd numbers */
2249 if (p[that] < p[This]) {
2250 PerlLIO_dup2(p[This], p[that]);
2251 PerlLIO_close(p[This]);
2252 p[This] = p[that];
2253 }
4e6dfe71
GS
2254 else
2255 PerlLIO_close(p[that]); /* close child's end of pipe */
2256
1f852d0d 2257 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2258 SvUPGRADE(sv,SVt_IV);
45977657 2259 SvIV_set(sv, pid);
1f852d0d
NIS
2260 PL_forkprocess = pid;
2261 /* If we managed to get status pipe check for exec fail */
2262 if (did_pipes && pid > 0) {
2263 int errkid;
bb7a0f54
MHM
2264 unsigned n = 0;
2265 SSize_t n1;
1f852d0d
NIS
2266
2267 while (n < sizeof(int)) {
2268 n1 = PerlLIO_read(pp[0],
2269 (void*)(((char*)&errkid)+n),
2270 (sizeof(int)) - n);
2271 if (n1 <= 0)
2272 break;
2273 n += n1;
2274 }
2275 PerlLIO_close(pp[0]);
2276 did_pipes = 0;
2277 if (n) { /* Error */
2278 int pid2, status;
8c51524e 2279 PerlLIO_close(p[This]);
1f852d0d 2280 if (n != sizeof(int))
5637ef5b 2281 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS
2282 do {
2283 pid2 = wait4pid(pid, &status, 0);
2284 } while (pid2 == -1 && errno == EINTR);
2285 errno = errkid; /* Propagate errno from kid */
4608196e 2286 return NULL;
1f852d0d
NIS
2287 }
2288 }
2289 if (did_pipes)
2290 PerlLIO_close(pp[0]);
2291 return PerlIO_fdopen(p[This], mode);
2292#else
9d419b5f 2293# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2294 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2295# else
4a7d1889
NIS
2296 Perl_croak(aTHX_ "List form of piped open not implemented");
2297 return (PerlIO *) NULL;
9d419b5f 2298# endif
1f852d0d 2299#endif
4a7d1889
NIS
2300}
2301
5f05dabc 2302 /* VMS' my_popen() is in VMS.c, same with OS/2. */
739a0b84 2303#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
760ac839 2304PerlIO *
3dd43144 2305Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2306{
97aff369 2307 dVAR;
a687059c 2308 int p[2];
eb578fdb
KW
2309 I32 This, that;
2310 Pid_t pid;
79072805 2311 SV *sv;
bfce84ec 2312 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2313 I32 did_pipes = 0;
2314 int pp[2];
a687059c 2315
7918f24d
NC
2316 PERL_ARGS_ASSERT_MY_POPEN;
2317
45bc9206 2318 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2319#ifdef OS2
2320 if (doexec) {
23da6c43 2321 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2322 }
a1d180c4 2323#endif
8ac85365
NIS
2324 This = (*mode == 'w');
2325 that = !This;
284167a5 2326 if (doexec && TAINTING_get) {
bbce6d69
PP
2327 taint_env();
2328 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2329 }
c2267164 2330 if (PerlProc_pipe(p) < 0)
4608196e 2331 return NULL;
e446cec8
IZ
2332 if (doexec && PerlProc_pipe(pp) >= 0)
2333 did_pipes = 1;
52e18b1f 2334 while ((pid = PerlProc_fork()) < 0) {
a687059c 2335 if (errno != EAGAIN) {
6ad3d225 2336 PerlLIO_close(p[This]);
b5ac89c3 2337 PerlLIO_close(p[that]);
e446cec8
IZ
2338 if (did_pipes) {
2339 PerlLIO_close(pp[0]);
2340 PerlLIO_close(pp[1]);
2341 }
a687059c 2342 if (!doexec)
b3647a36 2343 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2344 return NULL;
a687059c 2345 }
a2a5de95 2346 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2347 sleep(5);
2348 }
2349 if (pid == 0) {
79072805 2350
30ac6d9b
GS
2351#undef THIS
2352#undef THAT
a687059c 2353#define THIS that
8ac85365 2354#define THAT This
e446cec8
IZ
2355 if (did_pipes) {
2356 PerlLIO_close(pp[0]);
2357#if defined(HAS_FCNTL) && defined(F_SETFD)
2358 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2359#endif
2360 }
a687059c 2361 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2362 PerlLIO_dup2(p[THIS], *mode == 'r');
2363 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2364 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2365 PerlLIO_close(p[THAT]);
a687059c 2366 }
b5ac89c3
NIS
2367 else
2368 PerlLIO_close(p[THAT]);
4435c477 2369#ifndef OS2
a687059c 2370 if (doexec) {
a0d0e21e 2371#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2372#ifndef NOFILE
2373#define NOFILE 20
2374#endif
a080fe3d 2375 {
3aed30dc 2376 int fd;
a080fe3d
NIS
2377
2378 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2379 if (fd != pp[1])
3aed30dc 2380 PerlLIO_close(fd);
a080fe3d 2381 }
ae986130 2382#endif
a080fe3d
NIS
2383 /* may or may not use the shell */
2384 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2385 PerlProc__exit(1);
a687059c 2386 }
4435c477 2387#endif /* defined OS2 */
713cef20
IZ
2388
2389#ifdef PERLIO_USING_CRLF
2390 /* Since we circumvent IO layers when we manipulate low-level
2391 filedescriptors directly, need to manually switch to the
2392 default, binary, low-level mode; see PerlIOBuf_open(). */
2393 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2394#endif
3280af22 2395 PL_forkprocess = 0;
ca0c25f6 2396#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2397 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2398#endif
4608196e 2399 return NULL;
a687059c
LW
2400#undef THIS
2401#undef THAT
2402 }
b5ac89c3 2403 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2404 if (did_pipes)
2405 PerlLIO_close(pp[1]);
8ac85365 2406 if (p[that] < p[This]) {
6ad3d225
GS
2407 PerlLIO_dup2(p[This], p[that]);
2408 PerlLIO_close(p[This]);
8ac85365 2409 p[This] = p[that];
62b28dd9 2410 }
b5ac89c3
NIS
2411 else
2412 PerlLIO_close(p[that]);
2413
3280af22 2414 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2415 SvUPGRADE(sv,SVt_IV);
45977657 2416 SvIV_set(sv, pid);
3280af22 2417 PL_forkprocess = pid;
e446cec8
IZ
2418 if (did_pipes && pid > 0) {
2419 int errkid;
bb7a0f54
MHM
2420 unsigned n = 0;
2421 SSize_t n1;
e446cec8
IZ
2422
2423 while (n < sizeof(int)) {
2424 n1 = PerlLIO_read(pp[0],
2425 (void*)(((char*)&errkid)+n),
2426 (sizeof(int)) - n);
2427 if (n1 <= 0)
2428 break;
2429 n += n1;
2430 }
2f96c702
IZ
2431 PerlLIO_close(pp[0]);
2432 did_pipes = 0;
e446cec8 2433 if (n) { /* Error */
faa466a7 2434 int pid2, status;
8c51524e 2435 PerlLIO_close(p[This]);
e446cec8 2436 if (n != sizeof(int))
5637ef5b 2437 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2438 do {
2439 pid2 = wait4pid(pid, &status, 0);
2440 } while (pid2 == -1 && errno == EINTR);
e446cec8 2441 errno = errkid; /* Propagate errno from kid */
4608196e 2442 return NULL;
e446cec8
IZ
2443 }
2444 }
2445 if (did_pipes)
2446 PerlLIO_close(pp[0]);
8ac85365 2447 return PerlIO_fdopen(p[This], mode);
a687059c 2448}
7c0587c8 2449#else
2b96b0a5
JH
2450#if defined(DJGPP)
2451FILE *djgpp_popen();
2452PerlIO *
cef6ea9d 2453Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2454{
2455 PERL_FLUSHALL_FOR_CHILD;
2456 /* Call system's popen() to get a FILE *, then import it.
2457 used 0 for 2nd parameter to PerlIO_importFILE;
2458 apparently not used
2459 */
2460 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2461}
9c12f1e5
RGS
2462#else
2463#if defined(__LIBCATAMOUNT__)
2464PerlIO *
2465Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2466{
2467 return NULL;
2468}
2469#endif
2b96b0a5 2470#endif
7c0587c8
LW
2471
2472#endif /* !DOSISH */
a687059c 2473
52e18b1f
GS
2474/* this is called in parent before the fork() */
2475void
2476Perl_atfork_lock(void)
2477{
27da23d5 2478 dVAR;
3db8f154 2479#if defined(USE_ITHREADS)
52e18b1f 2480 /* locks must be held in locking order (if any) */
4da80956
P
2481# ifdef USE_PERLIO
2482 MUTEX_LOCK(&PL_perlio_mutex);
2483# endif
52e18b1f
GS
2484# ifdef MYMALLOC
2485 MUTEX_LOCK(&PL_malloc_mutex);
2486# endif
2487 OP_REFCNT_LOCK;
2488#endif
2489}
2490
2491/* this is called in both parent and child after the fork() */
2492void
2493Perl_atfork_unlock(void)
2494{
27da23d5 2495 dVAR;
3db8f154 2496#if defined(USE_ITHREADS)
52e18b1f 2497 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2498# ifdef USE_PERLIO
2499 MUTEX_UNLOCK(&PL_perlio_mutex);
2500# endif
52e18b1f
GS
2501# ifdef MYMALLOC
2502 MUTEX_UNLOCK(&PL_malloc_mutex);
2503# endif
2504 OP_REFCNT_UNLOCK;
2505#endif
2506}
2507
2508Pid_t
2509Perl_my_fork(void)
2510{
2511#if defined(HAS_FORK)
2512 Pid_t pid;
3db8f154 2513#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2514 atfork_lock();
2515 pid = fork();
2516 atfork_unlock();
2517#else
2518 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2519 * handlers elsewhere in the code */
2520 pid = fork();
2521#endif
2522 return pid;
2523#else
2524 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2525 Perl_croak_nocontext("fork() not available");
b961a566 2526 return 0;
52e18b1f
GS
2527#endif /* HAS_FORK */
2528}
2529
748a9306 2530#ifdef DUMP_FDS
35ff7856 2531void
c9289b7b 2532Perl_dump_fds(pTHX_ const char *const s)
ae986130
LW
2533{
2534 int fd;
c623ac67 2535 Stat_t tmpstatbuf;
ae986130 2536
7918f24d
NC
2537 PERL_ARGS_ASSERT_DUMP_FDS;
2538
bf49b057 2539 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2540 for (fd = 0; fd < 32; fd++) {
6ad3d225 2541 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2542 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2543 }
bf49b057 2544 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2545 return;
ae986130 2546}
35ff7856 2547#endif /* DUMP_FDS */
ae986130 2548
fe14fcc3 2549#ifndef HAS_DUP2
fec02dd3 2550int
ba106d47 2551dup2(int oldfd, int newfd)
a687059c 2552{
a0d0e21e 2553#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2554 if (oldfd == newfd)
2555 return oldfd;
6ad3d225 2556 PerlLIO_close(newfd);
fec02dd3 2557 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2558#else
fc36a67e
PP
2559#define DUP2_MAX_FDS 256
2560 int fdtmp[DUP2_MAX_FDS];
79072805 2561 I32 fdx = 0;
ae986130
LW
2562 int fd;
2563
fe14fcc3 2564 if (oldfd == newfd)
fec02dd3 2565 return oldfd;
6ad3d225 2566 PerlLIO_close(newfd);
fc36a67e 2567 /* good enough for low fd's... */
6ad3d225 2568 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2569 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2570 PerlLIO_close(fd);
fc36a67e
PP
2571 fd = -1;
2572 break;
2573 }
ae986130 2574 fdtmp[fdx++] = fd;
fc36a67e 2575 }
ae986130 2576 while (fdx > 0)
6ad3d225 2577 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2578 return fd;
62b28dd9 2579#endif
a687059c
LW
2580}
2581#endif
2582
64ca3a65 2583#ifndef PERL_MICRO
ff68c719
PP
2584#ifdef HAS_SIGACTION
2585
2586Sighandler_t
864dbfa3 2587Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2588{
27da23d5 2589 dVAR;
ff68c719
PP
2590 struct sigaction act, oact;
2591
a10b1e10
JH
2592#ifdef USE_ITHREADS
2593 /* only "parent" interpreter can diddle signals */
2594 if (PL_curinterp != aTHX)
8aad04aa 2595 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2596#endif
2597
8aad04aa 2598 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2599 sigemptyset(&act.sa_mask);
2600 act.sa_flags = 0;
2601#ifdef SA_RESTART
4ffa73a3
JH
2602 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2603 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2604#endif
358837b8 2605#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2606 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2607 act.sa_flags |= SA_NOCLDWAIT;
2608#endif
ff68c719 2609 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2610 return (Sighandler_t) SIG_ERR;
ff68c719 2611 else
8aad04aa 2612 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2613}
2614
2615Sighandler_t
864dbfa3 2616Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2617{
2618 struct sigaction oact;
96a5add6 2619 PERL_UNUSED_CONTEXT;
ff68c719
PP
2620
2621 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2622 return (Sighandler_t) SIG_ERR;
ff68c719 2623 else
8aad04aa 2624 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2625}
2626
2627int
864dbfa3 2628Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2629{
27da23d5 2630 dVAR;
ff68c719
PP
2631 struct sigaction act;
2632
7918f24d
NC
2633 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2634
a10b1e10
JH
2635#ifdef USE_ITHREADS
2636 /* only "parent" interpreter can diddle signals */
2637 if (PL_curinterp != aTHX)
2638 return -1;
2639#endif
2640
8aad04aa 2641 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2642 sigemptyset(&act.sa_mask);
2643 act.sa_flags = 0;
2644#ifdef SA_RESTART
4ffa73a3
JH
2645 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2646 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2647#endif
36b5d377 2648#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2649 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2650 act.sa_flags |= SA_NOCLDWAIT;
2651#endif
ff68c719
PP
2652 return sigaction(signo, &act, save);
2653}
2654
2655int
864dbfa3 2656Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2657{
27da23d5 2658 dVAR;
a10b1e10
JH
2659#ifdef USE_ITHREADS
2660 /* only "parent" interpreter can diddle signals */
2661 if (PL_curinterp != aTHX)
2662 return -1;
2663#endif
2664
ff68c719
PP
2665 return sigaction(signo, save, (struct sigaction *)NULL);
2666}
2667
2668#else /* !HAS_SIGACTION */
2669
2670Sighandler_t
864dbfa3 2671Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2672{
39f1703b 2673#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2674 /* only "parent" interpreter can diddle signals */
2675 if (PL_curinterp != aTHX)
8aad04aa 2676 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2677#endif
2678
6ad3d225 2679 return PerlProc_signal(signo, handler);
ff68c719
PP
2680}
2681
fabdb6c0 2682static Signal_t
4e35701f 2683sig_trap(int signo)
ff68c719 2684{
27da23d5
JH
2685 dVAR;
2686 PL_sig_trapped++;
ff68c719
PP
2687}
2688
2689Sighandler_t
864dbfa3 2690Perl_rsignal_state(pTHX_ int signo)
ff68c719 2691{
27da23d5 2692 dVAR;
ff68c719
PP
2693 Sighandler_t oldsig;
2694
39f1703b 2695#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2696 /* only "parent" interpreter can diddle signals */
2697 if (PL_curinterp != aTHX)
8aad04aa 2698 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2699#endif
2700
27da23d5 2701 PL_sig_trapped = 0;
6ad3d225
GS
2702 oldsig = PerlProc_signal(signo, sig_trap);
2703 PerlProc_signal(signo, oldsig);
27da23d5 2704 if (PL_sig_trapped)
3aed30dc 2705 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
2706 return oldsig;
2707}
2708
2709int
864dbfa3 2710Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2711{
39f1703b 2712#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2713 /* only "parent" interpreter can diddle signals */
2714 if (PL_curinterp != aTHX)
2715 return -1;
2716#endif
6ad3d225 2717 *save = PerlProc_signal(signo, handler);
8aad04aa 2718 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2719}
2720
2721int
864dbfa3 2722Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2723{
39f1703b 2724#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2725 /* only "parent" interpreter can diddle signals */
2726 if (PL_curinterp != aTHX)
2727 return -1;
2728#endif
8aad04aa 2729 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2730}
2731
2732#endif /* !HAS_SIGACTION */
64ca3a65 2733#endif /* !PERL_MICRO */
ff68c719 2734
5f05dabc 2735 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
739a0b84 2736#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
79072805 2737I32
864dbfa3 2738Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2739{
97aff369 2740 dVAR;
a687059c 2741 int status;
a0d0e21e 2742 SV **svp;
d8a83dd3 2743 Pid_t pid;
2e0cfa16 2744 Pid_t pid2 = 0;
03136e13 2745 bool close_failed;
4ee39169 2746 dSAVEDERRNO;
2e0cfa16
FC
2747 const int fd = PerlIO_fileno(ptr);
2748
b6ae43b7 2749#ifdef USE_PERLIO
2e0cfa16
FC
2750 /* Find out whether the refcount is low enough for us to wait for the
2751 child proc without blocking. */
2752 const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
b6ae43b7
NC
2753#else
2754 const bool should_wait = 1;
2755#endif
a687059c 2756
2e0cfa16 2757 svp = av_fetch(PL_fdpid,fd,TRUE);
25d92023 2758 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2759 SvREFCNT_dec(*svp);
3280af22 2760 *svp = &PL_sv_undef;
ddcf38b7
IZ
2761#ifdef OS2
2762 if (pid == -1) { /* Opened by popen. */
2763 return my_syspclose(ptr);
2764 }
a1d180c4 2765#endif
f1618b10
CS
2766 close_failed = (PerlIO_close(ptr) == EOF);
2767 SAVE_ERRNO;
2e0cfa16 2768 if (should_wait) do {
1d3434b8
GS
2769 pid2 = wait4pid(pid, &status, 0);
2770 } while (pid2 == -1 && errno == EINTR);
03136e13 2771 if (close_failed) {
4ee39169 2772 RESTORE_ERRNO;
03136e13
CS
2773 return -1;
2774 }
2e0cfa16
FC
2775 return(
2776 should_wait
2777 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2778 : 0
2779 );
20188a90 2780}
9c12f1e5
RGS
2781#else
2782#if defined(__LIBCATAMOUNT__)
2783I32
2784Perl_my_pclose(pTHX_ PerlIO *ptr)
2785{
2786 return -1;
2787}
2788#endif
4633a7c4
LW
2789#endif /* !DOSISH */
2790
e37778c2 2791#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 2792I32
d8a83dd3 2793Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2794{
97aff369 2795 dVAR;
27da23d5 2796 I32 result = 0;
7918f24d 2797 PERL_ARGS_ASSERT_WAIT4PID;
b7953727
JH
2798 if (!pid)
2799 return -1;
ca0c25f6 2800#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2801 {
3aed30dc 2802 if (pid > 0) {
12072db5
NC
2803 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2804 pid, rather than a string form. */
c4420975 2805 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
2806 if (svp && *svp != &PL_sv_undef) {
2807 *statusp = SvIVX(*svp);
12072db5
NC
2808 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2809 G_DISCARD);
3aed30dc
HS
2810 return pid;
2811 }
2812 }
2813 else {
2814 HE *entry;
2815
2816 hv_iterinit(PL_pidstatus);
2817 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2818 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2819 I32 len;
0bcc34c2 2820 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2821
12072db5
NC
2822 assert (len == sizeof(Pid_t));
2823 memcpy((char *)&pid, spid, len);
3aed30dc 2824 *statusp = SvIVX(sv);
7b9a3241
NC
2825 /* The hash iterator is currently on this entry, so simply
2826 calling hv_delete would trigger the lazy delete, which on
2827 aggregate does more work, beacuse next call to hv_iterinit()
2828 would spot the flag, and have to call the delete routine,
2829 while in the meantime any new entries can't re-use that
2830 memory. */
2831 hv_iterinit(PL_pidstatus);
7ea75b61 2832 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
2833 return pid;
2834 }
20188a90
LW
2835 }
2836 }
68a29c53 2837#endif
79072805 2838#ifdef HAS_WAITPID
367f3c24
IZ
2839# ifdef HAS_WAITPID_RUNTIME
2840 if (!HAS_WAITPID_RUNTIME)
2841 goto hard_way;
2842# endif
cddd4526 2843 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2844 goto finish;
367f3c24
IZ
2845#endif
2846#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2847 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2848 goto finish;
367f3c24 2849#endif
ca0c25f6 2850#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2851#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2852 hard_way:
27da23d5 2853#endif
a0d0e21e 2854 {
a0d0e21e 2855 if (flags)
cea2e8a9 2856 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2857 else {
76e3520e 2858 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
2859 pidgone(result,*statusp);
2860 if (result < 0)
2861 *statusp = -1;
2862 }
a687059c
LW
2863 }
2864#endif
27da23d5 2865#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2866 finish:
27da23d5 2867#endif
cddd4526
NIS
2868 if (result < 0 && errno == EINTR) {
2869 PERL_ASYNC_CHECK();
48dbb59e 2870 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
2871 }
2872 return result;
a687059c 2873}
2986a63f 2874#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2875
ca0c25f6 2876#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2877void
ed4173ef 2878S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2879{
eb578fdb 2880 SV *sv;
a687059c 2881
12072db5 2882 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2883 SvUPGRADE(sv,SVt_IV);
45977657 2884 SvIV_set(sv, status);
20188a90 2885 return;
a687059c 2886}
ca0c25f6 2887#endif
a687059c 2888
739a0b84 2889#if defined(OS2)
7c0587c8 2890int pclose();
ddcf38b7
IZ
2891#ifdef HAS_FORK
2892int /* Cannot prototype with I32
2893 in os2ish.h. */
ba106d47 2894my_syspclose(PerlIO *ptr)
ddcf38b7 2895#else
79072805 2896I32
864dbfa3 2897Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2898#endif
a687059c 2899{
760ac839 2900 /* Needs work for PerlIO ! */
c4420975 2901 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 2902 const I32 result = pclose(f);
2b96b0a5
JH
2903 PerlIO_releaseFILE(ptr,f);
2904 return result;
2905}
2906#endif
2907
933fea7f 2908#if defined(DJGPP)
2b96b0a5
JH
2909int djgpp_pclose();
2910I32
2911Perl_my_pclose(pTHX_ PerlIO *ptr)
2912{
2913 /* Needs work for PerlIO ! */
c4420975 2914 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 2915 I32 result = djgpp_pclose(f);
933fea7f 2916 result = (result << 8) & 0xff00;
760ac839
LW
2917 PerlIO_releaseFILE(ptr,f);
2918 return result;
a687059c 2919}
7c0587c8 2920#endif
9f68db38 2921
16fa5c11 2922#define PERL_REPEATCPY_LINEAR 4
9f68db38 2923void
5aaab254 2924Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 2925{
7918f24d
NC
2926 PERL_ARGS_ASSERT_REPEATCPY;
2927
223f01db
KW
2928 assert(len >= 0);
2929
2709980d 2930 if (count < 0)
43387ee1 2931 Perl_croak_memory_wrap();
2709980d 2932
16fa5c11
VP
2933 if (len == 1)
2934 memset(to, *from, count);
2935 else if (count) {
eb578fdb 2936 char *p = to;
26e1303d 2937 IV items, linear, half;
16fa5c11
VP
2938
2939 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2940 for (items = 0; items < linear; ++items) {
eb578fdb 2941 const char *q = from;
26e1303d 2942 IV todo;
16fa5c11
VP
2943 for (todo = len; todo > 0; todo--)
2944 *p++ = *q++;
2945 }
2946
2947 half = count / 2;
2948 while (items <= half) {
26e1303d 2949 IV size = items * len;
16fa5c11
VP
2950 memcpy(p, to, size);
2951 p += size;
2952 items *= 2;
9f68db38 2953 }
16fa5c11
VP
2954
2955 if (count > items)
2956 memcpy(p, to, (count - items) * len);
9f68db38
LW
2957 }
2958}
0f85fab0 2959
fe14fcc3 2960#ifndef HAS_RENAME
79072805 2961I32
4373e329 2962Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 2963{
93a17b20
LW
2964 char *fa = strrchr(a,'/');
2965 char *fb = strrchr(b,'/');
c623ac67
GS
2966 Stat_t tmpstatbuf1;
2967 Stat_t tmpstatbuf2;
c4420975 2968 SV * const tmpsv = sv_newmortal();
62b28dd9 2969
7918f24d
NC
2970 PERL_ARGS_ASSERT_SAME_DIRENT;
2971
62b28dd9
LW
2972 if (fa)
2973 fa++;
2974 else
2975 fa = a;
2976 if (fb)
2977 fb++;
2978 else
2979 fb = b;
2980 if (strNE(a,b))
2981 return FALSE;
2982 if (fa == a)
76f68e9b 2983 sv_setpvs(tmpsv, ".");
62b28dd9 2984 else
46fc3d4c 2985 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 2986 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
2987 return FALSE;
2988 if (fb == b)
76f68e9b 2989 sv_setpvs(tmpsv, ".");
62b28dd9 2990 else
46fc3d4c 2991 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 2992 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
2993 return FALSE;
2994 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2995 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2996}
fe14fcc3
LW
2997#endif /* !HAS_RENAME */
2998
491527d0 2999char*
7f315aed
NC
3000Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3001 const char *const *const search_ext, I32 flags)
491527d0 3002{
97aff369 3003 dVAR;
bd61b366
SS
3004 const char *xfound = NULL;
3005 char *xfailed = NULL;
0f31cffe 3006 char tmpbuf[MAXPATHLEN];
eb578fdb 3007 char *s;
5f74f29c 3008 I32 len = 0;
491527d0 3009 int retval;
39a02377 3010 char *bufend;
7c458fae 3011#if defined(DOSISH) && !defined(OS2)
491527d0
GS
3012# define SEARCH_EXTS ".bat", ".cmd", NULL
3013# define MAX_EXT_LEN 4
3014#endif
3015#ifdef OS2
3016# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3017# define MAX_EXT_LEN 4
3018#endif
3019#ifdef VMS
3020# define SEARCH_EXTS ".pl", ".com", NULL
3021# define MAX_EXT_LEN 4
3022#endif
3023 /* additional extensions to try in each dir if scriptname not found */
3024#ifdef SEARCH_EXTS
0bcc34c2 3025 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3026 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3027 int extidx = 0, i = 0;
bd61b366 3028 const char *curext = NULL;
491527d0 3029#else
53c1dcc0 3030 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3031# define MAX_EXT_LEN 0
3032#endif
3033
7918f24d
NC
3034 PERL_ARGS_ASSERT_FIND_SCRIPT;
3035
491527d0
GS
3036 /*
3037 * If dosearch is true and if scriptname does not contain path
3038 * delimiters, search the PATH for scriptname.
3039 *
3040 * If SEARCH_EXTS is also defined, will look for each
3041 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3042 * while searching the PATH.
3043 *
3044 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3045 * proceeds as follows:
3046 * If DOSISH or VMSISH:
3047 * + look for ./scriptname{,.foo,.bar}
3048 * + search the PATH for scriptname{,.foo,.bar}
3049 *
3050 * If !DOSISH:
3051 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3052 * this will not look in '.' if it's not in the PATH)
3053 */
84486fc6 3054 tmpbuf[0] = '\0';
491527d0
GS
3055
3056#ifdef VMS
3057# ifdef ALWAYS_DEFTYPES
3058 len = strlen(scriptname);
3059 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3060 int idx = 0, deftypes = 1;
491527d0
GS
3061 bool seen_dot = 1;
3062
bd61b366 3063 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3064# else
3065 if (dosearch) {
c4420975 3066 int idx = 0, deftypes = 1;
491527d0
GS
3067 bool seen_dot = 1;
3068
bd61b366 3069 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3070# endif
3071 /* The first time through, just add SEARCH_EXTS to whatever we
3072 * already have, so we can check for default file types. */
3073 while (deftypes ||
84486fc6 3074 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3075 {
3076 if (deftypes) {
3077 deftypes = 0;
84486fc6 3078 *tmpbuf = '\0';
491527d0 3079 }
84486fc6
GS
3080 if ((strlen(tmpbuf) + strlen(scriptname)
3081 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3082 continue; /* don't search dir with too-long name */
6fca0082 3083 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3084#else /* !VMS */
3085
3086#ifdef DOSISH
3087 if (strEQ(scriptname, "-"))
3088 dosearch = 0;
3089 if (dosearch) { /* Look in '.' first. */
fe2774ed 3090 const char *cur = scriptname;
491527d0
GS
3091#ifdef SEARCH_EXTS
3092 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3093 while (ext[i])
3094 if (strEQ(ext[i++],curext)) {
3095 extidx = -1; /* already has an ext */
3096 break;
3097 }
3098 do {
3099#endif
3100 DEBUG_p(PerlIO_printf(Perl_debug_log,
3101 "Looking for %s\n",cur));
017f25f1
IZ
3102 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3103 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3104 dosearch = 0;
3105 scriptname = cur;
3106#ifdef SEARCH_EXTS
3107 break;
3108#endif
3109 }
3110#ifdef SEARCH_EXTS
3111 if (cur == scriptname) {
3112 len = strlen(scriptname);
84486fc6 3113 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3114 break;
9e4425f7
SH
3115 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3116 cur = tmpbuf;
491527d0
GS
3117 }
3118 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3119 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3120#endif
3121 }
3122#endif
3123
3124 if (dosearch && !strchr(scriptname, '/')
3125#ifdef DOSISH
3126 && !strchr(scriptname, '\\')
3127#endif
cd39f2b6 3128 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3129 {
491527d0 3130 bool seen_dot = 0;
92f0c265 3131
39a02377
DM
3132 bufend = s + strlen(s);
3133 while (s < bufend) {
7c458fae 3134# ifdef DOSISH
491527d0 3135 for (len = 0; *s
491527d0 3136 && *s != ';'; len++, s++) {
84486fc6
GS
3137 if (len < sizeof tmpbuf)
3138 tmpbuf[len] = *s;
491527d0 3139 }
84486fc6
GS
3140 if (len < sizeof tmpbuf)
3141 tmpbuf[len] = '\0';
7c458fae 3142# else
39a02377 3143 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3144 ':',
3145 &len);
7c458fae 3146# endif
39a02377 3147 if (s < bufend)
491527d0 3148 s++;
84486fc6 3149 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3150 continue; /* don't search dir with too-long name */
3151 if (len
7c458fae 3152# ifdef DOSISH
84486fc6
GS
3153 && tmpbuf[len - 1] != '/'
3154 && tmpbuf[len - 1] != '\\'
490a0e98 3155# endif
491527d0 3156 )
84486fc6
GS
3157 tmpbuf[len++] = '/';
3158 if (len == 2 && tmpbuf[0] == '.')
491527d0 3159 seen_dot = 1;
28f0d0ec 3160 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3161#endif /* !VMS */
3162
3163#ifdef SEARCH_EXTS
84486fc6 3164 len = strlen(tmpbuf);
491527d0
GS
3165 if (extidx > 0) /* reset after previous loop */
3166 extidx = 0;
3167 do {
3168#endif
84486fc6 3169 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3170 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ
3171 if (S_ISDIR(PL_statbuf.st_mode)) {
3172 retval = -1;
3173 }
491527d0
GS
3174#ifdef SEARCH_EXTS
3175 } while ( retval < 0 /* not there */
3176 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3177 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3178 );
3179#endif
3180 if (retval < 0)
3181 continue;
3280af22
NIS
3182 if (S_ISREG(PL_statbuf.st_mode)
3183 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3184#if !defined(DOSISH)
3280af22 3185 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS
3186#endif
3187 )
3188 {
3aed30dc 3189 xfound = tmpbuf; /* bingo! */
491527d0
GS
3190 break;
3191 }
3192 if (!xfailed)
84486fc6 3193 xfailed = savepv(tmpbuf);
491527d0
GS
3194 }
3195#ifndef DOSISH
017f25f1 3196 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3197 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3198 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS
3199#endif
3200 seen_dot = 1; /* Disable message. */
9ccb31f9
GS
3201 if (!xfound) {
3202 if (flags & 1) { /* do or die? */
6ad282c7 3203 /* diag_listed_as: Can't execute %s */
3aed30dc 3204 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3205 (xfailed ? "execute" : "find"),
3206 (xfailed ? xfailed : scriptname),
3207 (xfailed ? "" : " on PATH"),
3208 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3209 }
bd61b366 3210 scriptname = NULL;
9ccb31f9 3211 }
43c5f42d 3212 Safefree(xfailed);
491527d0
GS
3213 scriptname = xfound;
3214 }
bd61b366 3215 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3216}
3217
ba869deb
GS
3218#ifndef PERL_GET_CONTEXT_DEFINED
3219
3220void *
3221Perl_get_context(void)
3222{
27da23d5 3223 dVAR;
3db8f154 3224#if defined(USE_ITHREADS)
ba869deb
GS
3225# ifdef OLD_PTHREADS_API
3226 pthread_addr_t t;
5637ef5b
NC
3227 int error = pthread_getspecific(PL_thr_key, &t)
3228 if (error)
3229 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS
3230 return (void*)t;
3231# else
bce813aa 3232# ifdef I_MACH_CTHREADS
8b8b35ab 3233 return (void*)cthread_data(cthread_self());
bce813aa 3234# else
8b8b35ab
JH
3235 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3236# endif
c44d3fdb 3237# endif
ba869deb
GS
3238#else
3239 return (void*)NULL;
3240#endif
3241}
3242
3243void
3244Perl_set_context(void *t)
3245{
8772537c 3246 dVAR;
7918f24d 3247 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3248#if defined(USE_ITHREADS)
c44d3fdb
GS
3249# ifdef I_MACH_CTHREADS
3250 cthread_set_data(cthread_self(), t);
3251# else
5637ef5b
NC
3252 {
3253 const int error = pthread_setspecific(PL_thr_key, t);
3254 if (error)
3255 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3256 }
c44d3fdb 3257# endif
b464bac0 3258#else
8772537c 3259 PERL_UNUSED_ARG(t);
ba869deb
GS
3260#endif
3261}
3262
3263#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3264
27da23d5 3265#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3266struct perl_vars *
864dbfa3 3267Perl_GetVars(pTHX)
22239a37 3268{
533c011a 3269 return &PL_Vars;
22239a37 3270}
31fb1209
NIS
3271#endif
3272
1cb0ed9b 3273char **
864dbfa3 3274Perl_get_op_names(pTHX)
31fb1209 3275{
96a5add6
AL
3276 PERL_UNUSED_CONTEXT;
3277 return (char **)PL_op_name;
31fb1209
NIS
3278}
3279
1cb0ed9b 3280char **
864dbfa3 3281Perl_get_op_descs(pTHX)
31fb1209 3282{
96a5add6
AL
3283 PERL_UNUSED_CONTEXT;
3284 return (char **)PL_op_desc;
31fb1209 3285}
9e6b2b00 3286
e1ec3a88 3287const char *
864dbfa3 3288Perl_get_no_modify(pTHX)
9e6b2b00 3289{
96a5add6
AL
3290 PERL_UNUSED_CONTEXT;
3291 return PL_no_modify;
9e6b2b00
GS
3292}
3293
3294U32 *
864dbfa3 3295Perl_get_opargs(pTHX)
9e6b2b00 3296{
96a5add6
AL
3297 PERL_UNUSED_CONTEXT;
3298 return (U32 *)PL_opargs;
9e6b2b00 3299}
51aa15f3 3300
0cb96387
GS
3301PPADDR_t*
3302Perl_get_ppaddr(pTHX)
3303{
96a5add6
AL
3304 dVAR;
3305 PERL_UNUSED_CONTEXT;
3306 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3307}
3308
a6c40364
GS
3309#ifndef HAS_GETENV_LEN
3310char *
bf4acbe4 3311Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3312{
8772537c 3313 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3314 PERL_UNUSED_CONTEXT;
7918f24d 3315 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS
3316 if (env_trans)
3317 *len = strlen(env_trans);
3318 return env_trans;
f675dbe5
CB
3319}
3320#endif
3321
dc9e4912
GS
3322
3323MGVTBL*
864dbfa3 3324Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3325{
96a5add6 3326 PERL_UNUSED_CONTEXT;
dc9e4912 3327
c7fdacb9
NC
3328 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3329 ? NULL : PL_magic_vtables + vtbl_id;
dc9e4912
GS
3330}
3331
767df6a1 3332I32
864dbfa3 3333Perl_my_fflush_all(pTHX)
767df6a1 3334{
f800e14d 3335#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3336 return PerlIO_flush(NULL);
767df6a1 3337#else
8fbdfb7c 3338# if defined(HAS__FWALK)
f13a2bc0 3339 extern int fflush(FILE *);
74cac757
JH
3340 /* undocumented, unprototyped, but very useful BSDism */
3341 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3342 _fwalk(&fflush);
74cac757 3343 return 0;
8fa7f367 3344# else
8fbdfb7c 3345# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3346 long open_max = -1;
8fbdfb7c 3347# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3348 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3349# else
8fa7f367 3350# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3351 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH
3352# else
3353# ifdef FOPEN_MAX
74cac757 3354 open_max = FOPEN_MAX;
8fa7f367
JH
3355# else
3356# ifdef OPEN_MAX
74cac757 3357 open_max = OPEN_MAX;
8fa7f367
JH
3358# else
3359# ifdef _NFILE
d2201af2 3360 open_max = _NFILE;
8fa7f367
JH
3361# endif
3362# endif
74cac757 3363# endif
767df6a1
JH
3364# endif
3365# endif
767df6a1
JH
3366 if (open_max > 0) {
3367 long i;
3368 for (i = 0; i < open_max; i++)
d2201af2
AD
3369 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3370 STDIO_STREAM_ARRAY[i]._file < open_max &&
3371 STDIO_STREAM_ARRAY[i]._flag)
3372 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH
3373 return 0;
3374 }
8fbdfb7c 3375# endif
93189314 3376 SETERRNO(EBADF,RMS_IFI);
767df6a1 3377 return EOF;
74cac757 3378# endif
767df6a1
JH
3379#endif
3380}
097ee67d 3381
69282e91 3382void
45219de6 3383Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
a5390457
NC
3384{
3385 if (ckWARN(WARN_IO)) {
0223a801 3386 HEK * const name
c6e4ff34 3387 = gv && (isGV_with_GP(gv))
0223a801 3388 ? GvENAME_HEK((gv))
3b46b707 3389 : NULL;
a5390457
NC
3390 const char * const direction = have == '>' ? "out" : "in";
3391
b3c81598 3392 if (name && HEK_LEN(name))
a5390457 3393 Perl_warner(aTHX_ packWARN(WARN_IO),
0223a801 3394 "Filehandle %"HEKf" opened only for %sput",
a5390457
NC
3395 name, direction);
3396 else
3397 Perl_warner(aTHX_ packWARN(WARN_IO),
3398 "Filehandle opened only for %sput", direction);
3399 }
3400}
3401
3402void
831e4cc3 3403Perl_report_evil_fh(pTHX_ const GV *gv)
bc37a18f 3404{
65820a28 3405 const IO *io = gv ? GvIO(gv) : NULL;
831e4cc3 3406 const PERL_BITFIELD16 op = PL_op->op_type;
a5390457
NC
3407 const char *vile;
3408 I32 warn_type;
3409
65820a28 3410 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
a5390457
NC
3411 vile = "closed";
3412 warn_type = WARN_CLOSED;
2dd78f96
JH
3413 }
3414 else {
a5390457
NC
3415 vile = "unopened";
3416 warn_type = WARN_UNOPENED;
3417 }
3418
3419 if (ckWARN(warn_type)) {
3b46b707 3420 SV * const name
5c5c5f45 3421 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3b46b707 3422 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
a5390457
NC
3423 const char * const pars =
3424 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3425 const char * const func =
3426 (const char *)
3427 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3428 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
a5390457
NC
3429 PL_op_desc[op]);
3430 const char * const type =
3431 (const char *)
65820a28 3432 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
a5390457 3433 ? "socket" : "filehandle");
1e00d6e9 3434 const bool have_name = name && SvCUR(name);
65d99836
FC
3435 Perl_warner(aTHX_ packWARN(warn_type),
3436 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3437 have_name ? " " : "",
3438 SVfARG(have_name ? name : &PL_sv_no));
3439 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
a5390457
NC
3440 Perl_warner(
3441 aTHX_ packWARN(warn_type),
65d99836
FC
3442 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3443 func, pars, have_name ? " " : "",
3444 SVfARG(have_name ? name : &PL_sv_no)
a5390457 3445 );
bc37a18f 3446 }
69282e91 3447}
a926ef6b 3448
f6adc668 3449/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH
3450 * system to give us a reasonable struct to copy. This fix means that
3451 * strftime uses the tm_zone and tm_gmtoff values returned by
3452 * localtime(time()). That should give the desired result most of the
3453 * time. But probably not always!
3454 *
f6adc668
JH
3455 * This does not address tzname aspects of NETaa14816.
3456 *
e72cf795 3457 */
f6adc668 3458
e72cf795
JH
3459#ifdef HAS_GNULIBC
3460# ifndef STRUCT_TM_HASZONE
3461# define STRUCT_TM_HASZONE
3462# endif
3463#endif
3464
f6adc668
JH
3465#ifdef STRUCT_TM_HASZONE /* Backward compat */
3466# ifndef HAS_TM_TM_ZONE
3467# define HAS_TM_TM_ZONE
3468# endif
3469#endif
3470
e72cf795 3471void
f1208910 3472Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3473{
f6adc668 3474#ifdef HAS_TM_TM_ZONE
e72cf795 3475 Time_t now;
1b6737cc 3476 const struct tm* my_tm;
7918f24d 3477 PERL_ARGS_ASSERT_INIT_TM;
e72cf795 3478 (void)time(&now);
82c57498 3479 my_tm = localtime(&now);
ca46b8ee
SP
3480 if (my_tm)
3481 Copy(my_tm, ptm, 1, struct tm);
1b6737cc 3482#else
7918f24d 3483 PERL_ARGS_ASSERT_INIT_TM;
1b6737cc 3484 PERL_UNUSED_ARG(ptm);
e72cf795
JH
3485#endif
3486}
3487
3488/*
3489 * mini_mktime - normalise struct tm values without the localtime()
3490 * semantics (and overhead) of mktime().
3491 */
3492void
f1208910 3493Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH
3494{
3495 int yearday;
3496 int secs;
3497 int month, mday, year, jday;
3498 int odd_cent, odd_year;
96a5add6 3499 PERL_UNUSED_CONTEXT;
e72cf795 3500
7918f24d
NC
3501 PERL_ARGS_ASSERT_MINI_MKTIME;
3502
e72cf795
JH
3503#define DAYS_PER_YEAR 365
3504#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3505#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3506#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3507#define SECS_PER_HOUR (60*60)
3508#define SECS_PER_DAY (24*SECS_PER_HOUR)
3509/* parentheses deliberately absent on these two, otherwise they don't work */
3510#define MONTH_TO_DAYS 153/5
3511#define DAYS_TO_MONTH 5/153
3512/* offset to bias by March (month 4) 1st between month/mday & year finding */
3513#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3514/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3515#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3516
3517/*
3518 * Year/day algorithm notes:
3519 *
3520 * With a suitable offset for numeric value of the month, one can find
3521 * an offset into the year by considering months to have 30.6 (153/5) days,
3522 * using integer arithmetic (i.e., with truncation). To avoid too much
3523 * messing about with leap days, we consider January and February to be
3524 * the 13th and 14th month of the previous year. After that transformation,
3525 * we need the month index we use to be high by 1 from 'normal human' usage,
3526 * so the month index values we use run from 4 through 15.
3527 *
3528 * Given that, and the rules for the Gregorian calendar (leap years are those
3529 * divisible by 4 unless also divisible by 100, when they must be divisible
3530 * by 400 instead), we can simply calculate the number of days since some
3531 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3532 * the days we derive from our month index, and adding in the day of the
3533 * month. The value used here is not adjusted for the actual origin which
3534 * it normally would use (1 January A.D. 1), since we're not exposing it.
3535 * We're only building the value so we can turn around and get the
3536 * normalised values for the year, month, day-of-month, and day-of-year.
3537 *
3538 * For going backward, we need to bias the value we're using so that we find
3539 * the right year value. (Basically, we don't want the contribution of
3540 * March 1st to the number to apply while deriving the year). Having done
3541 * that, we 'count up' the contribution to the year number by accounting for
3542 * full quadracenturies (400-year periods) with their extra leap days, plus
3543 * the contribution from full centuries (to avoid counting in the lost leap
3544 * days), plus the contribution from full quad-years (to count in the normal
3545 * leap days), plus the leftover contribution from any non-leap years.
3546 * At this point, if we were working with an actual leap day, we'll have 0
3547 * days left over. This is also true for March 1st, however. So, we have
3548 * to special-case that result, and (earlier) keep track of the 'odd'
3549 * century and year contributions. If we got 4 extra centuries in a qcent,
3550 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3551 * Otherwise, we add back in the earlier bias we removed (the 123 from
3552 * figuring in March 1st), find the month index (integer division by 30.6),
3553 * and the remainder is the day-of-month. We then have to convert back to
3554 * 'real' months (including fixing January and February from being 14/15 in
3555 * the previous year to being in the proper year). After that, to get
3556 * tm_yday, we work with the normalised year and get a new yearday value for
3557 * January 1st, which we subtract from the yearday value we had earlier,
3558