This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
doio.c: Remove EBCDIC dependency
[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;
04783dc7 1598 int rc;
77c1c05b 1599
4cbe3a7d 1600 /* Can't use PerlIO to write as it allocates memory */
04783dc7 1601 rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
4cbe3a7d 1602 PL_no_mem, sizeof(PL_no_mem)-1);
04783dc7
DM
1603 /* silently ignore failures */
1604 PERL_UNUSED_VAR(rc);
4cbe3a7d
DD
1605 my_exit(1);
1606}
1607
3d04513d
DD
1608/* does not return, used only in POPSTACK */
1609void
1610Perl_croak_popstack(void)
1611{
1612 dTHX;
1613 PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1614 my_exit(1);
1615}
1616
6ad8f254 1617/*
c5df3096 1618=for apidoc Am|void|warn_sv|SV *baseex
ccfc67b7 1619
c5df3096 1620This is an XS interface to Perl's C<warn> function.
954c1994 1621
c5df3096
Z
1622C<baseex> is the error message or object. If it is a reference, it
1623will be used as-is. Otherwise it is used as a string, and if it does
1624not end with a newline then it will be extended with some indication of
1625the current location in the code, as described for L</mess_sv>.
9983fa3c 1626
c5df3096
Z
1627The error message or object will by default be written to standard error,
1628but this is subject to modification by a C<$SIG{__WARN__}> handler.
9983fa3c 1629
c5df3096
Z
1630To warn with a simple string message, the L</warn> function may be
1631more convenient.
954c1994
GS
1632
1633=cut
1634*/
1635
cea2e8a9 1636void
c5df3096 1637Perl_warn_sv(pTHX_ SV *baseex)
cea2e8a9 1638{
c5df3096
Z
1639 SV *ex = mess_sv(baseex, 0);
1640 PERL_ARGS_ASSERT_WARN_SV;
1641 if (!invoke_exception_hook(ex, TRUE))
1642 write_to_stderr(ex);
cea2e8a9
GS
1643}
1644
c5df3096
Z
1645/*
1646=for apidoc Am|void|vwarn|const char *pat|va_list *args
1647
1648This is an XS interface to Perl's C<warn> function.
1649
1650C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1651argument list. These are used to generate a string message. If the
1652message does not end with a newline, then it will be extended with
1653some indication of the current location in the code, as described for
1654L</mess_sv>.
1655
1656The error message or object will by default be written to standard error,
1657but this is subject to modification by a C<$SIG{__WARN__}> handler.
1658
1659Unlike with L</vcroak>, C<pat> is not permitted to be null.
1660
1661=cut
1662*/
1663
c5be433b
GS
1664void
1665Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1666{
c5df3096 1667 SV *ex = vmess(pat, args);
7918f24d 1668 PERL_ARGS_ASSERT_VWARN;
c5df3096
Z
1669 if (!invoke_exception_hook(ex, TRUE))
1670 write_to_stderr(ex);
1671}
7918f24d 1672
c5df3096
Z
1673/*
1674=for apidoc Am|void|warn|const char *pat|...
87582a92 1675
c5df3096
Z
1676This is an XS interface to Perl's C<warn> function.
1677
1678Take a sprintf-style format pattern and argument list. These are used to
1679generate a string message. If the message does not end with a newline,
1680then it will be extended with some indication of the current location
1681in the code, as described for L</mess_sv>.
1682
1683The error message or object will by default be written to standard error,
1684but this is subject to modification by a C<$SIG{__WARN__}> handler.
1685
1686Unlike with L</croak>, C<pat> is not permitted to be null.
1687
1688=cut
1689*/
8d063cd8 1690
c5be433b 1691#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS
1692void
1693Perl_warn_nocontext(const char *pat, ...)
1694{
1695 dTHX;
1696 va_list args;
7918f24d 1697 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1698 va_start(args, pat);
c5be433b 1699 vwarn(pat, &args);
cea2e8a9
GS
1700 va_end(args);
1701}
1702#endif /* PERL_IMPLICIT_CONTEXT */
1703
1704void
1705Perl_warn(pTHX_ const char *pat, ...)
1706{
1707 va_list args;
7918f24d 1708 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1709 va_start(args, pat);
c5be433b 1710 vwarn(pat, &args);
cea2e8a9
GS
1711 va_end(args);
1712}
1713
c5be433b
GS
1714#if defined(PERL_IMPLICIT_CONTEXT)
1715void
1716Perl_warner_nocontext(U32 err, const char *pat, ...)
1717{
27da23d5 1718 dTHX;
c5be433b 1719 va_list args;
7918f24d 1720 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS
1721 va_start(args, pat);
1722 vwarner(err, pat, &args);
1723 va_end(args);
1724}
1725#endif /* PERL_IMPLICIT_CONTEXT */
1726
599cee73 1727void
9b387841
NC
1728Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1729{
1730 PERL_ARGS_ASSERT_CK_WARNER_D;
1731
1732 if (Perl_ckwarn_d(aTHX_ err)) {
1733 va_list args;
1734 va_start(args, pat);
1735 vwarner(err, pat, &args);
1736 va_end(args);
1737 }
1738}
1739
1740void
a2a5de95
NC
1741Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1742{
1743 PERL_ARGS_ASSERT_CK_WARNER;
1744
1745 if (Perl_ckwarn(aTHX_ err)) {
1746 va_list args;
1747 va_start(args, pat);
1748 vwarner(err, pat, &args);
1749 va_end(args);
1750 }
1751}
1752
1753void
864dbfa3 1754Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM
1755{
1756 va_list args;
7918f24d 1757 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS
1758 va_start(args, pat);
1759 vwarner(err, pat, &args);
1760 va_end(args);
1761}
1762
1763void
1764Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1765{
27da23d5 1766 dVAR;
7918f24d 1767 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1768 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1769 SV * const msv = vmess(pat, args);
599cee73 1770
c5df3096
Z
1771 invoke_exception_hook(msv, FALSE);
1772 die_unwind(msv);
599cee73
PM
1773 }
1774 else {
d13b0d77 1775 Perl_vwarn(aTHX_ pat, args);
599cee73
PM
1776 }
1777}
1778
f54ba1c2
DM
1779/* implements the ckWARN? macros */
1780
1781bool
1782Perl_ckwarn(pTHX_ U32 w)
1783{
97aff369 1784 dVAR;
ad287e37
NC
1785 /* If lexical warnings have not been set, use $^W. */
1786 if (isLEXWARN_off)
1787 return PL_dowarn & G_WARN_ON;
1788
26c7b074 1789 return ckwarn_common(w);
f54ba1c2
DM
1790}
1791
1792/* implements the ckWARN?_d macro */
1793
1794bool
1795Perl_ckwarn_d(pTHX_ U32 w)
1796{
97aff369 1797 dVAR;
ad287e37
NC
1798 /* If lexical warnings have not been set then default classes warn. */
1799 if (isLEXWARN_off)
1800 return TRUE;
1801
26c7b074
NC
1802 return ckwarn_common(w);
1803}
1804
1805static bool
1806S_ckwarn_common(pTHX_ U32 w)
1807{
ad287e37
NC
1808 if (PL_curcop->cop_warnings == pWARN_ALL)
1809 return TRUE;
1810
1811 if (PL_curcop->cop_warnings == pWARN_NONE)
1812 return FALSE;
1813
98fe6610
NC
1814 /* Check the assumption that at least the first slot is non-zero. */
1815 assert(unpackWARN1(w));
1816
1817 /* Check the assumption that it is valid to stop as soon as a zero slot is
1818 seen. */
1819 if (!unpackWARN2(w)) {
1820 assert(!unpackWARN3(w));
1821 assert(!unpackWARN4(w));
1822 } else if (!unpackWARN3(w)) {
1823 assert(!unpackWARN4(w));
1824 }
1825
26c7b074
NC
1826 /* Right, dealt with all the special cases, which are implemented as non-
1827 pointers, so there is a pointer to a real warnings mask. */
98fe6610
NC
1828 do {
1829 if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1830 return TRUE;
1831 } while (w >>= WARNshift);
1832
1833 return FALSE;
f54ba1c2
DM
1834}
1835
72dc9ed5
NC
1836/* Set buffer=NULL to get a new one. */
1837STRLEN *
8ee4cf24 1838Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5 1839 STRLEN size) {
5af88345
FC
1840 const MEM_SIZE len_wanted =
1841 sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
35da51f7 1842 PERL_UNUSED_CONTEXT;
7918f24d 1843 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 1844
10edeb5d
JH
1845 buffer = (STRLEN*)
1846 (specialWARN(buffer) ?
1847 PerlMemShared_malloc(len_wanted) :
1848 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC
1849 buffer[0] = size;
1850 Copy(bits, (buffer + 1), size, char);
5af88345
FC
1851 if (size < WARNsize)
1852 Zero((char *)(buffer + 1) + size, WARNsize - size, char);
72dc9ed5
NC
1853 return buffer;
1854}
f54ba1c2 1855
e6587932
DM
1856/* since we've already done strlen() for both nam and val
1857 * we can use that info to make things faster than
1858 * sprintf(s, "%s=%s", nam, val)
1859 */
1860#define my_setenv_format(s, nam, nlen, val, vlen) \
1861 Copy(nam, s, nlen, char); \
1862 *(s+nlen) = '='; \
1863 Copy(val, s+(nlen+1), vlen, char); \
1864 *(s+(nlen+1+vlen)) = '\0'
1865
c5d12488
JH
1866#ifdef USE_ENVIRON_ARRAY
1867 /* VMS' my_setenv() is in vms.c */
1868#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1869void
e1ec3a88 1870Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1871{
27da23d5 1872 dVAR;
4efc5df6
GS
1873#ifdef USE_ITHREADS
1874 /* only parent thread can modify process environment */
1875 if (PL_curinterp == aTHX)
1876#endif
1877 {
f2517201 1878#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1879 if (!PL_use_safe_putenv) {
c5d12488 1880 /* most putenv()s leak, so we manipulate environ directly */
eb578fdb
KW
1881 I32 i;
1882 const I32 len = strlen(nam);
c5d12488
JH
1883 int nlen, vlen;
1884
3a9222be
JH
1885 /* where does it go? */
1886 for (i = 0; environ[i]; i++) {
1887 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1888 break;
1889 }
1890
c5d12488
JH
1891 if (environ == PL_origenviron) { /* need we copy environment? */
1892 I32 j;
1893 I32 max;
1894 char **tmpenv;
1895
1896 max = i;
1897 while (environ[max])
1898 max++;
1899 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1900 for (j=0; j<max; j++) { /* copy environment */
1901 const int len = strlen(environ[j]);
1902 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1903 Copy(environ[j], tmpenv[j], len+1, char);
1904 }
1905 tmpenv[max] = NULL;
1906 environ = tmpenv; /* tell exec where it is now */
1907 }
1908 if (!val) {
1909 safesysfree(environ[i]);
1910 while (environ[i]) {
1911 environ[i] = environ[i+1];
1912 i++;
a687059c 1913 }
c5d12488
JH
1914 return;
1915 }
1916 if (!environ[i]) { /* does not exist yet */
1917 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1918 environ[i+1] = NULL; /* make sure it's null terminated */
1919 }
1920 else
1921 safesysfree(environ[i]);
1922 nlen = strlen(nam);
1923 vlen = strlen(val);
1924
1925 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1926 /* all that work just for this */
1927 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1928 } else {
c5d12488 1929# endif
739a0b84 1930# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB
1931# if defined(HAS_UNSETENV)
1932 if (val == NULL) {
1933 (void)unsetenv(nam);
1934 } else {
1935 (void)setenv(nam, val, 1);
1936 }
1937# else /* ! HAS_UNSETENV */
1938 (void)setenv(nam, val, 1);
1939# endif /* HAS_UNSETENV */
47dafe4d 1940# else
88f5bc07
AB
1941# if defined(HAS_UNSETENV)
1942 if (val == NULL) {
ba88ff58
MJ
1943 if (environ) /* old glibc can crash with null environ */
1944 (void)unsetenv(nam);
88f5bc07 1945 } else {
c4420975
AL
1946 const int nlen = strlen(nam);
1947 const int vlen = strlen(val);
1948 char * const new_env =
88f5bc07
AB
1949 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1950 my_setenv_format(new_env, nam, nlen, val, vlen);
1951 (void)putenv(new_env);
1952 }
1953# else /* ! HAS_UNSETENV */
1954 char *new_env;
c4420975
AL
1955 const int nlen = strlen(nam);
1956 int vlen;
88f5bc07
AB
1957 if (!val) {
1958 val = "";
1959 }
1960 vlen = strlen(val);
1961 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1962 /* all that work just for this */
1963 my_setenv_format(new_env, nam, nlen, val, vlen);
1964 (void)putenv(new_env);
1965# endif /* HAS_UNSETENV */
47dafe4d 1966# endif /* __CYGWIN__ */
50acdf95
MS
1967#ifndef PERL_USE_SAFE_PUTENV
1968 }
1969#endif
4efc5df6 1970 }
8d063cd8
LW
1971}
1972
c5d12488 1973#else /* WIN32 || NETWARE */
68dc0745
PP
1974
1975void
72229eff 1976Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1977{
27da23d5 1978 dVAR;
eb578fdb 1979 char *envstr;
c5d12488
JH
1980 const int nlen = strlen(nam);
1981 int vlen;
e6587932 1982
c5d12488
JH
1983 if (!val) {
1984 val = "";
ac5c734f 1985 }
c5d12488
JH
1986 vlen = strlen(val);
1987 Newx(envstr, nlen+vlen+2, char);
1988 my_setenv_format(envstr, nam, nlen, val, vlen);
1989 (void)PerlEnv_putenv(envstr);
1990 Safefree(envstr);
3e3baf6d
TB
1991}
1992
c5d12488 1993#endif /* WIN32 || NETWARE */
3e3baf6d 1994
739a0b84 1995#endif /* !VMS */
378cc40b 1996
16d20bd9 1997#ifdef UNLINK_ALL_VERSIONS
79072805 1998I32
6e732051 1999Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 2000{
35da51f7 2001 I32 retries = 0;
378cc40b 2002
7918f24d
NC
2003 PERL_ARGS_ASSERT_UNLNK;
2004
35da51f7
AL
2005 while (PerlLIO_unlink(f) >= 0)
2006 retries++;
2007 return retries ? 0 : -1;
378cc40b
LW
2008}
2009#endif
2010
7a3f2258 2011/* this is a drop-in replacement for bcopy() */
2253333f 2012#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 2013char *
5aaab254 2014Perl_my_bcopy(const char *from, char *to, I32 len)
378cc40b 2015{
2d03de9c 2016 char * const retval = to;
378cc40b 2017
7918f24d
NC
2018 PERL_ARGS_ASSERT_MY_BCOPY;
2019
223f01db
KW
2020 assert(len >= 0);
2021
7c0587c8
LW
2022 if (from - to >= 0) {
2023 while (len--)
2024 *to++ = *from++;
2025 }
2026 else {
2027 to += len;
2028 from += len;
2029 while (len--)
faf8582f 2030 *(--to) = *(--from);
7c0587c8 2031 }
378cc40b
LW
2032 return retval;
2033}
ffed7fef 2034#endif
378cc40b 2035
7a3f2258 2036/* this is a drop-in replacement for memset() */
fc36a67e
PP
2037#ifndef HAS_MEMSET
2038void *
5aaab254 2039Perl_my_memset(char *loc, I32 ch, I32 len)
fc36a67e 2040{
2d03de9c 2041 char * const retval = loc;
fc36a67e 2042
7918f24d
NC
2043 PERL_ARGS_ASSERT_MY_MEMSET;
2044
223f01db
KW
2045 assert(len >= 0);
2046
fc36a67e
PP
2047 while (len--)
2048 *loc++ = ch;
2049 return retval;
2050}
2051#endif
2052
7a3f2258 2053/* this is a drop-in replacement for bzero() */
7c0587c8 2054#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2055char *
5aaab254 2056Perl_my_bzero(char *loc, I32 len)
378cc40b 2057{
2d03de9c 2058 char * const retval = loc;
378cc40b 2059
7918f24d
NC
2060 PERL_ARGS_ASSERT_MY_BZERO;
2061
223f01db
KW
2062 assert(len >= 0);
2063
378cc40b
LW
2064 while (len--)
2065 *loc++ = 0;
2066 return retval;
2067}
2068#endif
7c0587c8 2069
7a3f2258 2070/* this is a drop-in replacement for memcmp() */
36477c24 2071#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2072I32
5aaab254 2073Perl_my_memcmp(const char *s1, const char *s2, I32 len)
7c0587c8 2074{
eb578fdb
KW
2075 const U8 *a = (const U8 *)s1;
2076 const U8 *b = (const U8 *)s2;
2077 I32 tmp;
7c0587c8 2078
7918f24d
NC
2079 PERL_ARGS_ASSERT_MY_MEMCMP;
2080
223f01db
KW
2081 assert(len >= 0);
2082
7c0587c8 2083 while (len--) {
27da23d5 2084 if ((tmp = *a++ - *b++))
7c0587c8
LW
2085 return tmp;
2086 }
2087 return 0;
2088}
36477c24 2089#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2090
fe14fcc3 2091#ifndef HAS_VPRINTF
d05d9be5
AD
2092/* This vsprintf replacement should generally never get used, since
2093 vsprintf was available in both System V and BSD 2.11. (There may
2094 be some cross-compilation or embedded set-ups where it is needed,
2095 however.)
2096
2097 If you encounter a problem in this function, it's probably a symptom
2098 that Configure failed to detect your system's vprintf() function.
2099 See the section on "item vsprintf" in the INSTALL file.
2100
2101 This version may compile on systems with BSD-ish <stdio.h>,
2102 but probably won't on others.
2103*/
a687059c 2104
85e6fe83 2105#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2106char *
2107#else
2108int
2109#endif
d05d9be5 2110vsprintf(char *dest, const char *pat, void *args)
a687059c
LW
2111{
2112 FILE fakebuf;
2113
d05d9be5
AD
2114#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2115 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2116 FILE_cnt(&fakebuf) = 32767;
2117#else
2118 /* These probably won't compile -- If you really need
2119 this, you'll have to figure out some other method. */
a687059c
LW
2120 fakebuf._ptr = dest;
2121 fakebuf._cnt = 32767;
d05d9be5 2122#endif
35c8bce7
LW
2123#ifndef _IOSTRG
2124#define _IOSTRG 0
2125#endif
a687059c
LW
2126 fakebuf._flag = _IOWRT|_IOSTRG;
2127 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD
2128#if defined(STDIO_PTR_LVALUE)
2129 *(FILE_ptr(&fakebuf)++) = '\0';
2130#else
2131 /* PerlIO has probably #defined away fputc, but we want it here. */
2132# ifdef fputc
2133# undef fputc /* XXX Should really restore it later */
2134# endif
2135 (void)fputc('\0', &fakebuf);
2136#endif
85e6fe83 2137#ifdef USE_CHAR_VSPRINTF
a687059c
LW
2138 return(dest);
2139#else
2140 return 0; /* perl doesn't use return value */
2141#endif
2142}
2143
fe14fcc3 2144#endif /* HAS_VPRINTF */
a687059c 2145
4a7d1889 2146PerlIO *
c9289b7b 2147Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2148{
739a0b84 2149#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
97aff369 2150 dVAR;
1f852d0d 2151 int p[2];
eb578fdb
KW
2152 I32 This, that;
2153 Pid_t pid;
1f852d0d
NIS
2154 SV *sv;
2155 I32 did_pipes = 0;
2156 int pp[2];
2157
7918f24d
NC
2158 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2159
1f852d0d
NIS
2160 PERL_FLUSHALL_FOR_CHILD;
2161 This = (*mode == 'w');
2162 that = !This;
284167a5 2163 if (TAINTING_get) {
1f852d0d
NIS
2164 taint_env();
2165 taint_proper("Insecure %s%s", "EXEC");
2166 }
2167 if (PerlProc_pipe(p) < 0)
4608196e 2168 return NULL;
1f852d0d
NIS
2169 /* Try for another pipe pair for error return */
2170 if (PerlProc_pipe(pp) >= 0)
2171 did_pipes = 1;
52e18b1f 2172 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS
2173 if (errno != EAGAIN) {
2174 PerlLIO_close(p[This]);
4e6dfe71 2175 PerlLIO_close(p[that]);
1f852d0d
NIS
2176 if (did_pipes) {
2177 PerlLIO_close(pp[0]);
2178 PerlLIO_close(pp[1]);
2179 }
4608196e 2180 return NULL;
1f852d0d 2181 }
a2a5de95 2182 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
1f852d0d
NIS
2183 sleep(5);
2184 }
2185 if (pid == 0) {
2186 /* Child */
1f852d0d
NIS
2187#undef THIS
2188#undef THAT
2189#define THIS that
2190#define THAT This
1f852d0d
NIS
2191 /* Close parent's end of error status pipe (if any) */
2192 if (did_pipes) {
2193 PerlLIO_close(pp[0]);
2194#if defined(HAS_FCNTL) && defined(F_SETFD)
2195 /* Close error pipe automatically if exec works */
2196 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2197#endif
2198 }
2199 /* Now dup our end of _the_ pipe to right position */
2200 if (p[THIS] != (*mode == 'r')) {
2201 PerlLIO_dup2(p[THIS], *mode == 'r');
2202 PerlLIO_close(p[THIS]);
4e6dfe71
GS
2203 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2204 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2205 }
4e6dfe71
GS
2206 else
2207 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS
2208#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2209 /* No automatic close - do it by hand */
b7953727
JH
2210# ifndef NOFILE
2211# define NOFILE 20
2212# endif
a080fe3d
NIS
2213 {
2214 int fd;
2215
2216 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2217 if (fd != pp[1])
a080fe3d
NIS
2218 PerlLIO_close(fd);
2219 }
1f852d0d
NIS
2220 }
2221#endif
a0714e2c 2222 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS
2223 PerlProc__exit(1);
2224#undef THIS
2225#undef THAT
2226 }
2227 /* Parent */
52e18b1f 2228 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS
2229 if (did_pipes)
2230 PerlLIO_close(pp[1]);
2231 /* Keep the lower of the two fd numbers */
2232 if (p[that] < p[This]) {
2233 PerlLIO_dup2(p[This], p[that]);
2234 PerlLIO_close(p[This]);
2235 p[This] = p[that];
2236 }
4e6dfe71
GS
2237 else
2238 PerlLIO_close(p[that]); /* close child's end of pipe */
2239
1f852d0d 2240 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2241 SvUPGRADE(sv,SVt_IV);
45977657 2242 SvIV_set(sv, pid);
1f852d0d
NIS
2243 PL_forkprocess = pid;
2244 /* If we managed to get status pipe check for exec fail */
2245 if (did_pipes && pid > 0) {
2246 int errkid;
bb7a0f54
MHM
2247 unsigned n = 0;
2248 SSize_t n1;
1f852d0d
NIS
2249
2250 while (n < sizeof(int)) {
2251 n1 = PerlLIO_read(pp[0],
2252 (void*)(((char*)&errkid)+n),
2253 (sizeof(int)) - n);
2254 if (n1 <= 0)
2255 break;
2256 n += n1;
2257 }
2258 PerlLIO_close(pp[0]);
2259 did_pipes = 0;
2260 if (n) { /* Error */
2261 int pid2, status;
8c51524e 2262 PerlLIO_close(p[This]);
1f852d0d 2263 if (n != sizeof(int))
5637ef5b 2264 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
1f852d0d
NIS
2265 do {
2266 pid2 = wait4pid(pid, &status, 0);
2267 } while (pid2 == -1 && errno == EINTR);
2268 errno = errkid; /* Propagate errno from kid */
4608196e 2269 return NULL;
1f852d0d
NIS
2270 }
2271 }
2272 if (did_pipes)
2273 PerlLIO_close(pp[0]);
2274 return PerlIO_fdopen(p[This], mode);
2275#else
9d419b5f 2276# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2277 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2278# else
4a7d1889
NIS
2279 Perl_croak(aTHX_ "List form of piped open not implemented");
2280 return (PerlIO *) NULL;
9d419b5f 2281# endif
1f852d0d 2282#endif
4a7d1889
NIS
2283}
2284
5f05dabc 2285 /* VMS' my_popen() is in VMS.c, same with OS/2. */
739a0b84 2286#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
760ac839 2287PerlIO *
3dd43144 2288Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2289{
97aff369 2290 dVAR;
a687059c 2291 int p[2];
eb578fdb
KW
2292 I32 This, that;
2293 Pid_t pid;
79072805 2294 SV *sv;
bfce84ec 2295 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ
2296 I32 did_pipes = 0;
2297 int pp[2];
a687059c 2298
7918f24d
NC
2299 PERL_ARGS_ASSERT_MY_POPEN;
2300
45bc9206 2301 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ
2302#ifdef OS2
2303 if (doexec) {
23da6c43 2304 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2305 }
a1d180c4 2306#endif
8ac85365
NIS
2307 This = (*mode == 'w');
2308 that = !This;
284167a5 2309 if (doexec && TAINTING_get) {
bbce6d69
PP
2310 taint_env();
2311 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2312 }
c2267164 2313 if (PerlProc_pipe(p) < 0)
4608196e 2314 return NULL;
e446cec8
IZ
2315 if (doexec && PerlProc_pipe(pp) >= 0)
2316 did_pipes = 1;
52e18b1f 2317 while ((pid = PerlProc_fork()) < 0) {
a687059c 2318 if (errno != EAGAIN) {
6ad3d225 2319 PerlLIO_close(p[This]);
b5ac89c3 2320 PerlLIO_close(p[that]);
e446cec8
IZ
2321 if (did_pipes) {
2322 PerlLIO_close(pp[0]);
2323 PerlLIO_close(pp[1]);
2324 }
a687059c 2325 if (!doexec)
b3647a36 2326 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
4608196e 2327 return NULL;
a687059c 2328 }
a2a5de95 2329 Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
a687059c
LW
2330 sleep(5);
2331 }
2332 if (pid == 0) {
79072805 2333
30ac6d9b
GS
2334#undef THIS
2335#undef THAT
a687059c 2336#define THIS that
8ac85365 2337#define THAT This
e446cec8
IZ
2338 if (did_pipes) {
2339 PerlLIO_close(pp[0]);
2340#if defined(HAS_FCNTL) && defined(F_SETFD)
2341 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2342#endif
2343 }
a687059c 2344 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS
2345 PerlLIO_dup2(p[THIS], *mode == 'r');
2346 PerlLIO_close(p[THIS]);
b5ac89c3
NIS
2347 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2348 PerlLIO_close(p[THAT]);
a687059c 2349 }
b5ac89c3
NIS
2350 else
2351 PerlLIO_close(p[THAT]);
4435c477 2352#ifndef OS2
a687059c 2353 if (doexec) {
a0d0e21e 2354#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
2355#ifndef NOFILE
2356#define NOFILE 20
2357#endif
a080fe3d 2358 {
3aed30dc 2359 int fd;
a080fe3d
NIS
2360
2361 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2362 if (fd != pp[1])
3aed30dc 2363 PerlLIO_close(fd);
a080fe3d 2364 }
ae986130 2365#endif
a080fe3d
NIS
2366 /* may or may not use the shell */
2367 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2368 PerlProc__exit(1);
a687059c 2369 }
4435c477 2370#endif /* defined OS2 */
713cef20
IZ
2371
2372#ifdef PERLIO_USING_CRLF
2373 /* Since we circumvent IO layers when we manipulate low-level
2374 filedescriptors directly, need to manually switch to the
2375 default, binary, low-level mode; see PerlIOBuf_open(). */
2376 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2377#endif
3280af22 2378 PL_forkprocess = 0;
ca0c25f6 2379#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2380 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2381#endif
4608196e 2382 return NULL;
a687059c
LW
2383#undef THIS
2384#undef THAT
2385 }
b5ac89c3 2386 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ
2387 if (did_pipes)
2388 PerlLIO_close(pp[1]);
8ac85365 2389 if (p[that] < p[This]) {
6ad3d225
GS
2390 PerlLIO_dup2(p[This], p[that]);
2391 PerlLIO_close(p[This]);
8ac85365 2392 p[This] = p[that];
62b28dd9 2393 }
b5ac89c3
NIS
2394 else
2395 PerlLIO_close(p[that]);
2396
3280af22 2397 sv = *av_fetch(PL_fdpid,p[This],TRUE);
862a34c6 2398 SvUPGRADE(sv,SVt_IV);
45977657 2399 SvIV_set(sv, pid);
3280af22 2400 PL_forkprocess = pid;
e446cec8
IZ
2401 if (did_pipes && pid > 0) {
2402 int errkid;
bb7a0f54
MHM
2403 unsigned n = 0;
2404 SSize_t n1;
e446cec8
IZ
2405
2406 while (n < sizeof(int)) {
2407 n1 = PerlLIO_read(pp[0],
2408 (void*)(((char*)&errkid)+n),
2409 (sizeof(int)) - n);
2410 if (n1 <= 0)
2411 break;
2412 n += n1;
2413 }
2f96c702
IZ
2414 PerlLIO_close(pp[0]);
2415 did_pipes = 0;
e446cec8 2416 if (n) { /* Error */
faa466a7 2417 int pid2, status;
8c51524e 2418 PerlLIO_close(p[This]);
e446cec8 2419 if (n != sizeof(int))
5637ef5b 2420 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
faa466a7
RG
2421 do {
2422 pid2 = wait4pid(pid, &status, 0);
2423 } while (pid2 == -1 && errno == EINTR);
e446cec8 2424 errno = errkid; /* Propagate errno from kid */
4608196e 2425 return NULL;
e446cec8
IZ
2426 }
2427 }
2428 if (did_pipes)
2429 PerlLIO_close(pp[0]);
8ac85365 2430 return PerlIO_fdopen(p[This], mode);
a687059c 2431}
7c0587c8 2432#else
2b96b0a5
JH
2433#if defined(DJGPP)
2434FILE *djgpp_popen();
2435PerlIO *
cef6ea9d 2436Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH
2437{
2438 PERL_FLUSHALL_FOR_CHILD;
2439 /* Call system's popen() to get a FILE *, then import it.
2440 used 0 for 2nd parameter to PerlIO_importFILE;
2441 apparently not used
2442 */
2443 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2444}
9c12f1e5
RGS
2445#else
2446#if defined(__LIBCATAMOUNT__)
2447PerlIO *
2448Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2449{
2450 return NULL;
2451}
2452#endif
2b96b0a5 2453#endif
7c0587c8
LW
2454
2455#endif /* !DOSISH */
a687059c 2456
52e18b1f
GS
2457/* this is called in parent before the fork() */
2458void
2459Perl_atfork_lock(void)
2460{
27da23d5 2461 dVAR;
3db8f154 2462#if defined(USE_ITHREADS)
52e18b1f 2463 /* locks must be held in locking order (if any) */
4da80956
P
2464# ifdef USE_PERLIO
2465 MUTEX_LOCK(&PL_perlio_mutex);
2466# endif
52e18b1f
GS
2467# ifdef MYMALLOC
2468 MUTEX_LOCK(&PL_malloc_mutex);
2469# endif
2470 OP_REFCNT_LOCK;
2471#endif
2472}
2473
2474/* this is called in both parent and child after the fork() */
2475void
2476Perl_atfork_unlock(void)
2477{
27da23d5 2478 dVAR;
3db8f154 2479#if defined(USE_ITHREADS)
52e18b1f 2480 /* locks must be released in same order as in atfork_lock() */
4da80956
P
2481# ifdef USE_PERLIO
2482 MUTEX_UNLOCK(&PL_perlio_mutex);
2483# endif
52e18b1f
GS
2484# ifdef MYMALLOC
2485 MUTEX_UNLOCK(&PL_malloc_mutex);
2486# endif
2487 OP_REFCNT_UNLOCK;
2488#endif
2489}
2490
2491Pid_t
2492Perl_my_fork(void)
2493{
2494#if defined(HAS_FORK)
2495 Pid_t pid;
3db8f154 2496#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS
2497 atfork_lock();
2498 pid = fork();
2499 atfork_unlock();
2500#else
2501 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2502 * handlers elsewhere in the code */
2503 pid = fork();
2504#endif
2505 return pid;
2506#else
2507 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2508 Perl_croak_nocontext("fork() not available");
b961a566 2509 return 0;
52e18b1f
GS
2510#endif /* HAS_FORK */
2511}
2512
fe14fcc3 2513#ifndef HAS_DUP2
fec02dd3 2514int
ba106d47 2515dup2(int oldfd, int newfd)
a687059c 2516{
a0d0e21e 2517#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
2518 if (oldfd == newfd)
2519 return oldfd;
6ad3d225 2520 PerlLIO_close(newfd);
fec02dd3 2521 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2522#else
fc36a67e
PP
2523#define DUP2_MAX_FDS 256
2524 int fdtmp[DUP2_MAX_FDS];
79072805 2525 I32 fdx = 0;
ae986130
LW
2526 int fd;
2527
fe14fcc3 2528 if (oldfd == newfd)
fec02dd3 2529 return oldfd;
6ad3d225 2530 PerlLIO_close(newfd);
fc36a67e 2531 /* good enough for low fd's... */
6ad3d225 2532 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2533 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2534 PerlLIO_close(fd);
fc36a67e
PP
2535 fd = -1;
2536 break;
2537 }
ae986130 2538 fdtmp[fdx++] = fd;
fc36a67e 2539 }
ae986130 2540 while (fdx > 0)
6ad3d225 2541 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2542 return fd;
62b28dd9 2543#endif
a687059c
LW
2544}
2545#endif
2546
64ca3a65 2547#ifndef PERL_MICRO
ff68c719
PP
2548#ifdef HAS_SIGACTION
2549
2550Sighandler_t
864dbfa3 2551Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2552{
27da23d5 2553 dVAR;
ff68c719
PP
2554 struct sigaction act, oact;
2555
a10b1e10
JH
2556#ifdef USE_ITHREADS
2557 /* only "parent" interpreter can diddle signals */
2558 if (PL_curinterp != aTHX)
8aad04aa 2559 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2560#endif
2561
8aad04aa 2562 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2563 sigemptyset(&act.sa_mask);
2564 act.sa_flags = 0;
2565#ifdef SA_RESTART
4ffa73a3
JH
2566 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2567 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2568#endif
358837b8 2569#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2570 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2571 act.sa_flags |= SA_NOCLDWAIT;
2572#endif
ff68c719 2573 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2574 return (Sighandler_t) SIG_ERR;
ff68c719 2575 else
8aad04aa 2576 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2577}
2578
2579Sighandler_t
864dbfa3 2580Perl_rsignal_state(pTHX_ int signo)
ff68c719
PP
2581{
2582 struct sigaction oact;
96a5add6 2583 PERL_UNUSED_CONTEXT;
ff68c719
PP
2584
2585 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2586 return (Sighandler_t) SIG_ERR;
ff68c719 2587 else
8aad04aa 2588 return (Sighandler_t) oact.sa_handler;
ff68c719
PP
2589}
2590
2591int
864dbfa3 2592Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2593{
27da23d5 2594 dVAR;
ff68c719
PP
2595 struct sigaction act;
2596
7918f24d
NC
2597 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2598
a10b1e10
JH
2599#ifdef USE_ITHREADS
2600 /* only "parent" interpreter can diddle signals */
2601 if (PL_curinterp != aTHX)
2602 return -1;
2603#endif
2604
8aad04aa 2605 act.sa_handler = (void(*)(int))handler;
ff68c719
PP
2606 sigemptyset(&act.sa_mask);
2607 act.sa_flags = 0;
2608#ifdef SA_RESTART
4ffa73a3
JH
2609 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2610 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2611#endif
36b5d377 2612#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2613 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS
2614 act.sa_flags |= SA_NOCLDWAIT;
2615#endif
ff68c719
PP
2616 return sigaction(signo, &act, save);
2617}
2618
2619int
864dbfa3 2620Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2621{
27da23d5 2622 dVAR;
a10b1e10
JH
2623#ifdef USE_ITHREADS
2624 /* only "parent" interpreter can diddle signals */
2625 if (PL_curinterp != aTHX)
2626 return -1;
2627#endif
2628
ff68c719
PP
2629 return sigaction(signo, save, (struct sigaction *)NULL);
2630}
2631
2632#else /* !HAS_SIGACTION */
2633
2634Sighandler_t
864dbfa3 2635Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2636{
39f1703b 2637#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2638 /* only "parent" interpreter can diddle signals */
2639 if (PL_curinterp != aTHX)
8aad04aa 2640 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2641#endif
2642
6ad3d225 2643 return PerlProc_signal(signo, handler);
ff68c719
PP
2644}
2645
fabdb6c0 2646static Signal_t
4e35701f 2647sig_trap(int signo)
ff68c719 2648{
27da23d5
JH
2649 dVAR;
2650 PL_sig_trapped++;
ff68c719
PP
2651}
2652
2653Sighandler_t
864dbfa3 2654Perl_rsignal_state(pTHX_ int signo)
ff68c719 2655{
27da23d5 2656 dVAR;
ff68c719
PP
2657 Sighandler_t oldsig;
2658
39f1703b 2659#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2660 /* only "parent" interpreter can diddle signals */
2661 if (PL_curinterp != aTHX)
8aad04aa 2662 return (Sighandler_t) SIG_ERR;
a10b1e10
JH
2663#endif
2664
27da23d5 2665 PL_sig_trapped = 0;
6ad3d225
GS
2666 oldsig = PerlProc_signal(signo, sig_trap);
2667 PerlProc_signal(signo, oldsig);
27da23d5 2668 if (PL_sig_trapped)
3aed30dc 2669 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719
PP
2670 return oldsig;
2671}
2672
2673int
864dbfa3 2674Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2675{
39f1703b 2676#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2677 /* only "parent" interpreter can diddle signals */
2678 if (PL_curinterp != aTHX)
2679 return -1;
2680#endif
6ad3d225 2681 *save = PerlProc_signal(signo, handler);
8aad04aa 2682 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2683}
2684
2685int
864dbfa3 2686Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2687{
39f1703b 2688#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH
2689 /* only "parent" interpreter can diddle signals */
2690 if (PL_curinterp != aTHX)
2691 return -1;
2692#endif
8aad04aa 2693 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719
PP
2694}
2695
2696#endif /* !HAS_SIGACTION */
64ca3a65 2697#endif /* !PERL_MICRO */
ff68c719 2698
5f05dabc 2699 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
739a0b84 2700#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
79072805 2701I32
864dbfa3 2702Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2703{
97aff369 2704 dVAR;
a687059c 2705 int status;
a0d0e21e 2706 SV **svp;
d8a83dd3 2707 Pid_t pid;
2e0cfa16 2708 Pid_t pid2 = 0;
03136e13 2709 bool close_failed;
4ee39169 2710 dSAVEDERRNO;
2e0cfa16 2711 const int fd = PerlIO_fileno(ptr);
e9d373c4
TC
2712 bool should_wait;
2713
2714 svp = av_fetch(PL_fdpid,fd,TRUE);
2715 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2716 SvREFCNT_dec(*svp);
2717 *svp = NULL;
2e0cfa16 2718
b6ae43b7 2719#ifdef USE_PERLIO
2e0cfa16
FC
2720 /* Find out whether the refcount is low enough for us to wait for the
2721 child proc without blocking. */
e9d373c4 2722 should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
b6ae43b7 2723#else
e9d373c4 2724 should_wait = pid > 0;
b6ae43b7 2725#endif
a687059c 2726
ddcf38b7
IZ
2727#ifdef OS2
2728 if (pid == -1) { /* Opened by popen. */
2729 return my_syspclose(ptr);
2730 }
a1d180c4 2731#endif
f1618b10
CS
2732 close_failed = (PerlIO_close(ptr) == EOF);
2733 SAVE_ERRNO;
2e0cfa16 2734 if (should_wait) do {
1d3434b8
GS
2735 pid2 = wait4pid(pid, &status, 0);
2736 } while (pid2 == -1 && errno == EINTR);
03136e13 2737 if (close_failed) {
4ee39169 2738 RESTORE_ERRNO;
03136e13
CS
2739 return -1;
2740 }
2e0cfa16
FC
2741 return(
2742 should_wait
2743 ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2744 : 0
2745 );
20188a90 2746}
9c12f1e5
RGS
2747#else
2748#if defined(__LIBCATAMOUNT__)
2749I32
2750Perl_my_pclose(pTHX_ PerlIO *ptr)
2751{
2752 return -1;
2753}
2754#endif
4633a7c4
LW
2755#endif /* !DOSISH */
2756
e37778c2 2757#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
79072805 2758I32
d8a83dd3 2759Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2760{
97aff369 2761 dVAR;
27da23d5 2762 I32 result = 0;
7918f24d 2763 PERL_ARGS_ASSERT_WAIT4PID;
ca0c25f6 2764#ifdef PERL_USES_PL_PIDSTATUS
d4c02743
TC
2765 if (!pid) {
2766 /* PERL_USES_PL_PIDSTATUS is only defined when neither
2767 waitpid() nor wait4() is available, or on OS/2, which
2768 doesn't appear to support waiting for a progress group
2769 member, so we can only treat a 0 pid as an unknown child.
2770 */
2771 errno = ECHILD;
2772 return -1;
2773 }
b7953727 2774 {
3aed30dc 2775 if (pid > 0) {
12072db5
NC
2776 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2777 pid, rather than a string form. */
c4420975 2778 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS
2779 if (svp && *svp != &PL_sv_undef) {
2780 *statusp = SvIVX(*svp);
12072db5
NC
2781 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2782 G_DISCARD);
3aed30dc
HS
2783 return pid;
2784 }
2785 }
2786 else {
2787 HE *entry;
2788
2789 hv_iterinit(PL_pidstatus);
2790 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2791 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2792 I32 len;
0bcc34c2 2793 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2794
12072db5
NC
2795 assert (len == sizeof(Pid_t));
2796 memcpy((char *)&pid, spid, len);
3aed30dc 2797 *statusp = SvIVX(sv);
7b9a3241
NC
2798 /* The hash iterator is currently on this entry, so simply
2799 calling hv_delete would trigger the lazy delete, which on
2800 aggregate does more work, beacuse next call to hv_iterinit()
2801 would spot the flag, and have to call the delete routine,
2802 while in the meantime any new entries can't re-use that
2803 memory. */
2804 hv_iterinit(PL_pidstatus);
7ea75b61 2805 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS
2806 return pid;
2807 }
20188a90
LW
2808 }
2809 }
68a29c53 2810#endif
79072805 2811#ifdef HAS_WAITPID
367f3c24
IZ
2812# ifdef HAS_WAITPID_RUNTIME
2813 if (!HAS_WAITPID_RUNTIME)
2814 goto hard_way;
2815# endif
cddd4526 2816 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2817 goto finish;
367f3c24
IZ
2818#endif
2819#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
d4c02743 2820 result = wait4(pid,statusp,flags,NULL);
dfcfdb64 2821 goto finish;
367f3c24 2822#endif
ca0c25f6 2823#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2824#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2825 hard_way:
27da23d5 2826#endif
a0d0e21e 2827 {
a0d0e21e 2828 if (flags)
cea2e8a9 2829 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2830 else {
76e3520e 2831 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW
2832 pidgone(result,*statusp);
2833 if (result < 0)
2834 *statusp = -1;
2835 }
a687059c
LW
2836 }
2837#endif
27da23d5 2838#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2839 finish:
27da23d5 2840#endif
cddd4526
NIS
2841 if (result < 0 && errno == EINTR) {
2842 PERL_ASYNC_CHECK();
48dbb59e 2843 errno = EINTR; /* reset in case a signal handler changed $! */
cddd4526
NIS
2844 }
2845 return result;
a687059c 2846}
2986a63f 2847#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2848
ca0c25f6 2849#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2850void
ed4173ef 2851S_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2852{
eb578fdb 2853 SV *sv;
a687059c 2854
12072db5 2855 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2856 SvUPGRADE(sv,SVt_IV);
45977657 2857 SvIV_set(sv, status);
20188a90 2858 return;
a687059c 2859}
ca0c25f6 2860#endif
a687059c 2861
739a0b84 2862#if defined(OS2)
7c0587c8 2863int pclose();
ddcf38b7
IZ
2864#ifdef HAS_FORK
2865int /* Cannot prototype with I32
2866 in os2ish.h. */
ba106d47 2867my_syspclose(PerlIO *ptr)
ddcf38b7 2868#else
79072805 2869I32
864dbfa3 2870Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2871#endif
a687059c 2872{
760ac839 2873 /* Needs work for PerlIO ! */
c4420975 2874 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 2875 const I32 result = pclose(f);
2b96b0a5
JH
2876 PerlIO_releaseFILE(ptr,f);
2877 return result;
2878}
2879#endif
2880
933fea7f 2881#if defined(DJGPP)
2b96b0a5
JH
2882int djgpp_pclose();
2883I32
2884Perl_my_pclose(pTHX_ PerlIO *ptr)
2885{
2886 /* Needs work for PerlIO ! */
c4420975 2887 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 2888 I32 result = djgpp_pclose(f);
933fea7f 2889 result = (result << 8) & 0xff00;
760ac839
LW
2890 PerlIO_releaseFILE(ptr,f);
2891 return result;
a687059c 2892}
7c0587c8 2893#endif
9f68db38 2894
16fa5c11 2895#define PERL_REPEATCPY_LINEAR 4
9f68db38 2896void
5aaab254 2897Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
9f68db38 2898{
7918f24d
NC
2899 PERL_ARGS_ASSERT_REPEATCPY;
2900
223f01db
KW
2901 assert(len >= 0);
2902
2709980d 2903 if (count < 0)
d1decf2b 2904 croak_memory_wrap();
2709980d 2905
16fa5c11
VP
2906 if (len == 1)
2907 memset(to, *from, count);
2908 else if (count) {
eb578fdb 2909 char *p = to;
26e1303d 2910 IV items, linear, half;
16fa5c11
VP
2911
2912 linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2913 for (items = 0; items < linear; ++items) {
eb578fdb 2914 const char *q = from;
26e1303d 2915 IV todo;
16fa5c11
VP
2916 for (todo = len; todo > 0; todo--)
2917 *p++ = *q++;
2918 }
2919
2920 half = count / 2;
2921 while (items <= half) {
26e1303d 2922 IV size = items * len;
16fa5c11
VP
2923 memcpy(p, to, size);
2924 p += size;
2925 items *= 2;
9f68db38 2926 }
16fa5c11
VP
2927
2928 if (count > items)
2929 memcpy(p, to, (count - items) * len);
9f68db38
LW
2930 }
2931}
0f85fab0 2932
fe14fcc3 2933#ifndef HAS_RENAME
79072805 2934I32
4373e329 2935Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 2936{
93a17b20
LW
2937 char *fa = strrchr(a,'/');
2938 char *fb = strrchr(b,'/');
c623ac67
GS
2939 Stat_t tmpstatbuf1;
2940 Stat_t tmpstatbuf2;
c4420975 2941 SV * const tmpsv = sv_newmortal();
62b28dd9 2942
7918f24d
NC
2943 PERL_ARGS_ASSERT_SAME_DIRENT;
2944
62b28dd9
LW
2945 if (fa)
2946 fa++;
2947 else
2948 fa = a;
2949 if (fb)
2950 fb++;
2951 else
2952 fb = b;
2953 if (strNE(a,b))
2954 return FALSE;
2955 if (fa == a)
76f68e9b 2956 sv_setpvs(tmpsv, ".");
62b28dd9 2957 else
46fc3d4c 2958 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 2959 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
2960 return FALSE;
2961 if (fb == b)
76f68e9b 2962 sv_setpvs(tmpsv, ".");
62b28dd9 2963 else
46fc3d4c 2964 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 2965 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
2966 return FALSE;
2967 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2968 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2969}
fe14fcc3
LW
2970#endif /* !HAS_RENAME */
2971
491527d0 2972char*
7f315aed
NC
2973Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2974 const char *const *const search_ext, I32 flags)
491527d0 2975{
97aff369 2976 dVAR;
bd61b366
SS
2977 const char *xfound = NULL;
2978 char *xfailed = NULL;
0f31cffe 2979 char tmpbuf[MAXPATHLEN];
eb578fdb 2980 char *s;
5f74f29c 2981 I32 len = 0;
491527d0 2982 int retval;
39a02377 2983 char *bufend;
7c458fae 2984#if defined(DOSISH) && !defined(OS2)
491527d0
GS
2985# define SEARCH_EXTS ".bat", ".cmd", NULL
2986# define MAX_EXT_LEN 4
2987#endif
2988#ifdef OS2
2989# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2990# define MAX_EXT_LEN 4
2991#endif
2992#ifdef VMS
2993# define SEARCH_EXTS ".pl", ".com", NULL
2994# define MAX_EXT_LEN 4
2995#endif
2996 /* additional extensions to try in each dir if scriptname not found */
2997#ifdef SEARCH_EXTS
0bcc34c2 2998 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 2999 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3000 int extidx = 0, i = 0;
bd61b366 3001 const char *curext = NULL;
491527d0 3002#else
53c1dcc0 3003 PERL_UNUSED_ARG(search_ext);
491527d0
GS
3004# define MAX_EXT_LEN 0
3005#endif
3006
7918f24d
NC
3007 PERL_ARGS_ASSERT_FIND_SCRIPT;
3008
491527d0
GS
3009 /*
3010 * If dosearch is true and if scriptname does not contain path
3011 * delimiters, search the PATH for scriptname.
3012 *
3013 * If SEARCH_EXTS is also defined, will look for each
3014 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3015 * while searching the PATH.
3016 *
3017 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3018 * proceeds as follows:
3019 * If DOSISH or VMSISH:
3020 * + look for ./scriptname{,.foo,.bar}
3021 * + search the PATH for scriptname{,.foo,.bar}
3022 *
3023 * If !DOSISH:
3024 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3025 * this will not look in '.' if it's not in the PATH)
3026 */
84486fc6 3027 tmpbuf[0] = '\0';
491527d0
GS
3028
3029#ifdef VMS
3030# ifdef ALWAYS_DEFTYPES
3031 len = strlen(scriptname);
3032 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3033 int idx = 0, deftypes = 1;
491527d0
GS
3034 bool seen_dot = 1;
3035
bd61b366 3036 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3037# else
3038 if (dosearch) {
c4420975 3039 int idx = 0, deftypes = 1;
491527d0
GS
3040 bool seen_dot = 1;
3041
bd61b366 3042 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS
3043# endif
3044 /* The first time through, just add SEARCH_EXTS to whatever we
3045 * already have, so we can check for default file types. */
3046 while (deftypes ||
84486fc6 3047 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS
3048 {
3049 if (deftypes) {
3050 deftypes = 0;
84486fc6 3051 *tmpbuf = '\0';
491527d0 3052 }
84486fc6
GS
3053 if ((strlen(tmpbuf) + strlen(scriptname)
3054 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3055 continue; /* don't search dir with too-long name */
6fca0082 3056 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS
3057#else /* !VMS */
3058
3059#ifdef DOSISH
3060 if (strEQ(scriptname, "-"))
3061 dosearch = 0;
3062 if (dosearch) { /* Look in '.' first. */
fe2774ed 3063 const char *cur = scriptname;
491527d0
GS
3064#ifdef SEARCH_EXTS
3065 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3066 while (ext[i])
3067 if (strEQ(ext[i++],curext)) {
3068 extidx = -1; /* already has an ext */
3069 break;
3070 }
3071 do {
3072#endif
3073 DEBUG_p(PerlIO_printf(Perl_debug_log,
3074 "Looking for %s\n",cur));
017f25f1
IZ
3075 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3076 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS
3077 dosearch = 0;
3078 scriptname = cur;
3079#ifdef SEARCH_EXTS
3080 break;
3081#endif
3082 }
3083#ifdef SEARCH_EXTS
3084 if (cur == scriptname) {
3085 len = strlen(scriptname);
84486fc6 3086 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3087 break;
9e4425f7
SH
3088 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3089 cur = tmpbuf;
491527d0
GS
3090 }
3091 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3092 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS
3093#endif
3094 }
3095#endif
3096
3097 if (dosearch && !strchr(scriptname, '/')
3098#ifdef DOSISH
3099 && !strchr(scriptname, '\\')
3100#endif
cd39f2b6 3101 && (s = PerlEnv_getenv("PATH")))
cd39f2b6 3102 {
491527d0 3103 bool seen_dot = 0;
92f0c265 3104
39a02377
DM
3105 bufend = s + strlen(s);
3106 while (s < bufend) {
7c458fae 3107# ifdef DOSISH
491527d0 3108 for (len = 0; *s
491527d0 3109 && *s != ';'; len++, s++) {
84486fc6
GS
3110 if (len < sizeof tmpbuf)
3111 tmpbuf[len] = *s;
491527d0 3112 }
84486fc6
GS
3113 if (len < sizeof tmpbuf)
3114 tmpbuf[len] = '\0';
7c458fae 3115# else
39a02377 3116 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS
3117 ':',
3118 &len);
7c458fae 3119# endif
39a02377 3120 if (s < bufend)
491527d0 3121 s++;
84486fc6 3122 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0
GS
3123 continue; /* don't search dir with too-long name */
3124 if (len
7c458fae 3125# ifdef DOSISH
84486fc6
GS
3126 && tmpbuf[len - 1] != '/'
3127 && tmpbuf[len - 1] != '\\'
490a0e98 3128# endif
491527d0 3129 )
84486fc6
GS
3130 tmpbuf[len++] = '/';
3131 if (len == 2 && tmpbuf[0] == '.')
491527d0 3132 seen_dot = 1;
28f0d0ec 3133 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS
3134#endif /* !VMS */
3135
3136#ifdef SEARCH_EXTS
84486fc6 3137 len = strlen(tmpbuf);
491527d0
GS
3138 if (extidx > 0) /* reset after previous loop */
3139 extidx = 0;
3140 do {
3141#endif
84486fc6 3142 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3143 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ
3144 if (S_ISDIR(PL_statbuf.st_mode)) {
3145 retval = -1;
3146 }
491527d0
GS
3147#ifdef SEARCH_EXTS
3148 } while ( retval < 0 /* not there */
3149 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3150 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS
3151 );
3152#endif
3153 if (retval < 0)
3154 continue;
3280af22
NIS
3155 if (S_ISREG(PL_statbuf.st_mode)
3156 && cando(S_IRUSR,TRUE,&PL_statbuf)
e37778c2 3157#if !defined(DOSISH)
3280af22 3158 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS
3159#endif
3160 )
3161 {
3aed30dc 3162 xfound = tmpbuf; /* bingo! */
491527d0
GS
3163 break;
3164 }
3165 if (!xfailed)
84486fc6 3166 xfailed = savepv(tmpbuf);
491527d0
GS
3167 }
3168#ifndef DOSISH
017f25f1 3169 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3170 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3171 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS
3172#endif
3173 seen_dot = 1; /* Disable message. */
9ccb31f9
GS
3174 if (!xfound) {
3175 if (flags & 1) { /* do or die? */
6ad282c7 3176 /* diag_listed_as: Can't execute %s */
3aed30dc 3177 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS
3178 (xfailed ? "execute" : "find"),
3179 (xfailed ? xfailed : scriptname),
3180 (xfailed ? "" : " on PATH"),
3181 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3182 }
bd61b366 3183 scriptname = NULL;
9ccb31f9 3184 }
43c5f42d 3185 Safefree(xfailed);
491527d0
GS
3186 scriptname = xfound;
3187 }
bd61b366 3188 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS
3189}
3190
ba869deb
GS
3191#ifndef PERL_GET_CONTEXT_DEFINED
3192
3193void *
3194Perl_get_context(void)
3195{
27da23d5 3196 dVAR;
3db8f154 3197#if defined(USE_ITHREADS)
ba869deb
GS
3198# ifdef OLD_PTHREADS_API
3199 pthread_addr_t t;
5637ef5b
NC
3200 int error = pthread_getspecific(PL_thr_key, &t)
3201 if (error)
3202 Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
ba869deb
GS
3203 return (void*)t;
3204# else
bce813aa 3205# ifdef I_MACH_CTHREADS
8b8b35ab 3206 return (void*)cthread_data(cthread_self());
bce813aa 3207# else
8b8b35ab
JH
3208 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3209# endif
c44d3fdb 3210# endif
ba869deb
GS
3211#else
3212 return (void*)NULL;
3213#endif
3214}
3215
3216void
3217Perl_set_context(void *t)
3218{
8772537c 3219 dVAR;
7918f24d 3220 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3221#if defined(USE_ITHREADS)
c44d3fdb
GS
3222# ifdef I_MACH_CTHREADS
3223 cthread_set_data(cthread_self(), t);
3224# else
5637ef5b
NC
3225 {
3226 const int error = pthread_setspecific(PL_thr_key, t);
3227 if (error)
3228 Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3229 }
c44d3fdb 3230# endif
b464bac0 3231#else
8772537c 3232 PERL_UNUSED_ARG(t);
ba869deb
GS
3233#endif
3234}
3235
3236#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3237
27da23d5 3238#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3239struct perl_vars *
864dbfa3 3240Perl_GetVars(pTHX)
22239a37 3241{
533c011a 3242 return &PL_Vars;
22239a37 3243}
31fb1209
NIS
3244#endif
3245
1cb0ed9b 3246char **
864dbfa3 3247Perl_get_op_names(pTHX)
31fb1209 3248{
96a5add6
AL
3249 PERL_UNUSED_CONTEXT;
3250 return (char **)PL_op_name;
31fb1209
NIS
3251}
3252
1cb0ed9b 3253char **
864dbfa3 3254Perl_get_op_descs(pTHX)
31fb1209 3255{
96a5add6
AL
3256 PERL_UNUSED_CONTEXT;
3257 return (char **)PL_op_desc;
31fb1209 3258}
9e6b2b00 3259
e1ec3a88 3260const char *
864dbfa3 3261Perl_get_no_modify(pTHX)
9e6b2b00 3262{
96a5add6
AL
3263 PERL_UNUSED_CONTEXT;
3264 return PL_no_modify;
9e6b2b00
GS
3265}
3266
3267U32 *
864dbfa3 3268Perl_get_opargs(pTHX)
9e6b2b00 3269{
96a5add6
AL
3270 PERL_UNUSED_CONTEXT;
3271 return (U32 *)PL_opargs;
9e6b2b00 3272}
51aa15f3 3273
0cb96387
GS
3274PPADDR_t*
3275Perl_get_ppaddr(pTHX)
3276{
96a5add6
AL
3277 dVAR;
3278 PERL_UNUSED_CONTEXT;
3279 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS
3280}
3281
a6c40364
GS
3282#ifndef HAS_GETENV_LEN
3283char *
bf4acbe4 3284Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3285{
8772537c 3286 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3287 PERL_UNUSED_CONTEXT;
7918f24d 3288 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS
3289 if (env_trans)
3290 *len = strlen(env_trans);
3291 return env_trans;
f675dbe5
CB
3292}
3293#endif
3294
dc9e4912
GS
3295
3296MGVTBL*
864dbfa3 3297Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3298{
96a5add6 3299 PERL_UNUSED_CONTEXT;
dc9e4912 3300
c7fdacb9
NC
3301 return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3302 ? NULL : PL_magic_vtables + vtbl_id;
dc9e4912
GS
3303}
3304
767df6a1 3305I32
864dbfa3 3306Perl_my_fflush_all(pTHX)
767df6a1 3307{
f800e14d 3308#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3309 return PerlIO_flush(NULL);
767df6a1 3310#else
8fbdfb7c 3311# if defined(HAS__FWALK)
f13a2bc0 3312 extern int fflush(FILE *);
74cac757
JH
3313 /* undocumented, unprototyped, but very useful BSDism */
3314 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3315 _fwalk(&fflush);
74cac757 3316 return 0;
8fa7f367 3317# else
8fbdfb7c 3318# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3319 long open_max = -1;
8fbdfb7c 3320# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3321 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3322# else
8fa7f367 3323# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3324 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH
3325# else
3326# ifdef FOPEN_MAX
74cac757 3327 open_max = FOPEN_MAX;
8fa7f367
JH
3328# else
3329# ifdef OPEN_MAX
74cac757 3330 open_max = OPEN_MAX;
8fa7f367
JH
3331# else
3332# ifdef _NFILE
d2201af2 3333 open_max = _NFILE;
8fa7f367
JH
3334# endif
3335# endif
74cac757 3336# endif
767df6a1
JH
3337# endif
3338# endif
767df6a1
JH
3339 if (open_max > 0) {
3340 long i;
3341 for (i = 0; i < open_max; i++)
d2201af2
AD
3342 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3343 STDIO_STREAM_ARRAY[i]._file < open_max &&
3344 STDIO_STREAM_ARRAY[i]._flag)
3345 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH
3346 return 0;
3347 }
8fbdfb7c 3348# endif
93189314 3349 SETERRNO(EBADF,RMS_IFI);
767df6a1 3350 return EOF;
74cac757 3351# endif
767df6a1
JH
3352#endif
3353}
097ee67d 3354
69282e91 3355void
45219de6 3356Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
a5390457
NC
3357{
3358 if (ckWARN(WARN_IO)) {
0223a801 3359 HEK * const name
c6e4ff34 3360 = gv && (isGV_with_GP(gv))
0223a801 3361 ? GvENAME_HEK((gv))
3b46b707 3362 : NULL;
a5390457
NC
3363 const char * const direction = have == '>' ? "out" : "in";
3364
b3c81598 3365 if (name && HEK_LEN(name))
a5390457 3366 Perl_warner(aTHX_ packWARN(WARN_IO),
0223a801 3367 "Filehandle %"HEKf" opened only for %sput",
a5390457
NC
3368 name, direction);
3369 else
3370 Perl_warner(aTHX_ packWARN(WARN_IO),
3371 "Filehandle opened only for %sput", direction);
3372 }
3373}
3374
3375void
831e4cc3 3376Perl_report_evil_fh(pTHX_ const GV *gv)
bc37a18f 3377{
65820a28 3378 const IO *io = gv ? GvIO(gv) : NULL;
831e4cc3 3379 const PERL_BITFIELD16 op = PL_op->op_type;
a5390457
NC
3380 const char *vile;
3381 I32 warn_type;
3382
65820a28 3383 if (io && IoTYPE(io) == IoTYPE_CLOSED) {
a5390457
NC
3384 vile = "closed";
3385 warn_type = WARN_CLOSED;
2dd78f96
JH
3386 }
3387 else {
a5390457
NC
3388 vile = "unopened";
3389 warn_type = WARN_UNOPENED;
3390 }
3391
3392 if (ckWARN(warn_type)) {
3b46b707 3393 SV * const name
5c5c5f45 3394 = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3b46b707 3395 sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
a5390457
NC
3396 const char * const pars =
3397 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3398 const char * const func =
3399 (const char *)
3400 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3401 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
a5390457
NC
3402 PL_op_desc[op]);
3403 const char * const type =
3404 (const char *)
65820a28 3405 (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
a5390457 3406 ? "socket" : "filehandle");
1e00d6e9 3407 const bool have_name = name && SvCUR(name);
65d99836
FC
3408 Perl_warner(aTHX_ packWARN(warn_type),
3409 "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3410 have_name ? " " : "",
3411 SVfARG(have_name ? name : &PL_sv_no));
3412 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
a5390457
NC
3413 Perl_warner(
3414 aTHX_ packWARN(warn_type),
65d99836
FC
3415 "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3416 func, pars, have_name ? " " : "",
3417 SVfARG(have_name ? name : &PL_sv_no)
a5390457 3418 );
bc37a18f 3419 }
69282e91 3420}
a926ef6b 3421
f6adc668 3422/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH
3423 * system to give us a reasonable struct to copy. This fix means that
3424 * strftime uses the tm_zone and tm_gmtoff values returned by
3425 * localtime(time()). That should give the desired result most of the
3426 * time. But probably not always!
3427 *
f6adc668
JH
3428 * This does not address tzname aspects of NETaa14816.
3429 *
e72cf795 3430 */
f6adc668 3431
61b27c87 3432#ifdef __GLIBC__
e72cf795
JH
3433# ifndef STRUCT_TM_HASZONE
3434# define STRUCT_TM_HASZONE
3435# endif
3436#endif
3437
f6adc668
JH
3438#ifdef STRUCT_TM_HASZONE /* Backward compat */
3439# ifndef HAS_TM_TM_ZONE
3440# define HAS_TM_TM_ZONE
3441# endif
3442#endif
3443
e72cf795 3444void
f1208910 3445Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3446{
f6adc668 3447#ifdef HAS_TM_TM_ZONE
e72cf795 3448 Time_t now;
1b6737cc 3449 const struct tm* my_tm;
7918f24d 3450 PERL_ARGS_ASSERT_INIT_TM;
e72cf795 3451 (void)time(&now);
82c57498 3452 my_tm = localtime(&now);
ca46b8ee
SP
3453 if (my_tm)
3454 Copy(my_tm, ptm, 1, struct tm);
1b6737cc 3455#else
7918f24d 3456 PERL_ARGS_ASSERT_INIT_TM;
1b6737cc 3457 PERL_UNUSED_ARG(ptm);
e72cf795
JH
3458#endif
3459}
3460
3461/*
3462 * mini_mktime - normalise struct tm values without the localtime()
3463 * semantics (and overhead) of mktime().
3464 */
3465void
f1208910 3466Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH
3467{
3468 int yearday;
3469 int secs;
3470 int month, mday, year, jday;
3471 int odd_cent, odd_year;
96a5add6 3472 PERL_UNUSED_CONTEXT;
e72cf795 3473
7918f24d
NC
3474 PERL_ARGS_ASSERT_MINI_MKTIME;
3475
e72cf795
JH
3476#define DAYS_PER_YEAR 365
3477#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3478#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3479#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3480#define SECS_PER_HOUR (60*60)
3481#define SECS_PER_DAY (24*SECS_PER_HOUR)
3482/* parentheses deliberately absent on these two, otherwise they don't work */
3483#define MONTH_TO_DAYS 153/5
3484#define DAYS_TO_MONTH 5/153
3485/* offset to bias by March (month 4) 1st between month/mday & year finding */
3486#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3487/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3488#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3489
3490/*
3491 * Year/day algorithm notes:
3492 *
3493 * With a suitable offset for numeric value of the month, one can find
3494 * an offset into the year by considering months to have 30.6 (153/5) days,
3495 * using integer arithmetic (i.e., with truncation). To avoid too much
3496 * messing about with leap days, we consider January and February to be
3497 * the 13th and 14th month of the previous year. After that transformation,
3498 * we need the month index we use to be high by 1 from 'normal human' usage,
3499 * so the month index values we use run from 4 through 15.
3500 *
3501 * Given that, and the rules for the Gregorian calendar (leap years are those
3502 * divisible by 4 unless also divisible by 100, when they must be divisible
3503 * by 400 instead), we can simply calculate the number of days since some
3504 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3505 * the days we derive from our month index, and adding in the day of the
3506 * month. The value used here is not adjusted for the actual origin which
3507 * it normally would use (1 January A.D. 1), since we're not exposing it.
3508 * We're only building the value so we can turn around and get the
3509 * normalised values for the year, month, day-of-month, and day-of-year.
3510 *
3511 * For going backward, we need to bias the value we're using so that we find
3512 * the right year value. (Basically, we don't want the contribution of
3513 * March 1st to the number to apply while deriving the year). Having done
3514 * that, we 'count up' the contribution to the year number by accounting for
3515 * full quadracenturies (400-year periods) with their extra leap days, plus
3516 * the contribution from full centuries (to avoid counting in the lost leap
3517 * days), plus the contribution from full quad-years (to count in the normal
3518 * leap days), plus the leftover contribution from any non-leap years.
3519 * At this point, if we were working with an actual leap day, we'll have 0
3520 * days left over. This is also true for March 1st, however. So, we have
3521 * to special-case that result, and (earlier) keep track of the 'odd'
3522 * century and year contributions. If we got 4 extra centuries in a qcent,
3523 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3524 * Otherwise, we add back in the earlier bias we removed (the 123 from
3525 * figuring in March 1st), find the month index (integer division by 30.6),
3526 * and the remainder is the day-of-month. We then have to convert back to
3527 * 'real' months (including fixing January and February from being 14/15 in
3528 * the previous year to being in the proper year). After that, to get
3529 * tm_yday, we work with the normalised year and get a new yearday value for
3530 * January 1st, which we subtract from the yearday value we had earlier,
3531 * representing the date we've re-built. This is done from January 1
3532 * because tm_yday is 0-origin.
3533 *
3534 * Since POSIX time routines are only guaranteed to work for times since the
3535 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3536 * applies Gregorian calendar rules even to dates before the 16th century
3537 * doesn't bother me. Besides, you'd need cultural context for a given
3538 * date to know whether it was Julian or Gregorian calendar, and that's
3539 * outside the scope for this routine. Since we convert back based on the
3540 * same rules we used to build the yearday, you'll only get strange results
3541 * for input which needed normalising, or for the 'odd' century years which
486ec47a 3542 * were leap years in the Julian calendar but not in the Gregorian one.
e72cf795
JH
3543 * I can live with that.
3544 *
3545 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3546 * that's still outside the scope for POSIX time manipulation, so I don't
3547 * care.
3548 */
3549
3550 year = 1900 + ptm->tm_year;
3551 month = ptm->tm_mon;
3552 mday = ptm->tm_mday;
a64f08cb 3553 jday = 0;
e72cf795
JH
3554 if (month >= 2)
3555 month+=2;
3556 else
3557 month+=14, year--;
3558 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3559 yearday += month*MONTH_TO_DAYS + mday + jday;
3560 /*
3561 * Note that we don't know when leap-seconds were or will be,
3562 * so we have to trust the user if we get something which looks
3563 * like a sensible leap-second. Wild values for seconds will
3564 * be rationalised, however.
3565 */
3566 if ((unsigned) ptm->tm_sec <= 60) {
3567 secs = 0;
3568 }
3569 else {
3570 secs = ptm->tm_sec;
3571 ptm->tm_sec = 0;