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