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