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