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