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