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