This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fwd: CPAN Upload: Y/YV/YVES/ExtUtils-Install-1.45.tar.gz
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
7272f7c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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/*
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
14 */
8d063cd8 15
166f8a29
DM		 16/* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
20 */
21
8d063cd8 22#include "EXTERN.h"
864dbfa3 23#define PERL_IN_UTIL_C
8d063cd8 24#include "perl.h"
62b28dd9 25
64ca3a65 26#ifndef PERL_MICRO
a687059c 27#include <signal.h>
36477c24 28#ifndef SIG_ERR
29# define SIG_ERR ((Sighandler_t) -1)
30#endif
64ca3a65 31#endif
36477c24 32
172d2248
OS		 33#ifdef __Lynx__
34/* Missing protos on LynxOS */
35int putenv(char *);
36#endif
37
ff68c719 38#ifdef I_SYS_WAIT
39# include <sys/wait.h>
40#endif
41
868439a2
JH		 42#ifdef HAS_SELECT
43# ifdef I_SYS_SELECT
44# include <sys/select.h>
45# endif
46#endif
47
8d063cd8 48#define FLUSH
8d063cd8 49
16cebae2
GS		 50#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
51# define FD_CLOEXEC 1 /* NeXT needs this */
52#endif
53
a687059c
LW		 54/* NOTE: Do not call the next three routines directly. Use the macros
55 * in handy.h, so that we can easily redefine everything to do tracking of
56 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 57 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW		 58 */
59
ca8d8976
NC		 60static char *
61S_write_no_mem(pTHX)
62{
97aff369 63 dVAR;
ca8d8976
NC		 64 /* Can't use PerlIO to write as it allocates memory */
65 PerlLIO_write(PerlIO_fileno(Perl_error_log),
66 PL_no_mem, strlen(PL_no_mem));
67 my_exit(1);
1f440eb2 68 NORETURN_FUNCTION_END;
ca8d8976
NC		 69}
70
26fa51c3
AMS		 71/* paranoid version of system's malloc() */
72
bd4080b3 73Malloc_t
4f63d024 74Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 75{
54aff467 76 dTHX;
bd4080b3 77 Malloc_t ptr;
55497cff 78#ifdef HAS_64K_LIMIT
62b28dd9 79 if (size > 0xffff) {
bf49b057 80 PerlIO_printf(Perl_error_log,
16cebae2 81 "Allocation too large: %lx\n", size) FLUSH;
54aff467 82 my_exit(1);
62b28dd9 83 }
55497cff 84#endif /* HAS_64K_LIMIT */
e8dda941
JD		 85#ifdef PERL_TRACK_MEMPOOL
86 size += sTHX;
87#endif
34de22dd
LW		 88#ifdef DEBUGGING
89 if ((long)size < 0)
4f63d024 90 Perl_croak_nocontext("panic: malloc");
34de22dd 91#endif
12ae5dfc 92 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 93 PERL_ALLOC_CHECK(ptr);
97835f67 94 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
bd61b366 95 if (ptr != NULL) {
e8dda941 96#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 97 struct perl_memory_debug_header *const header
98 = (struct perl_memory_debug_header *)ptr;
9a083ecf
NC		 99#endif
100
101#ifdef PERL_POISON
7e337ee0 102 PoisonNew(((char *)ptr), size, char);
9a083ecf 103#endif
7cb608b5 104
9a083ecf 105#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 106 header->interpreter = aTHX;
107 /* Link us into the list. */
108 header->prev = &PL_memory_debug_header;
109 header->next = PL_memory_debug_header.next;
110 PL_memory_debug_header.next = header;
111 header->next->prev = header;
cd1541b2 112# ifdef PERL_POISON
7cb608b5 113 header->size = size;
cd1541b2 114# endif
e8dda941
JD		 115 ptr = (Malloc_t)((char*)ptr+sTHX);
116#endif
8d063cd8 117 return ptr;
e8dda941 118}
3280af22 119 else if (PL_nomemok)
bd61b366 120 return NULL;
8d063cd8 121 else {
0bd48802 122 return write_no_mem();
8d063cd8
LW		 123 }
124 /*NOTREACHED*/
125}
126
f2517201 127/* paranoid version of system's realloc() */
8d063cd8 128
bd4080b3 129Malloc_t
4f63d024 130Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 131{
54aff467 132 dTHX;
bd4080b3 133 Malloc_t ptr;
9a34ef1d 134#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
6ad3d225 135 Malloc_t PerlMem_realloc();
ecfc5424 136#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 137
a1d180c4 138#ifdef HAS_64K_LIMIT
5f05dabc 139 if (size > 0xffff) {
bf49b057 140 PerlIO_printf(Perl_error_log,
5f05dabc 141 "Reallocation too large: %lx\n", size) FLUSH;
54aff467 142 my_exit(1);
5f05dabc 143 }
55497cff 144#endif /* HAS_64K_LIMIT */
7614df0c 145 if (!size) {
f2517201 146 safesysfree(where);
7614df0c
JD		 147 return NULL;
148 }
149
378cc40b 150 if (!where)
f2517201 151 return safesysmalloc(size);
e8dda941
JD		 152#ifdef PERL_TRACK_MEMPOOL
153 where = (Malloc_t)((char*)where-sTHX);
154 size += sTHX;
7cb608b5
NC		 155 {
156 struct perl_memory_debug_header *const header
157 = (struct perl_memory_debug_header *)where;
158
159 if (header->interpreter != aTHX) {
160 Perl_croak_nocontext("panic: realloc from wrong pool");
161 }
162 assert(header->next->prev == header);
163 assert(header->prev->next == header);
cd1541b2 164# ifdef PERL_POISON
7cb608b5
NC		 165 if (header->size > size) {
166 const MEM_SIZE freed_up = header->size - size;
167 char *start_of_freed = ((char *)where) + size;
7e337ee0 168 PoisonFree(start_of_freed, freed_up, char);
7cb608b5
NC		 169 }
170 header->size = size;
cd1541b2 171# endif
7cb608b5 172 }
e8dda941 173#endif
34de22dd
LW		 174#ifdef DEBUGGING
175 if ((long)size < 0)
4f63d024 176 Perl_croak_nocontext("panic: realloc");
34de22dd 177#endif
12ae5dfc 178 ptr = (Malloc_t)PerlMem_realloc(where,size);
da927450 179 PERL_ALLOC_CHECK(ptr);
a1d180c4 180
97835f67
JH		 181 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
182 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
79072805 183
bd61b366 184 if (ptr != NULL) {
e8dda941 185#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 186 struct perl_memory_debug_header *const header
187 = (struct perl_memory_debug_header *)ptr;
188
9a083ecf
NC		 189# ifdef PERL_POISON
190 if (header->size < size) {
191 const MEM_SIZE fresh = size - header->size;
192 char *start_of_fresh = ((char *)ptr) + size;
7e337ee0 193 PoisonNew(start_of_fresh, fresh, char);
9a083ecf
NC		 194 }
195# endif
196
7cb608b5
NC		 197 header->next->prev = header;
198 header->prev->next = header;
199
e8dda941
JD		 200 ptr = (Malloc_t)((char*)ptr+sTHX);
201#endif
8d063cd8 202 return ptr;
e8dda941 203 }
3280af22 204 else if (PL_nomemok)
bd61b366 205 return NULL;
8d063cd8 206 else {
0bd48802 207 return write_no_mem();
8d063cd8
LW		 208 }
209 /*NOTREACHED*/
210}
211
f2517201 212/* safe version of system's free() */
8d063cd8 213
54310121 214Free_t
4f63d024 215Perl_safesysfree(Malloc_t where)
8d063cd8 216{
e8dda941 217#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
54aff467 218 dTHX;
97aff369
JH		 219#else
220 dVAR;
155aba94 221#endif
97835f67 222 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 223 if (where) {
e8dda941
JD		 224#ifdef PERL_TRACK_MEMPOOL
225 where = (Malloc_t)((char*)where-sTHX);
cd1541b2 226 {
7cb608b5
NC		 227 struct perl_memory_debug_header *const header
228 = (struct perl_memory_debug_header *)where;
229
230 if (header->interpreter != aTHX) {
231 Perl_croak_nocontext("panic: free from wrong pool");
232 }
233 if (!header->prev) {
cd1541b2
NC		 234 Perl_croak_nocontext("panic: duplicate free");
235 }
7cb608b5
NC		 236 if (!(header->next) || header->next->prev != header
237 || header->prev->next != header) {
238 Perl_croak_nocontext("panic: bad free");
cd1541b2 239 }
7cb608b5
NC		 240 /* Unlink us from the chain. */
241 header->next->prev = header->prev;
242 header->prev->next = header->next;
243# ifdef PERL_POISON
7e337ee0 244 PoisonNew(where, header->size, char);
cd1541b2 245# endif
7cb608b5
NC		 246 /* Trigger the duplicate free warning. */
247 header->next = NULL;
248 }
e8dda941 249#endif
6ad3d225 250 PerlMem_free(where);
378cc40b 251 }
8d063cd8
LW		 252}
253
f2517201 254/* safe version of system's calloc() */
1050c9ca 255
bd4080b3 256Malloc_t
4f63d024 257Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 258{
54aff467 259 dTHX;
bd4080b3 260 Malloc_t ptr;
ad7244db 261 MEM_SIZE total_size = 0;
1050c9ca 262
ad7244db 263 /* Even though calloc() for zero bytes is strange, be robust. */
19a94d75 264 if (size && (count <= MEM_SIZE_MAX / size))
ad7244db
JH		 265 total_size = size * count;
266 else
267 Perl_croak_nocontext(PL_memory_wrap);
268#ifdef PERL_TRACK_MEMPOOL
19a94d75 269 if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
ad7244db
JH		 270 total_size += sTHX;
271 else
272 Perl_croak_nocontext(PL_memory_wrap);
273#endif
55497cff 274#ifdef HAS_64K_LIMIT
e1a95402 275 if (total_size > 0xffff) {
bf49b057 276 PerlIO_printf(Perl_error_log,
e1a95402 277 "Allocation too large: %lx\n", total_size) FLUSH;
54aff467 278 my_exit(1);
5f05dabc 279 }
55497cff 280#endif /* HAS_64K_LIMIT */
1050c9ca 281#ifdef DEBUGGING
282 if ((long)size < 0 || (long)count < 0)
4f63d024 283 Perl_croak_nocontext("panic: calloc");
1050c9ca 284#endif
e8dda941 285#ifdef PERL_TRACK_MEMPOOL
e1a95402
NC		 286 /* Have to use malloc() because we've added some space for our tracking
287 header. */
ad7244db
JH		 288 /* malloc(0) is non-portable. */
289 ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
e1a95402
NC		 290#else
291 /* Use calloc() because it might save a memset() if the memory is fresh
292 and clean from the OS. */
ad7244db
JH		 293 if (count && size)
294 ptr = (Malloc_t)PerlMem_calloc(count, size);
295 else /* calloc(0) is non-portable. */
296 ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
e8dda941 297#endif
da927450 298 PERL_ALLOC_CHECK(ptr);
e1a95402 299 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 300 if (ptr != NULL) {
e8dda941 301#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 302 {
303 struct perl_memory_debug_header *const header
304 = (struct perl_memory_debug_header *)ptr;
305
e1a95402 306 memset((void*)ptr, 0, total_size);
7cb608b5
NC		 307 header->interpreter = aTHX;
308 /* Link us into the list. */
309 header->prev = &PL_memory_debug_header;
310 header->next = PL_memory_debug_header.next;
311 PL_memory_debug_header.next = header;
312 header->next->prev = header;
cd1541b2 313# ifdef PERL_POISON
e1a95402 314 header->size = total_size;
cd1541b2 315# endif
7cb608b5
NC		 316 ptr = (Malloc_t)((char*)ptr+sTHX);
317 }
e8dda941 318#endif
1050c9ca 319 return ptr;
320 }
3280af22 321 else if (PL_nomemok)
bd61b366 322 return NULL;
0bd48802 323 return write_no_mem();
1050c9ca 324}
325
cae6d0e5
GS		 326/* These must be defined when not using Perl's malloc for binary
327 * compatibility */
328
329#ifndef MYMALLOC
330
331Malloc_t Perl_malloc (MEM_SIZE nbytes)
332{
333 dTHXs;
077a72a9 334 return (Malloc_t)PerlMem_malloc(nbytes);
cae6d0e5
GS		 335}
336
337Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
338{
339 dTHXs;
077a72a9 340 return (Malloc_t)PerlMem_calloc(elements, size);
cae6d0e5
GS		 341}
342
343Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
344{
345 dTHXs;
077a72a9 346 return (Malloc_t)PerlMem_realloc(where, nbytes);
cae6d0e5
GS		 347}
348
349Free_t Perl_mfree (Malloc_t where)
350{
351 dTHXs;
352 PerlMem_free(where);
353}
354
355#endif
356
8d063cd8
LW		 357/* copy a string up to some (non-backslashed) delimiter, if any */
358
359char *
e1ec3a88 360Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
8d063cd8 361{
fc36a67e 362 register I32 tolen;
96a5add6 363 PERL_UNUSED_CONTEXT;
35da51f7 364
7918f24d
NC		 365 PERL_ARGS_ASSERT_DELIMCPY;
366
fc36a67e 367 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b 368 if (*from == '\\') {
35da51f7 369 if (from[1] != delim) {
fc36a67e 370 if (to < toend)
371 *to++ = *from;
372 tolen++;
fc36a67e 373 }
35da51f7 374 from++;
378cc40b 375 }
bedebaa5 376 else if (*from == delim)
8d063cd8 377 break;
fc36a67e 378 if (to < toend)
379 *to++ = *from;
8d063cd8 380 }
bedebaa5
CS		 381 if (to < toend)
382 *to = '\0';
fc36a67e 383 *retlen = tolen;
73d840c0 384 return (char *)from;
8d063cd8
LW		 385}
386
387/* return ptr to little string in big string, NULL if not found */
378cc40b 388/* This routine was donated by Corey Satten. */
8d063cd8
LW		 389
390char *
864dbfa3 391Perl_instr(pTHX_ register const char *big, register const char *little)
378cc40b 392{
79072805 393 register I32 first;
96a5add6 394 PERL_UNUSED_CONTEXT;
378cc40b 395
7918f24d
NC		 396 PERL_ARGS_ASSERT_INSTR;
397
a687059c 398 if (!little)
08105a92 399 return (char*)big;
a687059c 400 first = *little++;
378cc40b 401 if (!first)
08105a92 402 return (char*)big;
378cc40b 403 while (*big) {
66a1b24b 404 register const char *s, *x;
378cc40b
LW		 405 if (*big++ != first)
406 continue;
407 for (x=big,s=little; *s; /**/ ) {
408 if (!*x)
bd61b366 409 return NULL;
4fc877ac 410 if (*s != *x)
378cc40b 411 break;
4fc877ac
AL		 412 else {
413 s++;
414 x++;
378cc40b
LW		 415 }
416 }
417 if (!*s)
08105a92 418 return (char*)(big-1);
378cc40b 419 }
bd61b366 420 return NULL;
378cc40b 421}
8d063cd8 422
a687059c
LW		 423/* same as instr but allow embedded nulls */
424
425char *
4c8626be 426Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 427{
7918f24d 428 PERL_ARGS_ASSERT_NINSTR;
96a5add6 429 PERL_UNUSED_CONTEXT;
4c8626be
GA		 430 if (little >= lend)
431 return (char*)big;
432 {
c9289b7b 433 const char first = *little++;
4c8626be
GA		 434 const char *s, *x;
435 bigend -= lend - little;
436 OUTER:
437 while (big <= bigend) {
b0ca24ee
JH		 438 if (*big++ == first) {
439 for (x=big,s=little; s < lend; x++,s++) {
440 if (*s != *x)
441 goto OUTER;
442 }
443 return (char*)(big-1);
4c8626be 444 }
4c8626be 445 }
378cc40b 446 }
bd61b366 447 return NULL;
a687059c
LW		 448}
449
450/* reverse of the above--find last substring */
451
452char *
864dbfa3 453Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
a687059c 454{
08105a92 455 register const char *bigbeg;
e1ec3a88 456 register const I32 first = *little;
7452cf6a 457 register const char * const littleend = lend;
96a5add6 458 PERL_UNUSED_CONTEXT;
a687059c 459
7918f24d
NC		 460 PERL_ARGS_ASSERT_RNINSTR;
461
260d78c9 462 if (little >= littleend)
08105a92 463 return (char*)bigend;
a687059c
LW		 464 bigbeg = big;
465 big = bigend - (littleend - little++);
466 while (big >= bigbeg) {
66a1b24b 467 register const char *s, *x;
a687059c
LW		 468 if (*big-- != first)
469 continue;
470 for (x=big+2,s=little; s < littleend; /**/ ) {
4fc877ac 471 if (*s != *x)
a687059c 472 break;
4fc877ac
AL		 473 else {
474 x++;
475 s++;
a687059c
LW		 476 }
477 }
478 if (s >= littleend)
08105a92 479 return (char*)(big+1);
378cc40b 480 }
bd61b366 481 return NULL;
378cc40b 482}
a687059c 483
cf93c79d
IZ		 484/* As a space optimization, we do not compile tables for strings of length
485 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
486 special-cased in fbm_instr().
487
488 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
489
954c1994 490/*
ccfc67b7
JH		 491=head1 Miscellaneous Functions
492
954c1994
GS		 493=for apidoc fbm_compile
494
495Analyses the string in order to make fast searches on it using fbm_instr()
496-- the Boyer-Moore algorithm.
497
498=cut
499*/
500
378cc40b 501void
7506f9c3 502Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 503{
97aff369 504 dVAR;
0d46e09a 505 register const U8 *s;
79072805 506 register U32 i;
0b71040e 507 STRLEN len;
cb742848 508 U32 rarest = 0;
79072805
LW		 509 U32 frequency = 256;
510
7918f24d
NC		 511 PERL_ARGS_ASSERT_FBM_COMPILE;
512
c517dc2b 513 if (flags & FBMcf_TAIL) {
890ce7af 514 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 515 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH		 516 if (mg && mg->mg_len >= 0)
517 mg->mg_len++;
518 }
9cbe880b 519 s = (U8*)SvPV_force_mutable(sv, len);
d1be9408 520 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 521 return;
cecf5685 522 SvUPGRADE(sv, SVt_PVGV);
78d0cf80 523 SvIOK_off(sv);
8eeaf79a
NC		 524 SvNOK_off(sv);
525 SvVALID_on(sv);
02128f11 526 if (len > 2) {
9cbe880b 527 const unsigned char *sb;
66a1b24b 528 const U8 mlen = (len>255) ? 255 : (U8)len;
890ce7af 529 register U8 *table;
cf93c79d 530
d8419e03
NC		 531 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
532 table
533 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
534 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
7506f9c3 535 memset((void*)table, mlen, 256);
02128f11 536 i = 0;
7506f9c3 537 sb = s - mlen + 1; /* first char (maybe) */
cf93c79d
IZ		 538 while (s >= sb) {
539 if (table[*s] == mlen)
7506f9c3 540 table[*s] = (U8)i;
cf93c79d
IZ		 541 s--, i++;
542 }
d0688fc4
NC		 543 } else {
544 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
378cc40b 545 }
a0714e2c 546 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
378cc40b 547
9cbe880b 548 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
bbce6d69 549 for (i = 0; i < len; i++) {
22c35a8c 550 if (PL_freq[s[i]] < frequency) {
bbce6d69 551 rarest = i;
22c35a8c 552 frequency = PL_freq[s[i]];
378cc40b
LW		 553 }
554 }
610460f9 555 BmFLAGS(sv) = (U8)flags;
79072805 556 BmRARE(sv) = s[rarest];
44a10c71 557 BmPREVIOUS(sv) = rarest;
cf93c79d
IZ		 558 BmUSEFUL(sv) = 100; /* Initial value */
559 if (flags & FBMcf_TAIL)
560 SvTAIL_on(sv);
8eeaf79a
NC		 561 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
562 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
378cc40b
LW		 563}
564
cf93c79d
IZ		 565/* If SvTAIL(littlestr), it has a fake '\n' at end. */
566/* If SvTAIL is actually due to \Z or \z, this gives false positives
567 if multiline */
568
954c1994
GS		 569/*
570=for apidoc fbm_instr
571
572Returns the location of the SV in the string delimited by C<str> and
bd61b366 573C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
954c1994
GS		 574does not have to be fbm_compiled, but the search will not be as fast
575then.
576
577=cut
578*/
579
378cc40b 580char *
864dbfa3 581Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 582{
a687059c 583 register unsigned char *s;
cf93c79d 584 STRLEN l;
9cbe880b
NC		 585 register const unsigned char *little
586 = (const unsigned char *)SvPV_const(littlestr,l);
cf93c79d 587 register STRLEN littlelen = l;
e1ec3a88 588 register const I32 multiline = flags & FBMrf_MULTILINE;
cf93c79d 589
7918f24d
NC		 590 PERL_ARGS_ASSERT_FBM_INSTR;
591
eb160463 592 if ((STRLEN)(bigend - big) < littlelen) {
a1d180c4 593 if ( SvTAIL(littlestr)
eb160463 594 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 595 && (littlelen == 1
12ae5dfc 596 || (*big == *little &&
27da23d5 597 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 598 return (char*)big;
bd61b366 599 return NULL;
cf93c79d 600 }
378cc40b 601
cf93c79d 602 if (littlelen <= 2) { /* Special-cased */
cf93c79d
IZ		 603
604 if (littlelen == 1) {
605 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
606 /* Know that bigend != big. */
607 if (bigend[-1] == '\n')
608 return (char *)(bigend - 1);
609 return (char *) bigend;
610 }
611 s = big;
612 while (s < bigend) {
613 if (*s == *little)
614 return (char *)s;
615 s++;
616 }
617 if (SvTAIL(littlestr))
618 return (char *) bigend;
bd61b366 619 return NULL;
cf93c79d
IZ		 620 }
621 if (!littlelen)
622 return (char*)big; /* Cannot be SvTAIL! */
623
624 /* littlelen is 2 */
625 if (SvTAIL(littlestr) && !multiline) {
626 if (bigend[-1] == '\n' && bigend[-2] == *little)
627 return (char*)bigend - 2;
628 if (bigend[-1] == *little)
629 return (char*)bigend - 1;
bd61b366 630 return NULL;
cf93c79d
IZ		 631 }
632 {
633 /* This should be better than FBM if c1 == c2, and almost
634 as good otherwise: maybe better since we do less indirection.
635 And we save a lot of memory by caching no table. */
66a1b24b
AL		 636 const unsigned char c1 = little[0];
637 const unsigned char c2 = little[1];
cf93c79d
IZ		 638
639 s = big + 1;
640 bigend--;
641 if (c1 != c2) {
642 while (s <= bigend) {
643 if (s[0] == c2) {
644 if (s[-1] == c1)
645 return (char*)s - 1;
646 s += 2;
647 continue;
3fe6f2dc 648 }
cf93c79d
IZ		 649 next_chars:
650 if (s[0] == c1) {
651 if (s == bigend)
652 goto check_1char_anchor;
653 if (s[1] == c2)
654 return (char*)s;
655 else {
656 s++;
657 goto next_chars;
658 }
659 }
660 else
661 s += 2;
662 }
663 goto check_1char_anchor;
664 }
665 /* Now c1 == c2 */
666 while (s <= bigend) {
667 if (s[0] == c1) {
668 if (s[-1] == c1)
669 return (char*)s - 1;
670 if (s == bigend)
671 goto check_1char_anchor;
672 if (s[1] == c1)
673 return (char*)s;
674 s += 3;
02128f11 675 }
c277df42 676 else
cf93c79d 677 s += 2;
c277df42 678 }
c277df42 679 }
cf93c79d
IZ		 680 check_1char_anchor: /* One char and anchor! */
681 if (SvTAIL(littlestr) && (*bigend == *little))
682 return (char *)bigend; /* bigend is already decremented. */
bd61b366 683 return NULL;
d48672a2 684 }
cf93c79d 685 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
bbce6d69 686 s = bigend - littlelen;
a1d180c4 687 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ		 688 /* Automatically of length > 2 */
689 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 690 {
bbce6d69 691 return (char*)s; /* how sweet it is */
7506f9c3
GS		 692 }
693 if (s[1] == *little
694 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
695 {
cf93c79d 696 return (char*)s + 1; /* how sweet it is */
7506f9c3 697 }
bd61b366 698 return NULL;
02128f11 699 }
cecf5685 700 if (!SvVALID(littlestr)) {
c4420975 701 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ		 702 (char*)little, (char*)little + littlelen);
703
704 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
705 /* Chop \n from littlestr: */
706 s = bigend - littlelen + 1;
7506f9c3
GS		 707 if (*s == *little
708 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
709 {
3fe6f2dc 710 return (char*)s;
7506f9c3 711 }
bd61b366 712 return NULL;
a687059c 713 }
cf93c79d 714 return b;
a687059c 715 }
a1d180c4 716
3566a07d
NC		 717 /* Do actual FBM. */
718 if (littlelen > (STRLEN)(bigend - big))
719 return NULL;
720
721 {
d8419e03
NC		 722 register const unsigned char * const table
723 = little + littlelen + PERL_FBM_TABLE_OFFSET;
0d46e09a 724 register const unsigned char *oldlittle;
cf93c79d 725
cf93c79d
IZ		 726 --littlelen; /* Last char found by table lookup */
727
728 s = big + littlelen;
729 little += littlelen; /* last char */
730 oldlittle = little;
731 if (s < bigend) {
732 register I32 tmp;
733
734 top2:
7506f9c3 735 if ((tmp = table[*s])) {
cf93c79d 736 if ((s += tmp) < bigend)
62b28dd9 737 goto top2;
cf93c79d
IZ		 738 goto check_end;
739 }
740 else { /* less expensive than calling strncmp() */
66a1b24b 741 register unsigned char * const olds = s;
cf93c79d
IZ		 742
743 tmp = littlelen;
744
745 while (tmp--) {
746 if (*--s == *--little)
747 continue;
cf93c79d
IZ		 748 s = olds + 1; /* here we pay the price for failure */
749 little = oldlittle;
750 if (s < bigend) /* fake up continue to outer loop */
751 goto top2;
752 goto check_end;
753 }
754 return (char *)s;
a687059c 755 }
378cc40b 756 }
cf93c79d 757 check_end:
c8029a41 758 if ( s == bigend
8eeaf79a 759 && (BmFLAGS(littlestr) & FBMcf_TAIL)
12ae5dfc
JH		 760 && memEQ((char *)(bigend - littlelen),
761 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 762 return (char*)bigend - littlelen;
bd61b366 763 return NULL;
378cc40b 764 }
378cc40b
LW		 765}
766
c277df42
IZ		 767/* start_shift, end_shift are positive quantities which give offsets
768 of ends of some substring of bigstr.
a0288114 769 If "last" we want the last occurrence.
c277df42 770 old_posp is the way of communication between consequent calls if
a1d180c4 771 the next call needs to find the .
c277df42 772 The initial *old_posp should be -1.
cf93c79d
IZ		 773
774 Note that we take into account SvTAIL, so one can get extra
775 optimizations if _ALL flag is set.
c277df42
IZ		 776 */
777
cf93c79d 778/* If SvTAIL is actually due to \Z or \z, this gives false positives
26fa51c3 779 if PL_multiline. In fact if !PL_multiline the authoritative answer
cf93c79d
IZ		 780 is not supported yet. */
781
378cc40b 782char *
864dbfa3 783Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
378cc40b 784{
97aff369 785 dVAR;
0d46e09a 786 register const unsigned char *big;
79072805
LW		 787 register I32 pos;
788 register I32 previous;
789 register I32 first;
0d46e09a 790 register const unsigned char *little;
c277df42 791 register I32 stop_pos;
0d46e09a 792 register const unsigned char *littleend;
c277df42 793 I32 found = 0;
378cc40b 794
7918f24d
NC		 795 PERL_ARGS_ASSERT_SCREAMINSTR;
796
cecf5685
NC		 797 assert(SvTYPE(littlestr) == SVt_PVGV);
798 assert(SvVALID(littlestr));
d372c834 799
c277df42 800 if (*old_posp == -1
3280af22 801 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
cf93c79d
IZ		 802 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
803 cant_find:
a1d180c4 804 if ( BmRARE(littlestr) == '\n'
85c508c3 805 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
cfd0369c 806 little = (const unsigned char *)(SvPVX_const(littlestr));
cf93c79d
IZ		 807 littleend = little + SvCUR(littlestr);
808 first = *little++;
809 goto check_tail;
810 }
bd61b366 811 return NULL;
cf93c79d
IZ		 812 }
813
cfd0369c 814 little = (const unsigned char *)(SvPVX_const(littlestr));
79072805 815 littleend = little + SvCUR(littlestr);
378cc40b 816 first = *little++;
c277df42 817 /* The value of pos we can start at: */
79072805 818 previous = BmPREVIOUS(littlestr);
cfd0369c 819 big = (const unsigned char *)(SvPVX_const(bigstr));
c277df42
IZ		 820 /* The value of pos we can stop at: */
821 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
cf93c79d 822 if (previous + start_shift > stop_pos) {
0fe87f7c
HS		 823/*
824 stop_pos does not include SvTAIL in the count, so this check is incorrect
825 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
826*/
827#if 0
cf93c79d
IZ		 828 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
829 goto check_tail;
0fe87f7c 830#endif
bd61b366 831 return NULL;
cf93c79d 832 }
c277df42 833 while (pos < previous + start_shift) {
3280af22 834 if (!(pos += PL_screamnext[pos]))
cf93c79d 835 goto cant_find;
378cc40b 836 }
de3bb511 837 big -= previous;
bbce6d69 838 do {
0d46e09a 839 register const unsigned char *s, *x;
ef64f398 840 if (pos >= stop_pos) break;
bbce6d69 841 if (big[pos] != first)
842 continue;
843 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69 844 if (*s++ != *x++) {
845 s--;
846 break;
378cc40b 847 }
bbce6d69 848 }
c277df42
IZ		 849 if (s == littleend) {
850 *old_posp = pos;
851 if (!last) return (char *)(big+pos);
852 found = 1;
853 }
3280af22 854 } while ( pos += PL_screamnext[pos] );
a1d180c4 855 if (last && found)
cf93c79d 856 return (char *)(big+(*old_posp));
cf93c79d
IZ		 857 check_tail:
858 if (!SvTAIL(littlestr) || (end_shift > 0))
bd61b366 859 return NULL;
cf93c79d 860 /* Ignore the trailing "\n". This code is not microoptimized */
cfd0369c 861 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
cf93c79d
IZ		 862 stop_pos = littleend - little; /* Actual littlestr len */
863 if (stop_pos == 0)
864 return (char*)big;
865 big -= stop_pos;
866 if (*big == first
12ae5dfc
JH		 867 && ((stop_pos == 1) ||
868 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
cf93c79d 869 return (char*)big;
bd61b366 870 return NULL;
8d063cd8
LW		 871}
872
79072805 873I32
864dbfa3 874Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
79072805 875{
e1ec3a88
AL		 876 register const U8 *a = (const U8 *)s1;
877 register const U8 *b = (const U8 *)s2;
96a5add6
AL		 878 PERL_UNUSED_CONTEXT;
879
7918f24d
NC		 880 PERL_ARGS_ASSERT_IBCMP;
881
79072805 882 while (len--) {
22c35a8c 883 if (*a != *b && *a != PL_fold[*b])
bbce6d69 884 return 1;
885 a++,b++;
886 }
887 return 0;
888}
889
890I32
864dbfa3 891Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
bbce6d69 892{
27da23d5 893 dVAR;
e1ec3a88
AL		 894 register const U8 *a = (const U8 *)s1;
895 register const U8 *b = (const U8 *)s2;
96a5add6
AL		 896 PERL_UNUSED_CONTEXT;
897
7918f24d
NC		 898 PERL_ARGS_ASSERT_IBCMP_LOCALE;
899
bbce6d69 900 while (len--) {
22c35a8c 901 if (*a != *b && *a != PL_fold_locale[*b])
bbce6d69 902 return 1;
903 a++,b++;
79072805
LW		 904 }
905 return 0;
906}
907
8d063cd8
LW		 908/* copy a string to a safe spot */
909
954c1994 910/*
ccfc67b7
JH		 911=head1 Memory Management
912
954c1994
GS		 913=for apidoc savepv
914
61a925ed
AMS		 915Perl's version of C<strdup()>. Returns a pointer to a newly allocated
916string which is a duplicate of C<pv>. The size of the string is
917determined by C<strlen()>. The memory allocated for the new string can
918be freed with the C<Safefree()> function.
954c1994
GS		 919
920=cut
921*/
922
8d063cd8 923char *
efdfce31 924Perl_savepv(pTHX_ const char *pv)
8d063cd8 925{
96a5add6 926 PERL_UNUSED_CONTEXT;
e90e2364 927 if (!pv)
bd61b366 928 return NULL;
66a1b24b
AL		 929 else {
930 char *newaddr;
931 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH		 932 Newx(newaddr, pvlen, char);
933 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 934 }
8d063cd8
LW		 935}
936
a687059c
LW		 937/* same thing but with a known length */
938
954c1994
GS		 939/*
940=for apidoc savepvn
941
61a925ed
AMS		 942Perl's version of what C<strndup()> would be if it existed. Returns a
943pointer to a newly allocated string which is a duplicate of the first
cbf82dd0
NC		 944C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
945the new string can be freed with the C<Safefree()> function.
954c1994
GS		 946
947=cut
948*/
949
a687059c 950char *
efdfce31 951Perl_savepvn(pTHX_ const char *pv, register I32 len)
a687059c
LW		 952{
953 register char *newaddr;
96a5add6 954 PERL_UNUSED_CONTEXT;
a687059c 955
a02a5408 956 Newx(newaddr,len+1,char);
92110913 957 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 958 if (pv) {
e90e2364
NC		 959 /* might not be null terminated */
960 newaddr[len] = '\0';
07409e01 961 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS		 962 }
963 else {
07409e01 964 return (char *) ZeroD(newaddr,len+1,char);
92110913 965 }
a687059c
LW		 966}
967
05ec9bb3
NIS		 968/*
969=for apidoc savesharedpv
970
61a925ed
AMS		 971A version of C<savepv()> which allocates the duplicate string in memory
972which is shared between threads.
05ec9bb3
NIS		 973
974=cut
975*/
976char *
efdfce31 977Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 978{
e90e2364 979 register char *newaddr;
490a0e98 980 STRLEN pvlen;
e90e2364 981 if (!pv)
bd61b366 982 return NULL;
e90e2364 983
490a0e98
NC		 984 pvlen = strlen(pv)+1;
985 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 986 if (!newaddr) {
0bd48802 987 return write_no_mem();
05ec9bb3 988 }
10edeb5d 989 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS		 990}
991
2e0de35c 992/*
d9095cec
NC		 993=for apidoc savesharedpvn
994
995A version of C<savepvn()> which allocates the duplicate string in memory
996which is shared between threads. (With the specific difference that a NULL
997pointer is not acceptable)
998
999=cut
1000*/
1001char *
1002Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1003{
1004 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
7918f24d
NC		 1005
1006 PERL_ARGS_ASSERT_SAVESHAREDPVN;
1007
d9095cec
NC		 1008 if (!newaddr) {
1009 return write_no_mem();
1010 }
1011 newaddr[len] = '\0';
1012 return (char*)memcpy(newaddr, pv, len);
1013}
1014
1015/*
2e0de35c
NC		 1016=for apidoc savesvpv
1017
6832267f 1018A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC		 1019the passed in SV using C<SvPV()>
1020
1021=cut
1022*/
1023
1024char *
1025Perl_savesvpv(pTHX_ SV *sv)
1026{
1027 STRLEN len;
7452cf6a 1028 const char * const pv = SvPV_const(sv, len);
2e0de35c
NC		 1029 register char *newaddr;
1030
7918f24d
NC		 1031 PERL_ARGS_ASSERT_SAVESVPV;
1032
26866f99 1033 ++len;
a02a5408 1034 Newx(newaddr,len,char);
07409e01 1035 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 1036}
05ec9bb3
NIS		 1037
1038
cea2e8a9 1039/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1040
76e3520e 1041STATIC SV *
cea2e8a9 1042S_mess_alloc(pTHX)
fc36a67e 1043{
97aff369 1044 dVAR;
fc36a67e 1045 SV *sv;
1046 XPVMG *any;
1047
e72dc28c 1048 if (!PL_dirty)
84bafc02 1049 return newSVpvs_flags("", SVs_TEMP);
e72dc28c 1050
0372dbb6
GS		 1051 if (PL_mess_sv)
1052 return PL_mess_sv;
1053
fc36a67e 1054 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC		 1055 Newx(sv, 1, SV);
1056 Newxz(any, 1, XPVMG);
fc36a67e 1057 SvFLAGS(sv) = SVt_PVMG;
1058 SvANY(sv) = (void*)any;
6136c704 1059 SvPV_set(sv, NULL);
fc36a67e 1060 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1061 PL_mess_sv = sv;
fc36a67e 1062 return sv;
1063}
1064
c5be433b 1065#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1066char *
1067Perl_form_nocontext(const char* pat, ...)
1068{
1069 dTHX;
c5be433b 1070 char *retval;
cea2e8a9 1071 va_list args;
7918f24d 1072 PERL_ARGS_ASSERT_FORM_NOCONTEXT;
cea2e8a9 1073 va_start(args, pat);
c5be433b 1074 retval = vform(pat, &args);
cea2e8a9 1075 va_end(args);
c5be433b 1076 return retval;
cea2e8a9 1077}
c5be433b 1078#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1079
7c9e965c 1080/*
ccfc67b7 1081=head1 Miscellaneous Functions
7c9e965c
JP		 1082=for apidoc form
1083
1084Takes a sprintf-style format pattern and conventional
1085(non-SV) arguments and returns the formatted string.
1086
1087 (char *) Perl_form(pTHX_ const char* pat, ...)
1088
1089can be used any place a string (char *) is required:
1090
1091 char * s = Perl_form("%d.%d",major,minor);
1092
1093Uses a single private buffer so if you want to format several strings you
1094must explicitly copy the earlier strings away (and free the copies when you
1095are done).
1096
1097=cut
1098*/
1099
8990e307 1100char *
864dbfa3 1101Perl_form(pTHX_ const char* pat, ...)
8990e307 1102{
c5be433b 1103 char *retval;
46fc3d4c 1104 va_list args;
7918f24d 1105 PERL_ARGS_ASSERT_FORM;
46fc3d4c 1106 va_start(args, pat);
c5be433b 1107 retval = vform(pat, &args);
46fc3d4c 1108 va_end(args);
c5be433b
GS		 1109 return retval;
1110}
1111
1112char *
1113Perl_vform(pTHX_ const char *pat, va_list *args)
1114{
2d03de9c 1115 SV * const sv = mess_alloc();
7918f24d 1116 PERL_ARGS_ASSERT_VFORM;
4608196e 1117 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1118 return SvPVX(sv);
46fc3d4c 1119}
a687059c 1120
5a844595
GS		 1121#if defined(PERL_IMPLICIT_CONTEXT)
1122SV *
1123Perl_mess_nocontext(const char *pat, ...)
1124{
1125 dTHX;
1126 SV *retval;
1127 va_list args;
7918f24d 1128 PERL_ARGS_ASSERT_MESS_NOCONTEXT;
5a844595
GS		 1129 va_start(args, pat);
1130 retval = vmess(pat, &args);
1131 va_end(args);
1132 return retval;
1133}
1134#endif /* PERL_IMPLICIT_CONTEXT */
1135
06bf62c7 1136SV *
5a844595
GS		 1137Perl_mess(pTHX_ const char *pat, ...)
1138{
1139 SV *retval;
1140 va_list args;
7918f24d 1141 PERL_ARGS_ASSERT_MESS;
5a844595
GS		 1142 va_start(args, pat);
1143 retval = vmess(pat, &args);
1144 va_end(args);
1145 return retval;
1146}
1147
5f66b61c
AL		 1148STATIC const COP*
1149S_closest_cop(pTHX_ const COP *cop, const OP *o)
ae7d165c 1150{
97aff369 1151 dVAR;
ae7d165c
PJ		 1152 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1153
7918f24d
NC		 1154 PERL_ARGS_ASSERT_CLOSEST_COP;
1155
fabdb6c0
AL		 1156 if (!o || o == PL_op)
1157 return cop;
ae7d165c
PJ		 1158
1159 if (o->op_flags & OPf_KIDS) {
5f66b61c 1160 const OP *kid;
fabdb6c0 1161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
5f66b61c 1162 const COP *new_cop;
ae7d165c
PJ		 1163
1164 /* If the OP_NEXTSTATE has been optimised away we can still use it
1165 * the get the file and line number. */
1166
1167 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1168 cop = (const COP *)kid;
ae7d165c
PJ		 1169
1170 /* Keep searching, and return when we've found something. */
1171
1172 new_cop = closest_cop(cop, kid);
fabdb6c0
AL		 1173 if (new_cop)
1174 return new_cop;
ae7d165c
PJ		 1175 }
1176 }
1177
1178 /* Nothing found. */
1179
5f66b61c 1180 return NULL;
ae7d165c
PJ		 1181}
1182
5a844595
GS		 1183SV *
1184Perl_vmess(pTHX_ const char *pat, va_list *args)
46fc3d4c 1185{
97aff369 1186 dVAR;
c4420975 1187 SV * const sv = mess_alloc();
46fc3d4c 1188
7918f24d
NC		 1189 PERL_ARGS_ASSERT_VMESS;
1190
5f66b61c 1191 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
46fc3d4c 1192 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ		 1193 /*
1194 * Try and find the file and line for PL_op. This will usually be
1195 * PL_curcop, but it might be a cop that has been optimised away. We
1196 * can try to find such a cop by searching through the optree starting
1197 * from the sibling of PL_curcop.
1198 */
1199
e1ec3a88 1200 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
5f66b61c
AL		 1201 if (!cop)
1202 cop = PL_curcop;
ae7d165c
PJ		 1203
1204 if (CopLINE(cop))
ed094faf 1205 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1206 OutCopFILE(cop), (IV)CopLINE(cop));
191f87d5
DH		 1207 /* Seems that GvIO() can be untrustworthy during global destruction. */
1208 if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1209 && IoLINES(GvIOp(PL_last_in_gv)))
1210 {
e1ec3a88 1211 const bool line_mode = (RsSIMPLE(PL_rs) &&
95a20fc0 1212 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
57def98f 1213 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
5f66b61c 1214 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
edc2eac3
JH		 1215 line_mode ? "line" : "chunk",
1216 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1217 }
5f66b61c
AL		 1218 if (PL_dirty)
1219 sv_catpvs(sv, " during global destruction");
1220 sv_catpvs(sv, ".\n");
a687059c 1221 }
06bf62c7 1222 return sv;
a687059c
LW		 1223}
1224
7ff03255
SG		 1225void
1226Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1227{
27da23d5 1228 dVAR;
7ff03255
SG		 1229 IO *io;
1230 MAGIC *mg;
1231
7918f24d
NC		 1232 PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1233
7ff03255
SG		 1234 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1235 && (io = GvIO(PL_stderrgv))
1236 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1237 {
1238 dSP;
1239 ENTER;
1240 SAVETMPS;
1241
1242 save_re_context();
1243 SAVESPTR(PL_stderrgv);
a0714e2c 1244 PL_stderrgv = NULL;
7ff03255
SG		 1245
1246 PUSHSTACKi(PERLSI_MAGIC);
1247
1248 PUSHMARK(SP);
1249 EXTEND(SP,2);
1250 PUSHs(SvTIED_obj((SV*)io, mg));
6e449a3a 1251 mPUSHp(message, msglen);
7ff03255
SG		 1252 PUTBACK;
1253 call_method("PRINT", G_SCALAR);
1254
1255 POPSTACK;
1256 FREETMPS;
1257 LEAVE;
1258 }
1259 else {
1260#ifdef USE_SFIO
1261 /* SFIO can really mess with your errno */
53c1dcc0 1262 const int e = errno;
7ff03255 1263#endif
53c1dcc0 1264 PerlIO * const serr = Perl_error_log;
7ff03255
SG		 1265
1266 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1267 (void)PerlIO_flush(serr);
1268#ifdef USE_SFIO
1269 errno = e;
1270#endif
1271 }
1272}
1273
46d9c920 1274/* Common code used by vcroak, vdie, vwarn and vwarner */
3ab1ac99 1275
46d9c920
NC		 1276STATIC bool
1277S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
63315e18 1278{
97aff369 1279 dVAR;
63315e18
NC		 1280 HV *stash;
1281 GV *gv;
1282 CV *cv;
46d9c920
NC		 1283 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1284 /* sv_2cv might call Perl_croak() or Perl_warner() */
1285 SV * const oldhook = *hook;
1286
1287 assert(oldhook);
63315e18 1288
63315e18 1289 ENTER;
46d9c920
NC		 1290 SAVESPTR(*hook);
1291 *hook = NULL;
1292 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC		 1293 LEAVE;
1294 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1295 dSP;
1296 SV *msg;
1297
1298 ENTER;
1299 save_re_context();
46d9c920
NC		 1300 if (warn) {
1301 SAVESPTR(*hook);
1302 *hook = NULL;
1303 }
1304 if (warn || message) {
740cce10 1305 msg = newSVpvn_flags(message, msglen, utf8);
63315e18
NC		 1306 SvREADONLY_on(msg);
1307 SAVEFREESV(msg);
1308 }
1309 else {
1310 msg = ERRSV;
1311 }
1312
46d9c920 1313 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18
NC		 1314 PUSHMARK(SP);
1315 XPUSHs(msg);
1316 PUTBACK;
1317 call_sv((SV*)cv, G_DISCARD);
1318 POPSTACK;
1319 LEAVE;
46d9c920 1320 return TRUE;
63315e18 1321 }
46d9c920 1322 return FALSE;
63315e18
NC		 1323}
1324
cfd0369c 1325STATIC const char *
e07360fa
AT		 1326S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1327 I32* utf8)
1328{
1329 dVAR;
cfd0369c 1330 const char *message;
e07360fa
AT		 1331
1332 if (pat) {
890ce7af 1333 SV * const msv = vmess(pat, args);
e07360fa
AT		 1334 if (PL_errors && SvCUR(PL_errors)) {
1335 sv_catsv(PL_errors, msv);
cfd0369c 1336 message = SvPV_const(PL_errors, *msglen);
e07360fa
AT		 1337 SvCUR_set(PL_errors, 0);
1338 }
1339 else
cfd0369c 1340 message = SvPV_const(msv,*msglen);
e07360fa
AT		 1341 *utf8 = SvUTF8(msv);
1342 }
1343 else {
bd61b366 1344 message = NULL;
e07360fa
AT		 1345 }
1346
e07360fa 1347 if (PL_diehook) {
46d9c920 1348 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
e07360fa
AT		 1349 }
1350 return message;
1351}
1352
c5be433b
GS		 1353OP *
1354Perl_vdie(pTHX_ const char* pat, va_list *args)
36477c24 1355{
97aff369 1356 dVAR;
73d840c0 1357 const char *message;
e1ec3a88 1358 const int was_in_eval = PL_in_eval;
06bf62c7 1359 STRLEN msglen;
ff882698 1360 I32 utf8 = 0;
36477c24 1361
890ce7af 1362 message = vdie_croak_common(pat, args, &msglen, &utf8);
36477c24 1363
06bf62c7 1364 PL_restartop = die_where(message, msglen);
ff882698 1365 SvFLAGS(ERRSV) |= utf8;
3280af22 1366 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
6224f72b 1367 JMPENV_JUMP(3);
3280af22 1368 return PL_restartop;
36477c24 1369}
1370
c5be433b 1371#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1372OP *
1373Perl_die_nocontext(const char* pat, ...)
a687059c 1374{
cea2e8a9
GS		 1375 dTHX;
1376 OP *o;
a687059c 1377 va_list args;
7918f24d 1378 PERL_ARGS_ASSERT_DIE_NOCONTEXT;
cea2e8a9 1379 va_start(args, pat);
c5be433b 1380 o = vdie(pat, &args);
cea2e8a9
GS		 1381 va_end(args);
1382 return o;
1383}
c5be433b 1384#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS		 1385
1386OP *
1387Perl_die(pTHX_ const char* pat, ...)
1388{
1389 OP *o;
1390 va_list args;
1391 va_start(args, pat);
c5be433b 1392 o = vdie(pat, &args);
cea2e8a9
GS		 1393 va_end(args);
1394 return o;
1395}
1396
c5be433b
GS		 1397void
1398Perl_vcroak(pTHX_ const char* pat, va_list *args)
cea2e8a9 1399{
97aff369 1400 dVAR;
73d840c0 1401 const char *message;
06bf62c7 1402 STRLEN msglen;
ff882698 1403 I32 utf8 = 0;
a687059c 1404
3ab1ac99 1405 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
5a844595 1406
3280af22 1407 if (PL_in_eval) {
06bf62c7 1408 PL_restartop = die_where(message, msglen);
ff882698 1409 SvFLAGS(ERRSV) |= utf8;
6224f72b 1410 JMPENV_JUMP(3);
a0d0e21e 1411 }
84414e3e 1412 else if (!message)
cfd0369c 1413 message = SvPVx_const(ERRSV, msglen);
84414e3e 1414
7ff03255 1415 write_to_stderr(message, msglen);
f86702cc 1416 my_failure_exit();
a687059c
LW		 1417}
1418
c5be433b 1419#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1420void
cea2e8a9 1421Perl_croak_nocontext(const char *pat, ...)
a687059c 1422{
cea2e8a9 1423 dTHX;
a687059c 1424 va_list args;
7918f24d 1425 PERL_ARGS_ASSERT_CROAK_NOCONTEXT;
cea2e8a9 1426 va_start(args, pat);
c5be433b 1427 vcroak(pat, &args);
cea2e8a9
GS		 1428 /* NOTREACHED */
1429 va_end(args);
1430}
1431#endif /* PERL_IMPLICIT_CONTEXT */
1432
954c1994 1433/*
ccfc67b7
JH		 1434=head1 Warning and Dieing
1435
954c1994
GS		 1436=for apidoc croak
1437
9983fa3c 1438This is the XSUB-writer's interface to Perl's C<die> function.
966353fd
MF		 1439Normally call this function the same way you call the C C<printf>
1440function. Calling C<croak> returns control directly to Perl,
1441sidestepping the normal C order of execution. See C<warn>.
9983fa3c
GS		 1442
1443If you want to throw an exception object, assign the object to
bd61b366 1444C<$@> and then pass C<NULL> to croak():
9983fa3c
GS		 1445
1446 errsv = get_sv("@", TRUE);
1447 sv_setsv(errsv, exception_object);
bd61b366 1448 croak(NULL);
954c1994
GS		 1449
1450=cut
1451*/
1452
cea2e8a9
GS		 1453void
1454Perl_croak(pTHX_ const char *pat, ...)
1455{
1456 va_list args;
1457 va_start(args, pat);
c5be433b 1458 vcroak(pat, &args);
cea2e8a9
GS		 1459 /* NOTREACHED */
1460 va_end(args);
1461}
1462
c5be433b
GS		 1463void
1464Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1465{
27da23d5 1466 dVAR;
06bf62c7 1467 STRLEN msglen;
53c1dcc0
AL		 1468 SV * const msv = vmess(pat, args);
1469 const I32 utf8 = SvUTF8(msv);
1470 const char * const message = SvPV_const(msv, msglen);
a687059c 1471
7918f24d
NC		 1472 PERL_ARGS_ASSERT_VWARN;
1473
3280af22 1474 if (PL_warnhook) {
46d9c920 1475 if (vdie_common(message, msglen, utf8, TRUE))
20cec16a 1476 return;
748a9306 1477 }
87582a92 1478
7ff03255 1479 write_to_stderr(message, msglen);
a687059c 1480}
8d063cd8 1481
c5be433b 1482#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1483void
1484Perl_warn_nocontext(const char *pat, ...)
1485{
1486 dTHX;
1487 va_list args;
7918f24d 1488 PERL_ARGS_ASSERT_WARN_NOCONTEXT;
cea2e8a9 1489 va_start(args, pat);
c5be433b 1490 vwarn(pat, &args);
cea2e8a9
GS		 1491 va_end(args);
1492}
1493#endif /* PERL_IMPLICIT_CONTEXT */
1494
954c1994
GS		 1495/*
1496=for apidoc warn
1497
966353fd
MF		 1498This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1499function the same way you call the C C<printf> function. See C<croak>.
954c1994
GS		 1500
1501=cut
1502*/
1503
cea2e8a9
GS		 1504void
1505Perl_warn(pTHX_ const char *pat, ...)
1506{
1507 va_list args;
7918f24d 1508 PERL_ARGS_ASSERT_WARN;
cea2e8a9 1509 va_start(args, pat);
c5be433b 1510 vwarn(pat, &args);
cea2e8a9
GS		 1511 va_end(args);
1512}
1513
c5be433b
GS		 1514#if defined(PERL_IMPLICIT_CONTEXT)
1515void
1516Perl_warner_nocontext(U32 err, const char *pat, ...)
1517{
27da23d5 1518 dTHX;
c5be433b 1519 va_list args;
7918f24d 1520 PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
c5be433b
GS		 1521 va_start(args, pat);
1522 vwarner(err, pat, &args);
1523 va_end(args);
1524}
1525#endif /* PERL_IMPLICIT_CONTEXT */
1526
599cee73 1527void
864dbfa3 1528Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1529{
1530 va_list args;
7918f24d 1531 PERL_ARGS_ASSERT_WARNER;
c5be433b
GS		 1532 va_start(args, pat);
1533 vwarner(err, pat, &args);
1534 va_end(args);
1535}
1536
1537void
1538Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1539{
27da23d5 1540 dVAR;
7918f24d 1541 PERL_ARGS_ASSERT_VWARNER;
5f2d9966 1542 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1543 SV * const msv = vmess(pat, args);
d13b0d77 1544 STRLEN msglen;
7452cf6a 1545 const char * const message = SvPV_const(msv, msglen);
a3b680e6 1546 const I32 utf8 = SvUTF8(msv);
599cee73 1547
3aed30dc 1548 if (PL_diehook) {
63315e18 1549 assert(message);
46d9c920 1550 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
3aed30dc
HS		 1551 }
1552 if (PL_in_eval) {
1553 PL_restartop = die_where(message, msglen);
ff882698 1554 SvFLAGS(ERRSV) |= utf8;
3aed30dc
HS		 1555 JMPENV_JUMP(3);
1556 }
7ff03255 1557 write_to_stderr(message, msglen);
3aed30dc 1558 my_failure_exit();
599cee73
PM		 1559 }
1560 else {
d13b0d77 1561 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 1562 }
1563}
1564
f54ba1c2
DM		 1565/* implements the ckWARN? macros */
1566
1567bool
1568Perl_ckwarn(pTHX_ U32 w)
1569{
97aff369 1570 dVAR;
f54ba1c2
DM		 1571 return
1572 (
1573 isLEXWARN_on
1574 && PL_curcop->cop_warnings != pWARN_NONE
1575 && (
1576 PL_curcop->cop_warnings == pWARN_ALL
1577 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1578 || (unpackWARN2(w) &&
1579 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1580 || (unpackWARN3(w) &&
1581 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1582 || (unpackWARN4(w) &&
1583 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1584 )
1585 )
1586 ||
1587 (
1588 isLEXWARN_off && PL_dowarn & G_WARN_ON
1589 )
1590 ;
1591}
1592
1593/* implements the ckWARN?_d macro */
1594
1595bool
1596Perl_ckwarn_d(pTHX_ U32 w)
1597{
97aff369 1598 dVAR;
f54ba1c2
DM		 1599 return
1600 isLEXWARN_off
1601 || PL_curcop->cop_warnings == pWARN_ALL
1602 || (
1603 PL_curcop->cop_warnings != pWARN_NONE
1604 && (
1605 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1606 || (unpackWARN2(w) &&
1607 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1608 || (unpackWARN3(w) &&
1609 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1610 || (unpackWARN4(w) &&
1611 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1612 )
1613 )
1614 ;
1615}
1616
72dc9ed5
NC		 1617/* Set buffer=NULL to get a new one. */
1618STRLEN *
8ee4cf24 1619Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5
NC		 1620 STRLEN size) {
1621 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
35da51f7 1622 PERL_UNUSED_CONTEXT;
7918f24d 1623 PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
72dc9ed5 1624
10edeb5d
JH		 1625 buffer = (STRLEN*)
1626 (specialWARN(buffer) ?
1627 PerlMemShared_malloc(len_wanted) :
1628 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC		 1629 buffer[0] = size;
1630 Copy(bits, (buffer + 1), size, char);
1631 return buffer;
1632}
f54ba1c2 1633
e6587932
DM		 1634/* since we've already done strlen() for both nam and val
1635 * we can use that info to make things faster than
1636 * sprintf(s, "%s=%s", nam, val)
1637 */
1638#define my_setenv_format(s, nam, nlen, val, vlen) \
1639 Copy(nam, s, nlen, char); \
1640 *(s+nlen) = '='; \
1641 Copy(val, s+(nlen+1), vlen, char); \
1642 *(s+(nlen+1+vlen)) = '\0'
1643
c5d12488
JH		 1644#ifdef USE_ENVIRON_ARRAY
1645 /* VMS' my_setenv() is in vms.c */
1646#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1647void
e1ec3a88 1648Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1649{
27da23d5 1650 dVAR;
4efc5df6
GS		 1651#ifdef USE_ITHREADS
1652 /* only parent thread can modify process environment */
1653 if (PL_curinterp == aTHX)
1654#endif
1655 {
f2517201 1656#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1657 if (!PL_use_safe_putenv) {
c5d12488
JH		 1658 /* most putenv()s leak, so we manipulate environ directly */
1659 register I32 i=setenv_getix(nam); /* where does it go? */
1660 int nlen, vlen;
1661
1662 if (environ == PL_origenviron) { /* need we copy environment? */
1663 I32 j;
1664 I32 max;
1665 char **tmpenv;
1666
1667 max = i;
1668 while (environ[max])
1669 max++;
1670 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1671 for (j=0; j<max; j++) { /* copy environment */
1672 const int len = strlen(environ[j]);
1673 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1674 Copy(environ[j], tmpenv[j], len+1, char);
1675 }
1676 tmpenv[max] = NULL;
1677 environ = tmpenv; /* tell exec where it is now */
1678 }
1679 if (!val) {
1680 safesysfree(environ[i]);
1681 while (environ[i]) {
1682 environ[i] = environ[i+1];
1683 i++;
a687059c 1684 }
c5d12488
JH		 1685 return;
1686 }
1687 if (!environ[i]) { /* does not exist yet */
1688 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1689 environ[i+1] = NULL; /* make sure it's null terminated */
1690 }
1691 else
1692 safesysfree(environ[i]);
1693 nlen = strlen(nam);
1694 vlen = strlen(val);
1695
1696 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1697 /* all that work just for this */
1698 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1699 } else {
c5d12488 1700# endif
7ee146b1 1701# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB		 1702# if defined(HAS_UNSETENV)
1703 if (val == NULL) {
1704 (void)unsetenv(nam);
1705 } else {
1706 (void)setenv(nam, val, 1);
1707 }
1708# else /* ! HAS_UNSETENV */
1709 (void)setenv(nam, val, 1);
1710# endif /* HAS_UNSETENV */
47dafe4d 1711# else
88f5bc07
AB		 1712# if defined(HAS_UNSETENV)
1713 if (val == NULL) {
1714 (void)unsetenv(nam);
1715 } else {
c4420975
AL		 1716 const int nlen = strlen(nam);
1717 const int vlen = strlen(val);
1718 char * const new_env =
88f5bc07
AB		 1719 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1720 my_setenv_format(new_env, nam, nlen, val, vlen);
1721 (void)putenv(new_env);
1722 }
1723# else /* ! HAS_UNSETENV */
1724 char *new_env;
c4420975
AL		 1725 const int nlen = strlen(nam);
1726 int vlen;
88f5bc07
AB		 1727 if (!val) {
1728 val = "";
1729 }
1730 vlen = strlen(val);
1731 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1732 /* all that work just for this */
1733 my_setenv_format(new_env, nam, nlen, val, vlen);
1734 (void)putenv(new_env);
1735# endif /* HAS_UNSETENV */
47dafe4d 1736# endif /* __CYGWIN__ */
50acdf95
MS		 1737#ifndef PERL_USE_SAFE_PUTENV
1738 }
1739#endif
4efc5df6 1740 }
8d063cd8
LW		 1741}
1742
c5d12488 1743#else /* WIN32 || NETWARE */
68dc0745 1744
1745void
72229eff 1746Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1747{
27da23d5 1748 dVAR;
c5d12488
JH		 1749 register char *envstr;
1750 const int nlen = strlen(nam);
1751 int vlen;
e6587932 1752
c5d12488
JH		 1753 if (!val) {
1754 val = "";
ac5c734f 1755 }
c5d12488
JH		 1756 vlen = strlen(val);
1757 Newx(envstr, nlen+vlen+2, char);
1758 my_setenv_format(envstr, nam, nlen, val, vlen);
1759 (void)PerlEnv_putenv(envstr);
1760 Safefree(envstr);
3e3baf6d
TB		 1761}
1762
c5d12488 1763#endif /* WIN32 || NETWARE */
3e3baf6d 1764
c5d12488 1765#ifndef PERL_MICRO
3e3baf6d 1766I32
e1ec3a88 1767Perl_setenv_getix(pTHX_ const char *nam)
3e3baf6d 1768{
c5d12488 1769 register I32 i;
0d46e09a 1770 register const I32 len = strlen(nam);
7918f24d
NC		 1771
1772 PERL_ARGS_ASSERT_SETENV_GETIX;
96a5add6 1773 PERL_UNUSED_CONTEXT;
3e3baf6d
TB		 1774
1775 for (i = 0; environ[i]; i++) {
1776 if (
1777#ifdef WIN32
1778 strnicmp(environ[i],nam,len) == 0
1779#else
1780 strnEQ(environ[i],nam,len)
1781#endif
1782 && environ[i][len] == '=')
1783 break; /* strnEQ must come first to avoid */
1784 } /* potential SEGV's */
1785 return i;
68dc0745 1786}
c5d12488 1787#endif /* !PERL_MICRO */
68dc0745 1788
c5d12488 1789#endif /* !VMS && !EPOC*/
378cc40b 1790
16d20bd9 1791#ifdef UNLINK_ALL_VERSIONS
79072805 1792I32
6e732051 1793Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 1794{
35da51f7 1795 I32 retries = 0;
378cc40b 1796
7918f24d
NC		 1797 PERL_ARGS_ASSERT_UNLNK;
1798
35da51f7
AL		 1799 while (PerlLIO_unlink(f) >= 0)
1800 retries++;
1801 return retries ? 0 : -1;
378cc40b
LW		 1802}
1803#endif
1804
7a3f2258 1805/* this is a drop-in replacement for bcopy() */
2253333f 1806#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1807char *
7a3f2258 1808Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b 1809{
2d03de9c 1810 char * const retval = to;
378cc40b 1811
7918f24d
NC		 1812 PERL_ARGS_ASSERT_MY_BCOPY;
1813
7c0587c8
LW		 1814 if (from - to >= 0) {
1815 while (len--)
1816 *to++ = *from++;
1817 }
1818 else {
1819 to += len;
1820 from += len;
1821 while (len--)
faf8582f 1822 *(--to) = *(--from);
7c0587c8 1823 }
378cc40b
LW		 1824 return retval;
1825}
ffed7fef 1826#endif
378cc40b 1827
7a3f2258 1828/* this is a drop-in replacement for memset() */
fc36a67e 1829#ifndef HAS_MEMSET
1830void *
7a3f2258 1831Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1832{
2d03de9c 1833 char * const retval = loc;
fc36a67e 1834
7918f24d
NC		 1835 PERL_ARGS_ASSERT_MY_MEMSET;
1836
fc36a67e 1837 while (len--)
1838 *loc++ = ch;
1839 return retval;
1840}
1841#endif
1842
7a3f2258 1843/* this is a drop-in replacement for bzero() */
7c0587c8 1844#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1845char *
7a3f2258 1846Perl_my_bzero(register char *loc, register I32 len)
378cc40b 1847{
2d03de9c 1848 char * const retval = loc;
378cc40b 1849
7918f24d
NC		 1850 PERL_ARGS_ASSERT_MY_BZERO;
1851
378cc40b
LW		 1852 while (len--)
1853 *loc++ = 0;
1854 return retval;
1855}
1856#endif
7c0587c8 1857
7a3f2258 1858/* this is a drop-in replacement for memcmp() */
36477c24 1859#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1860I32
7a3f2258 1861Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1862{
e1ec3a88
AL		 1863 register const U8 *a = (const U8 *)s1;
1864 register const U8 *b = (const U8 *)s2;
79072805 1865 register I32 tmp;
7c0587c8 1866
7918f24d
NC		 1867 PERL_ARGS_ASSERT_MY_MEMCMP;
1868
7c0587c8 1869 while (len--) {
27da23d5 1870 if ((tmp = *a++ - *b++))
7c0587c8
LW		 1871 return tmp;
1872 }
1873 return 0;
1874}
36477c24 1875#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1876
fe14fcc3 1877#ifndef HAS_VPRINTF
d05d9be5
AD		 1878/* This vsprintf replacement should generally never get used, since
1879 vsprintf was available in both System V and BSD 2.11. (There may
1880 be some cross-compilation or embedded set-ups where it is needed,
1881 however.)
1882
1883 If you encounter a problem in this function, it's probably a symptom
1884 that Configure failed to detect your system's vprintf() function.
1885 See the section on "item vsprintf" in the INSTALL file.
1886
1887 This version may compile on systems with BSD-ish <stdio.h>,
1888 but probably won't on others.
1889*/
a687059c 1890
85e6fe83 1891#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1892char *
1893#else
1894int
1895#endif
d05d9be5 1896vsprintf(char *dest, const char *pat, void *args)
a687059c
LW		 1897{
1898 FILE fakebuf;
1899
d05d9be5
AD		 1900#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1901 FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1902 FILE_cnt(&fakebuf) = 32767;
1903#else
1904 /* These probably won't compile -- If you really need
1905 this, you'll have to figure out some other method. */
a687059c
LW		 1906 fakebuf._ptr = dest;
1907 fakebuf._cnt = 32767;
d05d9be5 1908#endif
35c8bce7
LW		 1909#ifndef _IOSTRG
1910#define _IOSTRG 0
1911#endif
a687059c
LW		 1912 fakebuf._flag = _IOWRT|_IOSTRG;
1913 _doprnt(pat, args, &fakebuf); /* what a kludge */
d05d9be5
AD		 1914#if defined(STDIO_PTR_LVALUE)
1915 *(FILE_ptr(&fakebuf)++) = '\0';
1916#else
1917 /* PerlIO has probably #defined away fputc, but we want it here. */
1918# ifdef fputc
1919# undef fputc /* XXX Should really restore it later */
1920# endif
1921 (void)fputc('\0', &fakebuf);
1922#endif
85e6fe83 1923#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1924 return(dest);
1925#else
1926 return 0; /* perl doesn't use return value */
1927#endif
1928}
1929
fe14fcc3 1930#endif /* HAS_VPRINTF */
a687059c
LW		 1931
1932#ifdef MYSWAP
ffed7fef 1933#if BYTEORDER != 0x4321
a687059c 1934short
864dbfa3 1935Perl_my_swap(pTHX_ short s)
a687059c
LW		 1936{
1937#if (BYTEORDER & 1) == 0
1938 short result;
1939
1940 result = ((s & 255) << 8) + ((s >> 8) & 255);
1941 return result;
1942#else
1943 return s;
1944#endif
1945}
1946
1947long
864dbfa3 1948Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1949{
1950 union {
1951 long result;
ffed7fef 1952 char c[sizeof(long)];
a687059c
LW		 1953 } u;
1954
cef6ea9d
JH		 1955#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1956#if BYTEORDER == 0x12345678
1957 u.result = 0;
1958#endif
a687059c
LW		 1959 u.c[0] = (l >> 24) & 255;
1960 u.c[1] = (l >> 16) & 255;
1961 u.c[2] = (l >> 8) & 255;
1962 u.c[3] = l & 255;
1963 return u.result;
1964#else
ffed7fef 1965#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1966 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1967#else
79072805
LW		 1968 register I32 o;
1969 register I32 s;
a687059c 1970
ffed7fef
LW		 1971 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1972 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1973 }
1974 return u.result;
1975#endif
1976#endif
1977}
1978
1979long
864dbfa3 1980Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1981{
1982 union {
1983 long l;
ffed7fef 1984 char c[sizeof(long)];
a687059c
LW		 1985 } u;
1986
ffed7fef 1987#if BYTEORDER == 0x1234
a687059c
LW		 1988 u.c[0] = (l >> 24) & 255;
1989 u.c[1] = (l >> 16) & 255;
1990 u.c[2] = (l >> 8) & 255;
1991 u.c[3] = l & 255;
1992 return u.l;
1993#else
ffed7fef 1994#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1995 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1996#else
79072805
LW		 1997 register I32 o;
1998 register I32 s;
a687059c
LW		 1999
2000 u.l = l;
2001 l = 0;
ffed7fef
LW		 2002 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2003 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 2004 }
2005 return l;
2006#endif
2007#endif
2008}
2009
ffed7fef 2010#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 2011#endif /* MYSWAP */
2012
2013/*
2014 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2015 * If these functions are defined,
2016 * the BYTEORDER is neither 0x1234 nor 0x4321.
2017 * However, this is not assumed.
2018 * -DWS
2019 */
2020
1109a392 2021#define HTOLE(name,type) \
988174c1 2022 type \
ba106d47 2023 name (register type n) \
988174c1
LW		 2024 { \
2025 union { \
2026 type value; \
2027 char c[sizeof(type)]; \
2028 } u; \
bb7a0f54
MHM		 2029 register U32 i; \
2030 register U32 s = 0; \
1109a392 2031 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW		 2032 u.c[i] = (n >> s) & 0xFF; \
2033 } \
2034 return u.value; \
2035 }
2036
1109a392 2037#define LETOH(name,type) \
988174c1 2038 type \
ba106d47 2039 name (register type n) \
988174c1
LW		 2040 { \
2041 union { \
2042 type value; \
2043 char c[sizeof(type)]; \
2044 } u; \
bb7a0f54
MHM		 2045 register U32 i; \
2046 register U32 s = 0; \
988174c1
LW		 2047 u.value = n; \
2048 n = 0; \
1109a392
MHM		 2049 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
2050 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW		 2051 } \
2052 return n; \
2053 }
2054
1109a392
MHM		 2055/*
2056 * Big-endian byte order functions.
2057 */
2058
2059#define HTOBE(name,type) \
2060 type \
2061 name (register type n) \
2062 { \
2063 union { \
2064 type value; \
2065 char c[sizeof(type)]; \
2066 } u; \
bb7a0f54
MHM		 2067 register U32 i; \
2068 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 2069 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2070 u.c[i] = (n >> s) & 0xFF; \
2071 } \
2072 return u.value; \
2073 }
2074
2075#define BETOH(name,type) \
2076 type \
2077 name (register type n) \
2078 { \
2079 union { \
2080 type value; \
2081 char c[sizeof(type)]; \
2082 } u; \
bb7a0f54
MHM		 2083 register U32 i; \
2084 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 2085 u.value = n; \
2086 n = 0; \
2087 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
2088 n |= ((type)(u.c[i] & 0xFF)) << s; \
2089 } \
2090 return n; \
2091 }
2092
2093/*
2094 * If we just can't do it...
2095 */
2096
2097#define NOT_AVAIL(name,type) \
2098 type \
2099 name (register type n) \
2100 { \
2101 Perl_croak_nocontext(#name "() not available"); \
2102 return n; /* not reached */ \
2103 }
2104
2105
988174c1 2106#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 2107HTOLE(htovs,short)
988174c1
LW		 2108#endif
2109#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 2110HTOLE(htovl,long)
988174c1
LW		 2111#endif
2112#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 2113LETOH(vtohs,short)
988174c1
LW		 2114#endif
2115#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM		 2116LETOH(vtohl,long)
2117#endif
2118
2119#ifdef PERL_NEED_MY_HTOLE16
2120# if U16SIZE == 2
2121HTOLE(Perl_my_htole16,U16)
2122# else
2123NOT_AVAIL(Perl_my_htole16,U16)
2124# endif
2125#endif
2126#ifdef PERL_NEED_MY_LETOH16
2127# if U16SIZE == 2
2128LETOH(Perl_my_letoh16,U16)
2129# else
2130NOT_AVAIL(Perl_my_letoh16,U16)
2131# endif
2132#endif
2133#ifdef PERL_NEED_MY_HTOBE16
2134# if U16SIZE == 2
2135HTOBE(Perl_my_htobe16,U16)
2136# else
2137NOT_AVAIL(Perl_my_htobe16,U16)
2138# endif
2139#endif
2140#ifdef PERL_NEED_MY_BETOH16
2141# if U16SIZE == 2
2142BETOH(Perl_my_betoh16,U16)
2143# else
2144NOT_AVAIL(Perl_my_betoh16,U16)
2145# endif
2146#endif
2147
2148#ifdef PERL_NEED_MY_HTOLE32
2149# if U32SIZE == 4
2150HTOLE(Perl_my_htole32,U32)
2151# else
2152NOT_AVAIL(Perl_my_htole32,U32)
2153# endif
2154#endif
2155#ifdef PERL_NEED_MY_LETOH32
2156# if U32SIZE == 4
2157LETOH(Perl_my_letoh32,U32)
2158# else
2159NOT_AVAIL(Perl_my_letoh32,U32)
2160# endif
2161#endif
2162#ifdef PERL_NEED_MY_HTOBE32
2163# if U32SIZE == 4
2164HTOBE(Perl_my_htobe32,U32)
2165# else
2166NOT_AVAIL(Perl_my_htobe32,U32)
2167# endif
2168#endif
2169#ifdef PERL_NEED_MY_BETOH32
2170# if U32SIZE == 4
2171BETOH(Perl_my_betoh32,U32)
2172# else
2173NOT_AVAIL(Perl_my_betoh32,U32)
2174# endif
2175#endif
2176
2177#ifdef PERL_NEED_MY_HTOLE64
2178# if U64SIZE == 8
2179HTOLE(Perl_my_htole64,U64)
2180# else
2181NOT_AVAIL(Perl_my_htole64,U64)
2182# endif
2183#endif
2184#ifdef PERL_NEED_MY_LETOH64
2185# if U64SIZE == 8
2186LETOH(Perl_my_letoh64,U64)
2187# else
2188NOT_AVAIL(Perl_my_letoh64,U64)
2189# endif
2190#endif
2191#ifdef PERL_NEED_MY_HTOBE64
2192# if U64SIZE == 8
2193HTOBE(Perl_my_htobe64,U64)
2194# else
2195NOT_AVAIL(Perl_my_htobe64,U64)
2196# endif
2197#endif
2198#ifdef PERL_NEED_MY_BETOH64
2199# if U64SIZE == 8
2200BETOH(Perl_my_betoh64,U64)
2201# else
2202NOT_AVAIL(Perl_my_betoh64,U64)
2203# endif
988174c1 2204#endif
a687059c 2205
1109a392
MHM		 2206#ifdef PERL_NEED_MY_HTOLES
2207HTOLE(Perl_my_htoles,short)
2208#endif
2209#ifdef PERL_NEED_MY_LETOHS
2210LETOH(Perl_my_letohs,short)
2211#endif
2212#ifdef PERL_NEED_MY_HTOBES
2213HTOBE(Perl_my_htobes,short)
2214#endif
2215#ifdef PERL_NEED_MY_BETOHS
2216BETOH(Perl_my_betohs,short)
2217#endif
2218
2219#ifdef PERL_NEED_MY_HTOLEI
2220HTOLE(Perl_my_htolei,int)
2221#endif
2222#ifdef PERL_NEED_MY_LETOHI
2223LETOH(Perl_my_letohi,int)
2224#endif
2225#ifdef PERL_NEED_MY_HTOBEI
2226HTOBE(Perl_my_htobei,int)
2227#endif
2228#ifdef PERL_NEED_MY_BETOHI
2229BETOH(Perl_my_betohi,int)
2230#endif
2231
2232#ifdef PERL_NEED_MY_HTOLEL
2233HTOLE(Perl_my_htolel,long)
2234#endif
2235#ifdef PERL_NEED_MY_LETOHL
2236LETOH(Perl_my_letohl,long)
2237#endif
2238#ifdef PERL_NEED_MY_HTOBEL
2239HTOBE(Perl_my_htobel,long)
2240#endif
2241#ifdef PERL_NEED_MY_BETOHL
2242BETOH(Perl_my_betohl,long)
2243#endif
2244
2245void
2246Perl_my_swabn(void *ptr, int n)
2247{
2248 register char *s = (char *)ptr;
2249 register char *e = s + (n-1);
2250 register char tc;
2251
7918f24d
NC		 2252 PERL_ARGS_ASSERT_MY_SWABN;
2253
1109a392
MHM		 2254 for (n /= 2; n > 0; s++, e--, n--) {
2255 tc = *s;
2256 *s = *e;
2257 *e = tc;
2258 }
2259}
2260
4a7d1889 2261PerlIO *
c9289b7b 2262Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
4a7d1889 2263{
9c12f1e5 2264#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
97aff369 2265 dVAR;
1f852d0d
NIS		 2266 int p[2];
2267 register I32 This, that;
2268 register Pid_t pid;
2269 SV *sv;
2270 I32 did_pipes = 0;
2271 int pp[2];
2272
7918f24d
NC		 2273 PERL_ARGS_ASSERT_MY_POPEN_LIST;
2274
1f852d0d
NIS		 2275 PERL_FLUSHALL_FOR_CHILD;
2276 This = (*mode == 'w');
2277 that = !This;
2278 if (PL_tainting) {
2279 taint_env();
2280 taint_proper("Insecure %s%s", "EXEC");
2281 }
2282 if (PerlProc_pipe(p) < 0)
4608196e 2283 return NULL;
1f852d0d
NIS		 2284 /* Try for another pipe pair for error return */
2285 if (PerlProc_pipe(pp) >= 0)
2286 did_pipes = 1;
52e18b1f 2287 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 2288 if (errno != EAGAIN) {
2289 PerlLIO_close(p[This]);
4e6dfe71 2290 PerlLIO_close(p[that]);
1f852d0d
NIS		 2291 if (did_pipes) {
2292 PerlLIO_close(pp[0]);
2293 PerlLIO_close(pp[1]);
2294 }
4608196e 2295 return NULL;
1f852d0d
NIS		 2296 }
2297 sleep(5);
2298 }
2299 if (pid == 0) {
2300 /* Child */
1f852d0d
NIS		 2301#undef THIS
2302#undef THAT
2303#define THIS that
2304#define THAT This
1f852d0d
NIS		 2305 /* Close parent's end of error status pipe (if any) */
2306 if (did_pipes) {
2307 PerlLIO_close(pp[0]);
2308#if defined(HAS_FCNTL) && defined(F_SETFD)
2309 /* Close error pipe automatically if exec works */
2310 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2311#endif
2312 }
2313 /* Now dup our end of _the_ pipe to right position */
2314 if (p[THIS] != (*mode == 'r')) {
2315 PerlLIO_dup2(p[THIS], *mode == 'r');
2316 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 2317 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2318 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2319 }
4e6dfe71
GS		 2320 else
2321 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2322#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2323 /* No automatic close - do it by hand */
b7953727
JH		 2324# ifndef NOFILE
2325# define NOFILE 20
2326# endif
a080fe3d
NIS		 2327 {
2328 int fd;
2329
2330 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2331 if (fd != pp[1])
a080fe3d
NIS		 2332 PerlLIO_close(fd);
2333 }
1f852d0d
NIS		 2334 }
2335#endif
a0714e2c 2336 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS		 2337 PerlProc__exit(1);
2338#undef THIS
2339#undef THAT
2340 }
2341 /* Parent */
52e18b1f 2342 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2343 if (did_pipes)
2344 PerlLIO_close(pp[1]);
2345 /* Keep the lower of the two fd numbers */
2346 if (p[that] < p[This]) {
2347 PerlLIO_dup2(p[This], p[that]);
2348 PerlLIO_close(p[This]);
2349 p[This] = p[that];
2350 }
4e6dfe71
GS		 2351 else
2352 PerlLIO_close(p[that]); /* close child's end of pipe */
2353
1f852d0d
NIS		 2354 LOCK_FDPID_MUTEX;
2355 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2356 UNLOCK_FDPID_MUTEX;
862a34c6 2357 SvUPGRADE(sv,SVt_IV);
45977657 2358 SvIV_set(sv, pid);
1f852d0d
NIS		 2359 PL_forkprocess = pid;
2360 /* If we managed to get status pipe check for exec fail */
2361 if (did_pipes && pid > 0) {
2362 int errkid;
bb7a0f54
MHM		 2363 unsigned n = 0;
2364 SSize_t n1;
1f852d0d
NIS		 2365
2366 while (n < sizeof(int)) {
2367 n1 = PerlLIO_read(pp[0],
2368 (void*)(((char*)&errkid)+n),
2369 (sizeof(int)) - n);
2370 if (n1 <= 0)
2371 break;
2372 n += n1;
2373 }
2374 PerlLIO_close(pp[0]);
2375 did_pipes = 0;
2376 if (n) { /* Error */
2377 int pid2, status;
8c51524e 2378 PerlLIO_close(p[This]);
1f852d0d
NIS		 2379 if (n != sizeof(int))
2380 Perl_croak(aTHX_ "panic: kid popen errno read");
2381 do {
2382 pid2 = wait4pid(pid, &status, 0);
2383 } while (pid2 == -1 && errno == EINTR);
2384 errno = errkid; /* Propagate errno from kid */
4608196e 2385 return NULL;
1f852d0d
NIS		 2386 }
2387 }
2388 if (did_pipes)
2389 PerlLIO_close(pp[0]);
2390 return PerlIO_fdopen(p[This], mode);
2391#else
9d419b5f 2392# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
4e205ed6 2393 return my_syspopen4(aTHX_ NULL, mode, n, args);
9d419b5f 2394# else
4a7d1889
NIS		 2395 Perl_croak(aTHX_ "List form of piped open not implemented");
2396 return (PerlIO *) NULL;
9d419b5f 2397# endif
1f852d0d 2398#endif
4a7d1889
NIS		 2399}
2400
5f05dabc 2401 /* VMS' my_popen() is in VMS.c, same with OS/2. */
9c12f1e5 2402#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
760ac839 2403PerlIO *
3dd43144 2404Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2405{
97aff369 2406 dVAR;
a687059c 2407 int p[2];
8ac85365 2408 register I32 This, that;
d8a83dd3 2409 register Pid_t pid;
79072805 2410 SV *sv;
bfce84ec 2411 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2412 I32 did_pipes = 0;
2413 int pp[2];
a687059c 2414
7918f24d
NC		 2415 PERL_ARGS_ASSERT_MY_POPEN;
2416
45bc9206 2417 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2418#ifdef OS2
2419 if (doexec) {
23da6c43 2420 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2421 }
a1d180c4 2422#endif
8ac85365
NIS		 2423 This = (*mode == 'w');
2424 that = !This;
3280af22 2425 if (doexec && PL_tainting) {
bbce6d69 2426 taint_env();
2427 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2428 }
c2267164 2429 if (PerlProc_pipe(p) < 0)
4608196e 2430 return NULL;
e446cec8
IZ		 2431 if (doexec && PerlProc_pipe(pp) >= 0)
2432 did_pipes = 1;
52e18b1f 2433 while ((pid = PerlProc_fork()) < 0) {
a687059c 2434 if (errno != EAGAIN) {
6ad3d225 2435 PerlLIO_close(p[This]);
b5ac89c3 2436 PerlLIO_close(p[that]);
e446cec8
IZ		 2437 if (did_pipes) {
2438 PerlLIO_close(pp[0]);
2439 PerlLIO_close(pp[1]);
2440 }
a687059c 2441 if (!doexec)
cea2e8a9 2442 Perl_croak(aTHX_ "Can't fork");
4608196e 2443 return NULL;
a687059c
LW		 2444 }
2445 sleep(5);
2446 }
2447 if (pid == 0) {
79072805
LW		 2448 GV* tmpgv;
2449
30ac6d9b
GS		 2450#undef THIS
2451#undef THAT
a687059c 2452#define THIS that
8ac85365 2453#define THAT This
e446cec8
IZ		 2454 if (did_pipes) {
2455 PerlLIO_close(pp[0]);
2456#if defined(HAS_FCNTL) && defined(F_SETFD)
2457 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2458#endif
2459 }
a687059c 2460 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2461 PerlLIO_dup2(p[THIS], *mode == 'r');
2462 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2463 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2464 PerlLIO_close(p[THAT]);
a687059c 2465 }
b5ac89c3
NIS		 2466 else
2467 PerlLIO_close(p[THAT]);
4435c477 2468#ifndef OS2
a687059c 2469 if (doexec) {
a0d0e21e 2470#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2471#ifndef NOFILE
2472#define NOFILE 20
2473#endif
a080fe3d 2474 {
3aed30dc 2475 int fd;
a080fe3d
NIS		 2476
2477 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2478 if (fd != pp[1])
3aed30dc 2479 PerlLIO_close(fd);
a080fe3d 2480 }
ae986130 2481#endif
a080fe3d
NIS		 2482 /* may or may not use the shell */
2483 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2484 PerlProc__exit(1);
a687059c 2485 }
4435c477 2486#endif /* defined OS2 */
713cef20
IZ		 2487
2488#ifdef PERLIO_USING_CRLF
2489 /* Since we circumvent IO layers when we manipulate low-level
2490 filedescriptors directly, need to manually switch to the
2491 default, binary, low-level mode; see PerlIOBuf_open(). */
2492 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2493#endif
2494
fafc274c 2495 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2496 SvREADONLY_off(GvSV(tmpgv));
7766f137 2497 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2498 SvREADONLY_on(GvSV(tmpgv));
2499 }
2500#ifdef THREADS_HAVE_PIDS
2501 PL_ppid = (IV)getppid();
2502#endif
3280af22 2503 PL_forkprocess = 0;
ca0c25f6 2504#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2505 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2506#endif
4608196e 2507 return NULL;
a687059c
LW		 2508#undef THIS
2509#undef THAT
2510 }
b5ac89c3 2511 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2512 if (did_pipes)
2513 PerlLIO_close(pp[1]);
8ac85365 2514 if (p[that] < p[This]) {
6ad3d225
GS		 2515 PerlLIO_dup2(p[This], p[that]);
2516 PerlLIO_close(p[This]);
8ac85365 2517 p[This] = p[that];
62b28dd9 2518 }
b5ac89c3
NIS		 2519 else
2520 PerlLIO_close(p[that]);
2521
4755096e 2522 LOCK_FDPID_MUTEX;
3280af22 2523 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2524 UNLOCK_FDPID_MUTEX;
862a34c6 2525 SvUPGRADE(sv,SVt_IV);
45977657 2526 SvIV_set(sv, pid);
3280af22 2527 PL_forkprocess = pid;
e446cec8
IZ		 2528 if (did_pipes && pid > 0) {
2529 int errkid;
bb7a0f54
MHM		 2530 unsigned n = 0;
2531 SSize_t n1;
e446cec8
IZ		 2532
2533 while (n < sizeof(int)) {
2534 n1 = PerlLIO_read(pp[0],
2535 (void*)(((char*)&errkid)+n),
2536 (sizeof(int)) - n);
2537 if (n1 <= 0)
2538 break;
2539 n += n1;
2540 }
2f96c702
IZ		 2541 PerlLIO_close(pp[0]);
2542 did_pipes = 0;
e446cec8 2543 if (n) { /* Error */
faa466a7 2544 int pid2, status;
8c51524e 2545 PerlLIO_close(p[This]);
e446cec8 2546 if (n != sizeof(int))
cea2e8a9 2547 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2548 do {
2549 pid2 = wait4pid(pid, &status, 0);
2550 } while (pid2 == -1 && errno == EINTR);
e446cec8 2551 errno = errkid; /* Propagate errno from kid */
4608196e 2552 return NULL;
e446cec8
IZ		 2553 }
2554 }
2555 if (did_pipes)
2556 PerlLIO_close(pp[0]);
8ac85365 2557 return PerlIO_fdopen(p[This], mode);
a687059c 2558}
7c0587c8 2559#else
85ca448a 2560#if defined(atarist) || defined(EPOC)
7c0587c8 2561FILE *popen();
760ac839 2562PerlIO *
cef6ea9d 2563Perl_my_popen(pTHX_ const char *cmd, const char *mode)
7c0587c8 2564{
7918f24d 2565 PERL_ARGS_ASSERT_MY_POPEN;
45bc9206 2566 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2567 /* Call system's popen() to get a FILE *, then import it.
2568 used 0 for 2nd parameter to PerlIO_importFILE;
2569 apparently not used
2570 */
2571 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2572}
2b96b0a5
JH		 2573#else
2574#if defined(DJGPP)
2575FILE *djgpp_popen();
2576PerlIO *
cef6ea9d 2577Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH		 2578{
2579 PERL_FLUSHALL_FOR_CHILD;
2580 /* Call system's popen() to get a FILE *, then import it.
2581 used 0 for 2nd parameter to PerlIO_importFILE;
2582 apparently not used
2583 */
2584 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2585}
9c12f1e5
RGS		 2586#else
2587#if defined(__LIBCATAMOUNT__)
2588PerlIO *
2589Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2590{
2591 return NULL;
2592}
2593#endif
2b96b0a5 2594#endif
7c0587c8
LW		 2595#endif
2596
2597#endif /* !DOSISH */
a687059c 2598
52e18b1f
GS		 2599/* this is called in parent before the fork() */
2600void
2601Perl_atfork_lock(void)
2602{
27da23d5 2603 dVAR;
3db8f154 2604#if defined(USE_ITHREADS)
52e18b1f
GS		 2605 /* locks must be held in locking order (if any) */
2606# ifdef MYMALLOC
2607 MUTEX_LOCK(&PL_malloc_mutex);
2608# endif
2609 OP_REFCNT_LOCK;
2610#endif
2611}
2612
2613/* this is called in both parent and child after the fork() */
2614void
2615Perl_atfork_unlock(void)
2616{
27da23d5 2617 dVAR;
3db8f154 2618#if defined(USE_ITHREADS)
52e18b1f
GS		 2619 /* locks must be released in same order as in atfork_lock() */
2620# ifdef MYMALLOC
2621 MUTEX_UNLOCK(&PL_malloc_mutex);
2622# endif
2623 OP_REFCNT_UNLOCK;
2624#endif
2625}
2626
2627Pid_t
2628Perl_my_fork(void)
2629{
2630#if defined(HAS_FORK)
2631 Pid_t pid;
3db8f154 2632#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2633 atfork_lock();
2634 pid = fork();
2635 atfork_unlock();
2636#else
2637 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2638 * handlers elsewhere in the code */
2639 pid = fork();
2640#endif
2641 return pid;
2642#else
2643 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2644 Perl_croak_nocontext("fork() not available");
b961a566 2645 return 0;
52e18b1f
GS		 2646#endif /* HAS_FORK */
2647}
2648
748a9306 2649#ifdef DUMP_FDS
35ff7856 2650void
c9289b7b 2651Perl_dump_fds(pTHX_ const char *const s)
ae986130
LW		 2652{
2653 int fd;
c623ac67 2654 Stat_t tmpstatbuf;
ae986130 2655
7918f24d
NC		 2656 PERL_ARGS_ASSERT_DUMP_FDS;
2657
bf49b057 2658 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2659 for (fd = 0; fd < 32; fd++) {
6ad3d225 2660 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2661 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2662 }
bf49b057 2663 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2664 return;
ae986130 2665}
35ff7856 2666#endif /* DUMP_FDS */
ae986130 2667
fe14fcc3 2668#ifndef HAS_DUP2
fec02dd3 2669int
ba106d47 2670dup2(int oldfd, int newfd)
a687059c 2671{
a0d0e21e 2672#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2673 if (oldfd == newfd)
2674 return oldfd;
6ad3d225 2675 PerlLIO_close(newfd);
fec02dd3 2676 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2677#else
fc36a67e 2678#define DUP2_MAX_FDS 256
2679 int fdtmp[DUP2_MAX_FDS];
79072805 2680 I32 fdx = 0;
ae986130
LW		 2681 int fd;
2682
fe14fcc3 2683 if (oldfd == newfd)
fec02dd3 2684 return oldfd;
6ad3d225 2685 PerlLIO_close(newfd);
fc36a67e 2686 /* good enough for low fd's... */
6ad3d225 2687 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2688 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2689 PerlLIO_close(fd);
fc36a67e 2690 fd = -1;
2691 break;
2692 }
ae986130 2693 fdtmp[fdx++] = fd;
fc36a67e 2694 }
ae986130 2695 while (fdx > 0)
6ad3d225 2696 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2697 return fd;
62b28dd9 2698#endif
a687059c
LW		 2699}
2700#endif
2701
64ca3a65 2702#ifndef PERL_MICRO
ff68c719 2703#ifdef HAS_SIGACTION
2704
abea2c45
HS		 2705#ifdef MACOS_TRADITIONAL
2706/* We don't want restart behavior on MacOS */
2707#undef SA_RESTART
2708#endif
2709
ff68c719 2710Sighandler_t
864dbfa3 2711Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2712{
27da23d5 2713 dVAR;
ff68c719 2714 struct sigaction act, oact;
2715
a10b1e10
JH		 2716#ifdef USE_ITHREADS
2717 /* only "parent" interpreter can diddle signals */
2718 if (PL_curinterp != aTHX)
8aad04aa 2719 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2720#endif
2721
8aad04aa 2722 act.sa_handler = (void(*)(int))handler;
ff68c719 2723 sigemptyset(&act.sa_mask);
2724 act.sa_flags = 0;
2725#ifdef SA_RESTART
4ffa73a3
JH		 2726 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2727 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2728#endif
358837b8 2729#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2730 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2731 act.sa_flags |= SA_NOCLDWAIT;
2732#endif
ff68c719 2733 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2734 return (Sighandler_t) SIG_ERR;
ff68c719 2735 else
8aad04aa 2736 return (Sighandler_t) oact.sa_handler;
ff68c719 2737}
2738
2739Sighandler_t
864dbfa3 2740Perl_rsignal_state(pTHX_ int signo)
ff68c719 2741{
2742 struct sigaction oact;
96a5add6 2743 PERL_UNUSED_CONTEXT;
ff68c719 2744
2745 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2746 return (Sighandler_t) SIG_ERR;
ff68c719 2747 else
8aad04aa 2748 return (Sighandler_t) oact.sa_handler;
ff68c719 2749}
2750
2751int
864dbfa3 2752Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2753{
27da23d5 2754 dVAR;
ff68c719 2755 struct sigaction act;
2756
7918f24d
NC		 2757 PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2758
a10b1e10
JH		 2759#ifdef USE_ITHREADS
2760 /* only "parent" interpreter can diddle signals */
2761 if (PL_curinterp != aTHX)
2762 return -1;
2763#endif
2764
8aad04aa 2765 act.sa_handler = (void(*)(int))handler;
ff68c719 2766 sigemptyset(&act.sa_mask);
2767 act.sa_flags = 0;
2768#ifdef SA_RESTART
4ffa73a3
JH		 2769 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2770 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2771#endif
36b5d377 2772#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2773 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2774 act.sa_flags |= SA_NOCLDWAIT;
2775#endif
ff68c719 2776 return sigaction(signo, &act, save);
2777}
2778
2779int
864dbfa3 2780Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2781{
27da23d5 2782 dVAR;
a10b1e10
JH		 2783#ifdef USE_ITHREADS
2784 /* only "parent" interpreter can diddle signals */
2785 if (PL_curinterp != aTHX)
2786 return -1;
2787#endif
2788
ff68c719 2789 return sigaction(signo, save, (struct sigaction *)NULL);
2790}
2791
2792#else /* !HAS_SIGACTION */
2793
2794Sighandler_t
864dbfa3 2795Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2796{
39f1703b 2797#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2798 /* only "parent" interpreter can diddle signals */
2799 if (PL_curinterp != aTHX)
8aad04aa 2800 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2801#endif
2802
6ad3d225 2803 return PerlProc_signal(signo, handler);
ff68c719 2804}
2805
fabdb6c0 2806static Signal_t
4e35701f 2807sig_trap(int signo)
ff68c719 2808{
27da23d5
JH		 2809 dVAR;
2810 PL_sig_trapped++;
ff68c719 2811}
2812
2813Sighandler_t
864dbfa3 2814Perl_rsignal_state(pTHX_ int signo)
ff68c719 2815{
27da23d5 2816 dVAR;
ff68c719 2817 Sighandler_t oldsig;
2818
39f1703b 2819#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2820 /* only "parent" interpreter can diddle signals */
2821 if (PL_curinterp != aTHX)
8aad04aa 2822 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2823#endif
2824
27da23d5 2825 PL_sig_trapped = 0;
6ad3d225
GS		 2826 oldsig = PerlProc_signal(signo, sig_trap);
2827 PerlProc_signal(signo, oldsig);
27da23d5 2828 if (PL_sig_trapped)
3aed30dc 2829 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2830 return oldsig;
2831}
2832
2833int
864dbfa3 2834Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2835{
39f1703b 2836#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2837 /* only "parent" interpreter can diddle signals */
2838 if (PL_curinterp != aTHX)
2839 return -1;
2840#endif
6ad3d225 2841 *save = PerlProc_signal(signo, handler);
8aad04aa 2842 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2843}
2844
2845int
864dbfa3 2846Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2847{
39f1703b 2848#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2849 /* only "parent" interpreter can diddle signals */
2850 if (PL_curinterp != aTHX)
2851 return -1;
2852#endif
8aad04aa 2853 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2854}
2855
2856#endif /* !HAS_SIGACTION */
64ca3a65 2857#endif /* !PERL_MICRO */
ff68c719 2858
5f05dabc 2859 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
9c12f1e5 2860#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
79072805 2861I32
864dbfa3 2862Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2863{
97aff369 2864 dVAR;
ff68c719 2865 Sigsave_t hstat, istat, qstat;
a687059c 2866 int status;
a0d0e21e 2867 SV **svp;
d8a83dd3
JH		 2868 Pid_t pid;
2869 Pid_t pid2;
03136e13 2870 bool close_failed;
b7953727 2871 int saved_errno = 0;
22fae026
TM		 2872#ifdef WIN32
2873 int saved_win32_errno;
2874#endif
a687059c 2875
4755096e 2876 LOCK_FDPID_MUTEX;
3280af22 2877 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2878 UNLOCK_FDPID_MUTEX;
25d92023 2879 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2880 SvREFCNT_dec(*svp);
3280af22 2881 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2882#ifdef OS2
2883 if (pid == -1) { /* Opened by popen. */
2884 return my_syspclose(ptr);
2885 }
a1d180c4 2886#endif
03136e13
CS		 2887 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2888 saved_errno = errno;
22fae026
TM		 2889#ifdef WIN32
2890 saved_win32_errno = GetLastError();
2891#endif
03136e13 2892 }
7c0587c8 2893#ifdef UTS
6ad3d225 2894 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2895#endif
64ca3a65 2896#ifndef PERL_MICRO
8aad04aa
JH		 2897 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2898 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2899 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 2900#endif
748a9306 2901 do {
1d3434b8
GS		 2902 pid2 = wait4pid(pid, &status, 0);
2903 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2904#ifndef PERL_MICRO
ff68c719 2905 rsignal_restore(SIGHUP, &hstat);
2906 rsignal_restore(SIGINT, &istat);
2907 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2908#endif
03136e13 2909 if (close_failed) {
ce6e1103 2910 SETERRNO(saved_errno, 0);
03136e13
CS		 2911 return -1;
2912 }
1d3434b8 2913 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2914}
9c12f1e5
RGS		 2915#else
2916#if defined(__LIBCATAMOUNT__)
2917I32
2918Perl_my_pclose(pTHX_ PerlIO *ptr)
2919{
2920 return -1;
2921}
2922#endif
4633a7c4
LW		 2923#endif /* !DOSISH */
2924
9c12f1e5 2925#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
79072805 2926I32
d8a83dd3 2927Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2928{
97aff369 2929 dVAR;
27da23d5 2930 I32 result = 0;
7918f24d 2931 PERL_ARGS_ASSERT_WAIT4PID;
b7953727
JH		 2932 if (!pid)
2933 return -1;
ca0c25f6 2934#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2935 {
3aed30dc 2936 if (pid > 0) {
12072db5
NC		 2937 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2938 pid, rather than a string form. */
c4420975 2939 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 2940 if (svp && *svp != &PL_sv_undef) {
2941 *statusp = SvIVX(*svp);
12072db5
NC		 2942 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2943 G_DISCARD);
3aed30dc
HS		 2944 return pid;
2945 }
2946 }
2947 else {
2948 HE *entry;
2949
2950 hv_iterinit(PL_pidstatus);
2951 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2952 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2953 I32 len;
0bcc34c2 2954 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2955
12072db5
NC		 2956 assert (len == sizeof(Pid_t));
2957 memcpy((char *)&pid, spid, len);
3aed30dc 2958 *statusp = SvIVX(sv);
7b9a3241
NC		 2959 /* The hash iterator is currently on this entry, so simply
2960 calling hv_delete would trigger the lazy delete, which on
2961 aggregate does more work, beacuse next call to hv_iterinit()
2962 would spot the flag, and have to call the delete routine,
2963 while in the meantime any new entries can't re-use that
2964 memory. */
2965 hv_iterinit(PL_pidstatus);
7ea75b61 2966 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 2967 return pid;
2968 }
20188a90
LW		 2969 }
2970 }
68a29c53 2971#endif
79072805 2972#ifdef HAS_WAITPID
367f3c24
IZ		 2973# ifdef HAS_WAITPID_RUNTIME
2974 if (!HAS_WAITPID_RUNTIME)
2975 goto hard_way;
2976# endif
cddd4526 2977 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2978 goto finish;
367f3c24
IZ		 2979#endif
2980#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2981 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2982 goto finish;
367f3c24 2983#endif
ca0c25f6 2984#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2985#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2986 hard_way:
27da23d5 2987#endif
a0d0e21e 2988 {
a0d0e21e 2989 if (flags)
cea2e8a9 2990 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2991 else {
76e3520e 2992 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2993 pidgone(result,*statusp);
2994 if (result < 0)
2995 *statusp = -1;
2996 }
a687059c
LW		 2997 }
2998#endif
27da23d5 2999#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 3000 finish:
27da23d5 3001#endif
cddd4526
NIS		 3002 if (result < 0 && errno == EINTR) {
3003 PERL_ASYNC_CHECK();
3004 }
3005 return result;
a687059c 3006}
2986a63f 3007#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 3008
ca0c25f6 3009#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 3010void
d8a83dd3 3011Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 3012{
79072805 3013 register SV *sv;
a687059c 3014
12072db5 3015 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 3016 SvUPGRADE(sv,SVt_IV);
45977657 3017 SvIV_set(sv, status);
20188a90 3018 return;
a687059c 3019}
ca0c25f6 3020#endif
a687059c 3021
85ca448a 3022#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 3023int pclose();
ddcf38b7
IZ		 3024#ifdef HAS_FORK
3025int /* Cannot prototype with I32
3026 in os2ish.h. */
ba106d47 3027my_syspclose(PerlIO *ptr)
ddcf38b7 3028#else
79072805 3029I32
864dbfa3 3030Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 3031#endif
a687059c 3032{
760ac839 3033 /* Needs work for PerlIO ! */
c4420975 3034 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 3035 const I32 result = pclose(f);
2b96b0a5
JH		 3036 PerlIO_releaseFILE(ptr,f);
3037 return result;
3038}
3039#endif
3040
933fea7f 3041#if defined(DJGPP)
2b96b0a5
JH		 3042int djgpp_pclose();
3043I32
3044Perl_my_pclose(pTHX_ PerlIO *ptr)
3045{
3046 /* Needs work for PerlIO ! */
c4420975 3047 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 3048 I32 result = djgpp_pclose(f);
933fea7f 3049 result = (result << 8) & 0xff00;
760ac839
LW		 3050 PerlIO_releaseFILE(ptr,f);
3051 return result;
a687059c 3052}
7c0587c8 3053#endif
9f68db38
LW		 3054
3055void
864dbfa3 3056Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 3057{
79072805 3058 register I32 todo;
c4420975 3059 register const char * const frombase = from;
96a5add6 3060 PERL_UNUSED_CONTEXT;
9f68db38 3061
7918f24d
NC		 3062 PERL_ARGS_ASSERT_REPEATCPY;
3063
9f68db38 3064 if (len == 1) {
08105a92 3065 register const char c = *from;
9f68db38 3066 while (count-- > 0)
5926133d 3067 *to++ = c;
9f68db38
LW		 3068 return;
3069 }
3070 while (count-- > 0) {
3071 for (todo = len; todo > 0; todo--) {
3072 *to++ = *from++;
3073 }
3074 from = frombase;
3075 }
3076}
0f85fab0 3077
fe14fcc3 3078#ifndef HAS_RENAME
79072805 3079I32
4373e329 3080Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 3081{
93a17b20
LW		 3082 char *fa = strrchr(a,'/');
3083 char *fb = strrchr(b,'/');
c623ac67
GS		 3084 Stat_t tmpstatbuf1;
3085 Stat_t tmpstatbuf2;
c4420975 3086 SV * const tmpsv = sv_newmortal();
62b28dd9 3087
7918f24d
NC		 3088 PERL_ARGS_ASSERT_SAME_DIRENT;
3089
62b28dd9
LW		 3090 if (fa)
3091 fa++;
3092 else
3093 fa = a;
3094 if (fb)
3095 fb++;
3096 else
3097 fb = b;
3098 if (strNE(a,b))
3099 return FALSE;
3100 if (fa == a)
616d8c9c 3101 sv_setpvn(tmpsv, ".", 1);
62b28dd9 3102 else
46fc3d4c 3103 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 3104 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 3105 return FALSE;
3106 if (fb == b)
616d8c9c 3107 sv_setpvn(tmpsv, ".", 1);
62b28dd9 3108 else
46fc3d4c 3109 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 3110 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 3111 return FALSE;
3112 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3113 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3114}
fe14fcc3
LW		 3115#endif /* !HAS_RENAME */
3116
491527d0 3117char*
7f315aed
NC		 3118Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3119 const char *const *const search_ext, I32 flags)
491527d0 3120{
97aff369 3121 dVAR;
bd61b366
SS		 3122 const char *xfound = NULL;
3123 char *xfailed = NULL;
0f31cffe 3124 char tmpbuf[MAXPATHLEN];
491527d0 3125 register char *s;
5f74f29c 3126 I32 len = 0;
491527d0 3127 int retval;
39a02377 3128 char *bufend;
491527d0
GS		 3129#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3130# define SEARCH_EXTS ".bat", ".cmd", NULL
3131# define MAX_EXT_LEN 4
3132#endif
3133#ifdef OS2
3134# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3135# define MAX_EXT_LEN 4
3136#endif
3137#ifdef VMS
3138# define SEARCH_EXTS ".pl", ".com", NULL
3139# define MAX_EXT_LEN 4
3140#endif
3141 /* additional extensions to try in each dir if scriptname not found */
3142#ifdef SEARCH_EXTS
0bcc34c2 3143 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3144 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3145 int extidx = 0, i = 0;
bd61b366 3146 const char *curext = NULL;
491527d0 3147#else
53c1dcc0 3148 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 3149# define MAX_EXT_LEN 0
3150#endif
3151
7918f24d
NC		 3152 PERL_ARGS_ASSERT_FIND_SCRIPT;
3153
491527d0
GS		 3154 /*
3155 * If dosearch is true and if scriptname does not contain path
3156 * delimiters, search the PATH for scriptname.
3157 *
3158 * If SEARCH_EXTS is also defined, will look for each
3159 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3160 * while searching the PATH.
3161 *
3162 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3163 * proceeds as follows:
3164 * If DOSISH or VMSISH:
3165 * + look for ./scriptname{,.foo,.bar}
3166 * + search the PATH for scriptname{,.foo,.bar}
3167 *
3168 * If !DOSISH:
3169 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3170 * this will not look in '.' if it's not in the PATH)
3171 */
84486fc6 3172 tmpbuf[0] = '\0';
491527d0
GS		 3173
3174#ifdef VMS
3175# ifdef ALWAYS_DEFTYPES
3176 len = strlen(scriptname);
3177 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3178 int idx = 0, deftypes = 1;
491527d0
GS		 3179 bool seen_dot = 1;
3180
bd61b366 3181 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3182# else
3183 if (dosearch) {
c4420975 3184 int idx = 0, deftypes = 1;
491527d0
GS		 3185 bool seen_dot = 1;
3186
bd61b366 3187 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3188# endif
3189 /* The first time through, just add SEARCH_EXTS to whatever we
3190 * already have, so we can check for default file types. */
3191 while (deftypes ||
84486fc6 3192 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3193 {
3194 if (deftypes) {
3195 deftypes = 0;
84486fc6 3196 *tmpbuf = '\0';
491527d0 3197 }
84486fc6
GS		 3198 if ((strlen(tmpbuf) + strlen(scriptname)
3199 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3200 continue; /* don't search dir with too-long name */
6fca0082 3201 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS		 3202#else /* !VMS */
3203
3204#ifdef DOSISH
3205 if (strEQ(scriptname, "-"))
3206 dosearch = 0;
3207 if (dosearch) { /* Look in '.' first. */
fe2774ed 3208 const char *cur = scriptname;
491527d0
GS		 3209#ifdef SEARCH_EXTS
3210 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3211 while (ext[i])
3212 if (strEQ(ext[i++],curext)) {
3213 extidx = -1; /* already has an ext */
3214 break;
3215 }
3216 do {
3217#endif
3218 DEBUG_p(PerlIO_printf(Perl_debug_log,
3219 "Looking for %s\n",cur));
017f25f1
IZ		 3220 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3221 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3222 dosearch = 0;
3223 scriptname = cur;
3224#ifdef SEARCH_EXTS
3225 break;
3226#endif
3227 }
3228#ifdef SEARCH_EXTS
3229 if (cur == scriptname) {
3230 len = strlen(scriptname);
84486fc6 3231 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3232 break;
9e4425f7
SH		 3233 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3234 cur = tmpbuf;
491527d0
GS		 3235 }
3236 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3237 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS		 3238#endif
3239 }
3240#endif
3241
cd39f2b6
JH		 3242#ifdef MACOS_TRADITIONAL
3243 if (dosearch && !strchr(scriptname, ':') &&
3244 (s = PerlEnv_getenv("Commands")))
3245#else
491527d0
GS		 3246 if (dosearch && !strchr(scriptname, '/')
3247#ifdef DOSISH
3248 && !strchr(scriptname, '\\')
3249#endif
cd39f2b6
JH		 3250 && (s = PerlEnv_getenv("PATH")))
3251#endif
3252 {
491527d0 3253 bool seen_dot = 0;
92f0c265 3254
39a02377
DM		 3255 bufend = s + strlen(s);
3256 while (s < bufend) {
cd39f2b6 3257#ifdef MACOS_TRADITIONAL
39a02377 3258 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
cd39f2b6
JH		 3259 ',',
3260 &len);
3261#else
491527d0
GS		 3262#if defined(atarist) || defined(DOSISH)
3263 for (len = 0; *s
3264# ifdef atarist
3265 && *s != ','
3266# endif
3267 && *s != ';'; len++, s++) {
84486fc6
GS		 3268 if (len < sizeof tmpbuf)
3269 tmpbuf[len] = *s;
491527d0 3270 }
84486fc6
GS		 3271 if (len < sizeof tmpbuf)
3272 tmpbuf[len] = '\0';
491527d0 3273#else /* ! (atarist || DOSISH) */
39a02377 3274 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
491527d0
GS		 3275 ':',
3276 &len);
3277#endif /* ! (atarist || DOSISH) */
cd39f2b6 3278#endif /* MACOS_TRADITIONAL */
39a02377 3279 if (s < bufend)
491527d0 3280 s++;
84486fc6 3281 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 3282 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 3283#ifdef MACOS_TRADITIONAL
3284 if (len && tmpbuf[len - 1] != ':')
3285 tmpbuf[len++] = ':';
3286#else
491527d0 3287 if (len
490a0e98 3288# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 3289 && tmpbuf[len - 1] != '/'
3290 && tmpbuf[len - 1] != '\\'
490a0e98 3291# endif
491527d0 3292 )
84486fc6
GS		 3293 tmpbuf[len++] = '/';
3294 if (len == 2 && tmpbuf[0] == '.')
491527d0 3295 seen_dot = 1;
cd39f2b6 3296#endif
28f0d0ec 3297 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS		 3298#endif /* !VMS */
3299
3300#ifdef SEARCH_EXTS
84486fc6 3301 len = strlen(tmpbuf);
491527d0
GS		 3302 if (extidx > 0) /* reset after previous loop */
3303 extidx = 0;
3304 do {
3305#endif
84486fc6 3306 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3307 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3308 if (S_ISDIR(PL_statbuf.st_mode)) {
3309 retval = -1;
3310 }
491527d0
GS		 3311#ifdef SEARCH_EXTS
3312 } while ( retval < 0 /* not there */
3313 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3314 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS		 3315 );
3316#endif
3317 if (retval < 0)
3318 continue;
3280af22
NIS		 3319 if (S_ISREG(PL_statbuf.st_mode)
3320 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 3321#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 3322 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3323#endif
3324 )
3325 {
3aed30dc 3326 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3327 break;
3328 }
3329 if (!xfailed)
84486fc6 3330 xfailed = savepv(tmpbuf);
491527d0
GS		 3331 }
3332#ifndef DOSISH
017f25f1 3333 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3334 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3335 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3336#endif
3337 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3338 if (!xfound) {
3339 if (flags & 1) { /* do or die? */
3aed30dc 3340 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3341 (xfailed ? "execute" : "find"),
3342 (xfailed ? xfailed : scriptname),
3343 (xfailed ? "" : " on PATH"),
3344 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3345 }
bd61b366 3346 scriptname = NULL;
9ccb31f9 3347 }
43c5f42d 3348 Safefree(xfailed);
491527d0
GS		 3349 scriptname = xfound;
3350 }
bd61b366 3351 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3352}
3353
ba869deb
GS		 3354#ifndef PERL_GET_CONTEXT_DEFINED
3355
3356void *
3357Perl_get_context(void)
3358{
27da23d5 3359 dVAR;
3db8f154 3360#if defined(USE_ITHREADS)
ba869deb
GS		 3361# ifdef OLD_PTHREADS_API
3362 pthread_addr_t t;
3363 if (pthread_getspecific(PL_thr_key, &t))
3364 Perl_croak_nocontext("panic: pthread_getspecific");
3365 return (void*)t;
3366# else
bce813aa 3367# ifdef I_MACH_CTHREADS
8b8b35ab 3368 return (void*)cthread_data(cthread_self());
bce813aa 3369# else
8b8b35ab
JH		 3370 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3371# endif
c44d3fdb 3372# endif
ba869deb
GS		 3373#else
3374 return (void*)NULL;
3375#endif
3376}
3377
3378void
3379Perl_set_context(void *t)
3380{
8772537c 3381 dVAR;
7918f24d 3382 PERL_ARGS_ASSERT_SET_CONTEXT;
3db8f154 3383#if defined(USE_ITHREADS)
c44d3fdb
GS		 3384# ifdef I_MACH_CTHREADS
3385 cthread_set_data(cthread_self(), t);
3386# else
ba869deb
GS		 3387 if (pthread_setspecific(PL_thr_key, t))
3388 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3389# endif
b464bac0 3390#else
8772537c 3391 PERL_UNUSED_ARG(t);
ba869deb
GS		 3392#endif
3393}
3394
3395#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3396
27da23d5 3397#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3398struct perl_vars *
864dbfa3 3399Perl_GetVars(pTHX)
22239a37 3400{
533c011a 3401 return &PL_Vars;
22239a37 3402}
31fb1209
NIS		 3403#endif
3404
1cb0ed9b 3405char **
864dbfa3 3406Perl_get_op_names(pTHX)
31fb1209 3407{
96a5add6
AL		 3408 PERL_UNUSED_CONTEXT;
3409 return (char **)PL_op_name;
31fb1209
NIS		 3410}
3411
1cb0ed9b 3412char **
864dbfa3 3413Perl_get_op_descs(pTHX)
31fb1209 3414{
96a5add6
AL		 3415 PERL_UNUSED_CONTEXT;
3416 return (char **)PL_op_desc;
31fb1209 3417}
9e6b2b00 3418
e1ec3a88 3419const char *
864dbfa3 3420Perl_get_no_modify(pTHX)
9e6b2b00 3421{
96a5add6
AL		 3422 PERL_UNUSED_CONTEXT;
3423 return PL_no_modify;
9e6b2b00
GS		 3424}
3425
3426U32 *
864dbfa3 3427Perl_get_opargs(pTHX)
9e6b2b00 3428{
96a5add6
AL		 3429 PERL_UNUSED_CONTEXT;
3430 return (U32 *)PL_opargs;
9e6b2b00 3431}
51aa15f3 3432
0cb96387
GS		 3433PPADDR_t*
3434Perl_get_ppaddr(pTHX)
3435{
96a5add6
AL		 3436 dVAR;
3437 PERL_UNUSED_CONTEXT;
3438 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3439}
3440
a6c40364
GS		 3441#ifndef HAS_GETENV_LEN
3442char *
bf4acbe4 3443Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3444{
8772537c 3445 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3446 PERL_UNUSED_CONTEXT;
7918f24d 3447 PERL_ARGS_ASSERT_GETENV_LEN;
a6c40364
GS		 3448 if (env_trans)
3449 *len = strlen(env_trans);
3450 return env_trans;
f675dbe5
CB		 3451}
3452#endif
3453
dc9e4912
GS		 3454
3455MGVTBL*
864dbfa3 3456Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3457{
7452cf6a 3458 const MGVTBL* result;
96a5add6 3459 PERL_UNUSED_CONTEXT;
dc9e4912
GS		 3460
3461 switch(vtbl_id) {
3462 case want_vtbl_sv:
3463 result = &PL_vtbl_sv;
3464 break;
3465 case want_vtbl_env:
3466 result = &PL_vtbl_env;
3467 break;
3468 case want_vtbl_envelem:
3469 result = &PL_vtbl_envelem;
3470 break;
3471 case want_vtbl_sig:
3472 result = &PL_vtbl_sig;
3473 break;
3474 case want_vtbl_sigelem:
3475 result = &PL_vtbl_sigelem;
3476 break;
3477 case want_vtbl_pack:
3478 result = &PL_vtbl_pack;
3479 break;
3480 case want_vtbl_packelem:
3481 result = &PL_vtbl_packelem;
3482 break;
3483 case want_vtbl_dbline:
3484 result = &PL_vtbl_dbline;
3485 break;
3486 case want_vtbl_isa:
3487 result = &PL_vtbl_isa;
3488 break;
3489 case want_vtbl_isaelem:
3490 result = &PL_vtbl_isaelem;
3491 break;
3492 case want_vtbl_arylen:
3493 result = &PL_vtbl_arylen;
3494 break;
dc9e4912
GS		 3495 case want_vtbl_mglob:
3496 result = &PL_vtbl_mglob;
3497 break;
3498 case want_vtbl_nkeys:
3499 result = &PL_vtbl_nkeys;
3500 break;
3501 case want_vtbl_taint:
3502 result = &PL_vtbl_taint;
3503 break;
3504 case want_vtbl_substr:
3505 result = &PL_vtbl_substr;
3506 break;
3507 case want_vtbl_vec:
3508 result = &PL_vtbl_vec;
3509 break;
3510 case want_vtbl_pos:
3511 result = &PL_vtbl_pos;
3512 break;
3513 case want_vtbl_bm:
3514 result = &PL_vtbl_bm;
3515 break;
3516 case want_vtbl_fm:
3517 result = &PL_vtbl_fm;
3518 break;
3519 case want_vtbl_uvar:
3520 result = &PL_vtbl_uvar;
3521 break;
dc9e4912
GS		 3522 case want_vtbl_defelem:
3523 result = &PL_vtbl_defelem;
3524 break;
3525 case want_vtbl_regexp:
3526 result = &PL_vtbl_regexp;
3527 break;
3528 case want_vtbl_regdata:
3529 result = &PL_vtbl_regdata;
3530 break;
3531 case want_vtbl_regdatum:
3532 result = &PL_vtbl_regdatum;
3533 break;
3c90161d 3534#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3535 case want_vtbl_collxfrm:
3536 result = &PL_vtbl_collxfrm;
3537 break;
3c90161d 3538#endif
dc9e4912
GS		 3539 case want_vtbl_amagic:
3540 result = &PL_vtbl_amagic;
3541 break;
3542 case want_vtbl_amagicelem:
3543 result = &PL_vtbl_amagicelem;
3544 break;
810b8aa5
GS		 3545 case want_vtbl_backref:
3546 result = &PL_vtbl_backref;
3547 break;
7e8c5dac
HS		 3548 case want_vtbl_utf8:
3549 result = &PL_vtbl_utf8;
3550 break;
7452cf6a 3551 default:
4608196e 3552 result = NULL;
7452cf6a 3553 break;
dc9e4912 3554 }
27da23d5 3555 return (MGVTBL*)result;
dc9e4912
GS		 3556}
3557
767df6a1 3558I32
864dbfa3 3559Perl_my_fflush_all(pTHX)
767df6a1 3560{
f800e14d 3561#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3562 return PerlIO_flush(NULL);
767df6a1 3563#else
8fbdfb7c 3564# if defined(HAS__FWALK)
f13a2bc0 3565 extern int fflush(FILE *);
74cac757
JH		 3566 /* undocumented, unprototyped, but very useful BSDism */
3567 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3568 _fwalk(&fflush);
74cac757 3569 return 0;
8fa7f367 3570# else
8fbdfb7c 3571# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3572 long open_max = -1;
8fbdfb7c 3573# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3574 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3575# else
8fa7f367 3576# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3577 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3578# else
3579# ifdef FOPEN_MAX
74cac757 3580 open_max = FOPEN_MAX;
8fa7f367
JH		 3581# else
3582# ifdef OPEN_MAX
74cac757 3583 open_max = OPEN_MAX;
8fa7f367
JH		 3584# else
3585# ifdef _NFILE
d2201af2 3586 open_max = _NFILE;
8fa7f367
JH		 3587# endif
3588# endif
74cac757 3589# endif
767df6a1
JH		 3590# endif
3591# endif
767df6a1
JH		 3592 if (open_max > 0) {
3593 long i;
3594 for (i = 0; i < open_max; i++)
d2201af2
AD		 3595 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3596 STDIO_STREAM_ARRAY[i]._file < open_max &&
3597 STDIO_STREAM_ARRAY[i]._flag)
3598 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3599 return 0;
3600 }
8fbdfb7c 3601# endif
93189314 3602 SETERRNO(EBADF,RMS_IFI);
767df6a1 3603 return EOF;
74cac757 3604# endif
767df6a1
JH		 3605#endif
3606}
097ee67d 3607
69282e91 3608void
e1ec3a88 3609Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
bc37a18f 3610{
b64e5050 3611 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
66fc2fa5 3612
4c80c0b2 3613 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3614 if (ckWARN(WARN_IO)) {
10edeb5d
JH		 3615 const char * const direction =
3616 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3aed30dc
HS		 3617 if (name && *name)
3618 Perl_warner(aTHX_ packWARN(WARN_IO),
3619 "Filehandle %s opened only for %sput",
fd322ea4 3620 name, direction);
3aed30dc
HS		 3621 else
3622 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3623 "Filehandle opened only for %sput", direction);
3aed30dc 3624 }
2dd78f96
JH		 3625 }
3626 else {
e1ec3a88 3627 const char *vile;
3aed30dc
HS		 3628 I32 warn_type;
3629
3630 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3631 vile = "closed";
3632 warn_type = WARN_CLOSED;
3633 }
3634 else {
3635 vile = "unopened";
3636 warn_type = WARN_UNOPENED;
3637 }
3638
3639 if (ckWARN(warn_type)) {
10edeb5d
JH		 3640 const char * const pars =
3641 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
f0a09b71 3642 const char * const func =
10edeb5d
JH		 3643 (const char *)
3644 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3645 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3646 op < 0 ? "" : /* handle phoney cases */
3647 PL_op_desc[op]);
3648 const char * const type =
3649 (const char *)
3650 (OP_IS_SOCKET(op) ||
3651 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3652 "socket" : "filehandle");
3aed30dc
HS		 3653 if (name && *name) {
3654 Perl_warner(aTHX_ packWARN(warn_type),
3655 "%s%s on %s %s %s", func, pars, vile, type, name);
3656 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3657 Perl_warner(
3658 aTHX_ packWARN(warn_type),
3659 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3660 func, pars, name
3661 );
3662 }
3663 else {
3664 Perl_warner(aTHX_ packWARN(warn_type),
3665 "%s%s on %s %s", func, pars, vile, type);
3666 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3667 Perl_warner(
3668 aTHX_ packWARN(warn_type),
3669 "\t(Are you trying to call %s%s on dirhandle?)\n",
3670 func, pars
3671 );
3672 }
3673 }
bc37a18f 3674 }
69282e91 3675}
a926ef6b
JH		 3676
3677#ifdef EBCDIC
cbebf344
JH		 3678/* in ASCII order, not that it matters */
3679static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3680
a926ef6b
JH		 3681int
3682Perl_ebcdic_control(pTHX_ int ch)
3683{
3aed30dc 3684 if (ch > 'a') {
e1ec3a88 3685 const char *ctlp;
3aed30dc
HS		 3686
3687 if (islower(ch))
3688 ch = toupper(ch);
3689
3690 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3691 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3692 }
3aed30dc
HS		 3693
3694 if (ctlp == controllablechars)
3695 return('\177'); /* DEL */
3696 else
3697 return((unsigned char)(ctlp - controllablechars - 1));
3698 } else { /* Want uncontrol */
3699 if (ch == '\177' || ch == -1)
3700 return('?');
3701 else if (ch == '\157')
3702 return('\177');
3703 else if (ch == '\174')
3704 return('\000');
3705 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3706 return('\036');
3707 else if (ch == '\155')
3708 return('\037');
3709 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3710 return(controllablechars[ch+1]);
3711 else
3712 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3713 }
a926ef6b
JH		 3714}
3715#endif
e72cf795 3716
f6adc668 3717/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3718 * system to give us a reasonable struct to copy. This fix means that
3719 * strftime uses the tm_zone and tm_gmtoff values returned by
3720 * localtime(time()). That should give the desired result most of the
3721 * time. But probably not always!
3722 *
f6adc668
JH		 3723 * This does not address tzname aspects of NETaa14816.
3724 *
e72cf795 3725 */
f6adc668 3726
e72cf795
JH		 3727#ifdef HAS_GNULIBC
3728# ifndef STRUCT_TM_HASZONE
3729# define STRUCT_TM_HASZONE
3730# endif
3731#endif
3732
f6adc668
JH		 3733#ifdef STRUCT_TM_HASZONE /* Backward compat */
3734# ifndef HAS_TM_TM_ZONE
3735# define HAS_TM_TM_ZONE
3736# endif
3737#endif
3738
e72cf795 3739void
f1208910 3740Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3741{
f6adc668 3742#ifdef HAS_TM_TM_ZONE
e72cf795 3743 Time_t now;
1b6737cc 3744 const struct tm* my_tm;
7918f24d 3745 PERL_ARGS_ASSERT_INIT_TM;
e72cf795 3746 (void)time(&now);
82c57498 3747 my_tm = localtime(&now);
ca46b8ee
SP		 3748 if (my_tm)
3749 Copy(my_tm, ptm, 1, struct tm);
1b6737cc 3750#else
7918f24d 3751 PERL_ARGS_ASSERT_INIT_TM;
1b6737cc 3752 PERL_UNUSED_ARG(ptm);
e72cf795
JH		 3753#endif
3754}
3755
3756/*
3757 * mini_mktime - normalise struct tm values without the localtime()
3758 * semantics (and overhead) of mktime().
3759 */
3760void
f1208910 3761Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3762{
3763 int yearday;
3764 int secs;
3765 int month, mday, year, jday;
3766 int odd_cent, odd_year;
96a5add6 3767 PERL_UNUSED_CONTEXT;
e72cf795 3768
7918f24d
NC		 3769 PERL_ARGS_ASSERT_MINI_MKTIME;
3770
e72cf795
JH		 3771#define DAYS_PER_YEAR 365
3772#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3773#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3774#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3775#define SECS_PER_HOUR (60*60)
3776#define SECS_PER_DAY (24*SECS_PER_HOUR)
3777/* parentheses deliberately absent on these two, otherwise they don't work */
3778#define MONTH_TO_DAYS 153/5
3779#define DAYS_TO_MONTH 5/153
3780/* offset to bias by March (month 4) 1st between month/mday & year finding */
3781#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3782/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3783#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3784
3785/*
3786 * Year/day algorithm notes:
3787 *
3788 * With a suitable offset for numeric value of the month, one can find
3789 * an offset into the year by considering months to have 30.6 (153/5) days,
3790 * using integer arithmetic (i.e., with truncation). To avoid too much
3791 * messing about with leap days, we consider January and February to be
3792 * the 13th and 14th month of the previous year. After that transformation,
3793 * we need the month index we use to be high by 1 from 'normal human' usage,
3794 * so the month index values we use run from 4 through 15.
3795 *
3796 * Given that, and the rules for the Gregorian calendar (leap years are those
3797 * divisible by 4 unless also divisible by 100, when they must be divisible
3798 * by 400 instead), we can simply calculate the number of days since some
3799 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3800 * the days we derive from our month index, and adding in the day of the
3801 * month. The value used here is not adjusted for the actual origin which
3802 * it normally would use (1 January A.D. 1), since we're not exposing it.
3803 * We're only building the value so we can turn around and get the
3804 * normalised values for the year, month, day-of-month, and day-of-year.
3805 *
3806 * For going backward, we need to bias the value we're using so that we find
3807 * the right year value. (Basically, we don't want the contribution of
3808 * March 1st to the number to apply while deriving the year). Having done
3809 * that, we 'count up' the contribution to the year number by accounting for
3810 * full quadracenturies (400-year periods) with their extra leap days, plus
3811 * the contribution from full centuries (to avoid counting in the lost leap
3812 * days), plus the contribution from full quad-years (to count in the normal
3813 * leap days), plus the leftover contribution from any non-leap years.
3814 * At this point, if we were working with an actual leap day, we'll have 0
3815 * days left over. This is also true for March 1st, however. So, we have
3816 * to special-case that result, and (earlier) keep track of the 'odd'
3817 * century and year contributions. If we got 4 extra centuries in a qcent,
3818 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3819 * Otherwise, we add back in the earlier bias we removed (the 123 from
3820 * figuring in March 1st), find the month index (integer division by 30.6),
3821 * and the remainder is the day-of-month. We then have to convert back to
3822 * 'real' months (including fixing January and February from being 14/15 in
3823 * the previous year to being in the proper year). After that, to get
3824 * tm_yday, we work with the normalised year and get a new yearday value for
3825 * January 1st, which we subtract from the yearday value we had earlier,
3826 * representing the date we've re-built. This is done from January 1
3827 * because tm_yday is 0-origin.
3828 *
3829 * Since POSIX time routines are only guaranteed to work for times since the
3830 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3831 * applies Gregorian calendar rules even to dates before the 16th century
3832 * doesn't bother me. Besides, you'd need cultural context for a given
3833 * date to know whether it was Julian or Gregorian calendar, and that's
3834 * outside the scope for this routine. Since we convert back based on the
3835 * same rules we used to build the yearday, you'll only get strange results
3836 * for input which needed normalising, or for the 'odd' century years which
3837 * were leap years in the Julian calander but not in the Gregorian one.
3838 * I can live with that.
3839 *
3840 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3841 * that's still outside the scope for POSIX time manipulation, so I don't
3842 * care.
3843 */
3844
3845 year = 1900 + ptm->tm_year;
3846 month = ptm->tm_mon;
3847 mday = ptm->tm_mday;
3848 /* allow given yday with no month & mday to dominate the result */
3849 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3850 month = 0;
3851 mday = 0;
3852 jday = 1 + ptm->tm_yday;
3853 }
3854 else {
3855 jday = 0;
3856 }
3857 if (month >= 2)
3858 month+=2;
3859 else
3860 month+=14, year--;
3861 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3862 yearday += month*MONTH_TO_DAYS + mday + jday;
3863 /*
3864 * Note that we don't know when leap-seconds were or will be,
3865 * so we have to trust the user if we get something which looks
3866 * like a sensible leap-second. Wild values for seconds will
3867 * be rationalised, however.
3868 */
3869 if ((unsigned) ptm->tm_sec <= 60) {
3870 secs = 0;
3871 }
3872 else {
3873 secs = ptm->tm_sec;
3874 ptm->tm_sec = 0;
3875 }
3876 secs += 60 * ptm->tm_min;
3877 secs += SECS_PER_HOUR * ptm->tm_hour;
3878 if (secs < 0) {
3879 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3880 /* got negative remainder, but need positive time */
3881 /* back off an extra day to compensate */
3882 yearday += (secs/SECS_PER_DAY)-1;
3883 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3884 }
3885 else {
3886 yearday += (secs/SECS_PER_DAY);
3887 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3888 }
3889 }
3890 else if (secs >= SECS_PER_DAY) {
3891 yearday += (secs/SECS_PER_DAY);
3892 secs %= SECS_PER_DAY;
3893 }
3894 ptm->tm_hour = secs/SECS_PER_HOUR;
3895 secs %= SECS_PER_HOUR;
3896 ptm->tm_min = secs/60;
3897 secs %= 60;
3898 ptm->tm_sec += secs;
3899 /* done with time of day effects */
3900 /*
3901 * The algorithm for yearday has (so far) left it high by 428.
3902 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3903 * bias it by 123 while trying to figure out what year it
3904 * really represents. Even with this tweak, the reverse
3905 * translation fails for years before A.D. 0001.
3906 * It would still fail for Feb 29, but we catch that one below.
3907 */
3908 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3909 yearday -= YEAR_ADJUST;
3910 year = (yearday / DAYS_PER_QCENT) * 400;
3911 yearday %= DAYS_PER_QCENT;
3912 odd_cent = yearday / DAYS_PER_CENT;
3913 year += odd_cent * 100;
3914 yearday %= DAYS_PER_CENT;
3915 year += (yearday / DAYS_PER_QYEAR) * 4;
3916 yearday %= DAYS_PER_QYEAR;
3917 odd_year = yearday / DAYS_PER_YEAR;
3918 year += odd_year;
3919 yearday %= DAYS_PER_YEAR;
3920 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3921 month = 1;
3922 yearday = 29;
3923 }
3924 else {
3925 yearday += YEAR_ADJUST; /* recover March 1st crock */
3926 month = yearday*DAYS_TO_MONTH;
3927 yearday -= month*MONTH_TO_DAYS;
3928 /* recover other leap-year adjustment */
3929 if (month > 13) {
3930 month-=14;
3931 year++;
3932 }
3933 else {
3934 month-=2;
3935 }
3936 }
3937 ptm->tm_year = year - 1900;
3938 if (yearday) {
3939 ptm->tm_mday = yearday;
3940 ptm->tm_mon = month;
3941 }
3942 else {
3943 ptm->tm_mday = 31;
3944 ptm->tm_mon = month - 1;
3945 }
3946 /* re-build yearday based on Jan 1 to get tm_yday */
3947 year--;
3948 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3949 yearday += 14*MONTH_TO_DAYS + 1;
3950 ptm->tm_yday = jday - yearday;
3951 /* fix tm_wday if not overridden by caller */
3952 if ((unsigned)ptm->tm_wday > 6)
3953 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3954}
b3c85772
JH		 3955
3956char *
e1ec3a88 3957Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
b3c85772
JH		 3958{
3959#ifdef HAS_STRFTIME
3960 char *buf;
3961 int buflen;
3962 struct tm mytm;
3963 int len;
3964
7918f24d
NC		 3965 PERL_ARGS_ASSERT_MY_STRFTIME;
3966
b3c85772
JH		 3967 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3968 mytm.tm_sec = sec;
3969 mytm.tm_min = min;
3970 mytm.tm_hour = hour;
3971 mytm.tm_mday = mday;
3972 mytm.tm_mon = mon;
3973 mytm.tm_year = year;
3974 mytm.tm_wday = wday;
3975 mytm.tm_yday = yday;
3976 mytm.tm_isdst = isdst;
3977 mini_mktime(&mytm);
c473feec
SR		 3978 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3979#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3980 STMT_START {
3981 struct tm mytm2;
3982 mytm2 = mytm;
3983 mktime(&mytm2);
3984#ifdef HAS_TM_TM_GMTOFF
3985 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3986#endif
3987#ifdef HAS_TM_TM_ZONE
3988 mytm.tm_zone = mytm2.tm_zone;
3989#endif
3990 } STMT_END;
3991#endif
b3c85772 3992 buflen = 64;
a02a5408 3993 Newx(buf, buflen, char);
b3c85772
JH		 3994 len = strftime(buf, buflen, fmt, &mytm);
3995 /*
877f6a72 3996 ** The following is needed to handle to the situation where
b3c85772
JH		 3997 ** tmpbuf overflows. Basically we want to allocate a buffer
3998 ** and try repeatedly. The reason why it is so complicated
3999 ** is that getting a return value of 0 from strftime can indicate
4000 ** one of the following:
4001 ** 1. buffer overflowed,
4002 ** 2. illegal conversion specifier, or
4003 ** 3. the format string specifies nothing to be returned(not
4004 ** an error). This could be because format is an empty string
4005 ** or it specifies %p that yields an empty string in some locale.
4006 ** If there is a better way to make it portable, go ahead by
4007 ** all means.
4008 */
4009 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4010 return buf;
4011 else {
4012 /* Possibly buf overflowed - try again with a bigger buf */
e1ec3a88 4013 const int fmtlen = strlen(fmt);
7743c307 4014 int bufsize = fmtlen + buflen;
877f6a72 4015
a02a5408 4016 Newx(buf, bufsize, char);
b3c85772
JH		 4017 while (buf) {
4018 buflen = strftime(buf, bufsize, fmt, &mytm);
4019 if (buflen > 0 && buflen < bufsize)
4020 break;
4021 /* heuristic to prevent out-of-memory errors */
4022 if (bufsize > 100*fmtlen) {
4023 Safefree(buf);
4024 buf = NULL;
4025 break;
4026 }
7743c307
SH		 4027 bufsize *= 2;
4028 Renew(buf, bufsize, char);
b3c85772
JH		 4029 }
4030 return buf;
4031 }
4032#else
4033 Perl_croak(aTHX_ "panic: no strftime");
27da23d5 4034 return NULL;
b3c85772
JH		 4035#endif
4036}
4037
877f6a72
NIS		 4038
4039#define SV_CWD_RETURN_UNDEF \
4040sv_setsv(sv, &PL_sv_undef); \
4041return FALSE
4042
4043#define SV_CWD_ISDOT(dp) \
4044 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 4045 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 4046
4047/*
ccfc67b7
JH		 4048=head1 Miscellaneous Functions
4049
89423764 4050=for apidoc getcwd_sv
877f6a72
NIS		 4051
4052Fill the sv with current working directory
4053
4054=cut
4055*/
4056
4057/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4058 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4059 * getcwd(3) if available
4060 * Comments from the orignal:
4061 * This is a faster version of getcwd. It's also more dangerous
4062 * because you might chdir out of a directory that you can't chdir
4063 * back into. */
4064
877f6a72 4065int
89423764 4066Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 4067{
4068#ifndef PERL_MICRO
97aff369 4069 dVAR;
ea715489
JH		 4070#ifndef INCOMPLETE_TAINTS
4071 SvTAINTED_on(sv);
4072#endif
4073
7918f24d
NC		 4074 PERL_ARGS_ASSERT_GETCWD_SV;
4075
8f95b30d
JH		 4076#ifdef HAS_GETCWD
4077 {
60e110a8
DM		 4078 char buf[MAXPATHLEN];
4079
3aed30dc 4080 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 4081 * size from the heap if they are given a NULL buffer pointer.
4082 * The problem is that this behaviour is not portable. */
3aed30dc 4083 if (getcwd(buf, sizeof(buf) - 1)) {
42d9b98d 4084 sv_setpv(sv, buf);
3aed30dc
HS		 4085 return TRUE;
4086 }
4087 else {
4088 sv_setsv(sv, &PL_sv_undef);
4089 return FALSE;
4090 }
8f95b30d
JH		 4091 }
4092
4093#else
4094
c623ac67 4095 Stat_t statbuf;
877f6a72 4096 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4373e329 4097 int pathlen=0;
877f6a72 4098 Direntry_t *dp;
877f6a72 4099
862a34c6 4100 SvUPGRADE(sv, SVt_PV);
877f6a72 4101
877f6a72 4102 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 4103 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4104 }
4105
4106 orig_cdev = statbuf.st_dev;
4107 orig_cino = statbuf.st_ino;
4108 cdev = orig_cdev;
4109 cino = orig_cino;
4110
4111 for (;;) {
4373e329 4112 DIR *dir;
3aed30dc
HS		 4113 odev = cdev;
4114 oino = cino;
4115
4116 if (PerlDir_chdir("..") < 0) {
4117 SV_CWD_RETURN_UNDEF;
4118 }
4119 if (PerlLIO_stat(".", &statbuf) < 0) {
4120 SV_CWD_RETURN_UNDEF;
4121 }
4122
4123 cdev = statbuf.st_dev;
4124 cino = statbuf.st_ino;
4125
4126 if (odev == cdev && oino == cino) {
4127 break;
4128 }
4129 if (!(dir = PerlDir_open("."))) {
4130 SV_CWD_RETURN_UNDEF;
4131 }
4132
4133 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 4134#ifdef DIRNAMLEN
4373e329 4135 const int namelen = dp->d_namlen;
877f6a72 4136#else
4373e329 4137 const int namelen = strlen(dp->d_name);
877f6a72 4138#endif
3aed30dc
HS		 4139 /* skip . and .. */
4140 if (SV_CWD_ISDOT(dp)) {
4141 continue;
4142 }
4143
4144 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4145 SV_CWD_RETURN_UNDEF;
4146 }
4147
4148 tdev = statbuf.st_dev;
4149 tino = statbuf.st_ino;
4150 if (tino == oino && tdev == odev) {
4151 break;
4152 }
cb5953d6
JH		 4153 }
4154
3aed30dc
HS		 4155 if (!dp) {
4156 SV_CWD_RETURN_UNDEF;
4157 }
4158
4159 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4160 SV_CWD_RETURN_UNDEF;
4161 }
877f6a72 4162
3aed30dc
HS		 4163 SvGROW(sv, pathlen + namelen + 1);
4164
4165 if (pathlen) {
4166 /* shift down */
95a20fc0 4167 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3aed30dc 4168 }
877f6a72 4169
3aed30dc
HS		 4170 /* prepend current directory to the front */
4171 *SvPVX(sv) = '/';
4172 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4173 pathlen += (namelen + 1);
877f6a72
NIS		 4174
4175#ifdef VOID_CLOSEDIR
3aed30dc 4176 PerlDir_close(dir);
877f6a72 4177#else
3aed30dc
HS		 4178 if (PerlDir_close(dir) < 0) {
4179 SV_CWD_RETURN_UNDEF;
4180 }
877f6a72
NIS		 4181#endif
4182 }
4183
60e110a8 4184 if (pathlen) {
3aed30dc
HS		 4185 SvCUR_set(sv, pathlen);
4186 *SvEND(sv) = '\0';
4187 SvPOK_only(sv);
877f6a72 4188
95a20fc0 4189 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3aed30dc
HS		 4190 SV_CWD_RETURN_UNDEF;
4191 }
877f6a72
NIS		 4192 }
4193 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 4194 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4195 }
4196
4197 cdev = statbuf.st_dev;
4198 cino = statbuf.st_ino;
4199
4200 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 4201 Perl_croak(aTHX_ "Unstable directory path, "
4202 "current directory changed unexpectedly");
877f6a72 4203 }
877f6a72
NIS		 4204
4205 return TRUE;
793b8d8e
JH		 4206#endif
4207
877f6a72
NIS		 4208#else
4209 return FALSE;
4210#endif
4211}
4212
c812d146 4213#define VERSION_MAX 0x7FFFFFFF
f4758303 4214/*
b0f01acb
JP		 4215=for apidoc scan_version
4216
4217Returns a pointer to the next character after the parsed
4218version string, as well as upgrading the passed in SV to
4219an RV.
4220
4221Function must be called with an already existing SV like
4222
137d6fc0 4223 sv = newSV(0);
abc25d8c 4224 s = scan_version(s, SV *sv, bool qv);
b0f01acb
JP		 4225
4226Performs some preprocessing to the string to ensure that
4227it has the correct characteristics of a version. Flags the
4228object if it contains an underscore (which denotes this
abc25d8c 4229is an alpha version). The boolean qv denotes that the version
137d6fc0
JP		 4230should be interpreted as if it had multiple decimals, even if
4231it doesn't.
b0f01acb
JP		 4232
4233=cut
4234*/
4235
9137345a 4236const char *
e1ec3a88 4237Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
b0f01acb 4238{
e0218a61 4239 const char *start;
9137345a
JP		 4240 const char *pos;
4241 const char *last;
4242 int saw_period = 0;
cb5772bb 4243 int alpha = 0;
9137345a 4244 int width = 3;
c812d146 4245 bool vinf = FALSE;
7452cf6a
AL		 4246 AV * const av = newAV();
4247 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
7918f24d
NC		 4248
4249 PERL_ARGS_ASSERT_SCAN_VERSION;
4250
9137345a 4251 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
cb5772bb 4252
e0218a61
JP		 4253 while (isSPACE(*s)) /* leading whitespace is OK */
4254 s++;
4255
8cb289bd
RGS		 4256 start = last = s;
4257
9137345a
JP		 4258 if (*s == 'v') {
4259 s++; /* get past 'v' */
4260 qv = 1; /* force quoted version processing */
4261 }
4262
8cb289bd 4263 pos = s;
9137345a
JP		 4264
4265 /* pre-scan the input string to check for decimals/underbars */
ad63d80f
JP		 4266 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4267 {
4268 if ( *pos == '.' )
4269 {
cb5772bb 4270 if ( alpha )
5f89c282 4271 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 4272 saw_period++ ;
9137345a 4273 last = pos;
46314c13 4274 }
ad63d80f
JP		 4275 else if ( *pos == '_' )
4276 {
cb5772bb 4277 if ( alpha )
5f89c282 4278 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
cb5772bb 4279 alpha = 1;
9137345a 4280 width = pos - last - 1; /* natural width of sub-version */
ad63d80f
JP		 4281 }
4282 pos++;
4283 }
ad63d80f 4284
34ba6322
SP		 4285 if ( alpha && !saw_period )
4286 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4287
f34c6aaf
JP		 4288 if ( alpha && saw_period && width == 0 )
4289 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4290
e0218a61 4291 if ( saw_period > 1 )
137d6fc0 4292 qv = 1; /* force quoted version processing */
9137345a 4293
c812d146 4294 last = pos;
9137345a
JP		 4295 pos = s;
4296
4297 if ( qv )
85771703 4298 (void)hv_stores((HV *)hv, "qv", newSViv(qv));
cb5772bb 4299 if ( alpha )
85771703 4300 (void)hv_stores((HV *)hv, "alpha", newSViv(alpha));
9137345a 4301 if ( !qv && width < 3 )
85771703 4302 (void)hv_stores((HV *)hv, "width", newSViv(width));
9137345a 4303
ad63d80f 4304 while (isDIGIT(*pos))
46314c13 4305 pos++;
ad63d80f
JP		 4306 if (!isALPHA(*pos)) {
4307 I32 rev;
4308
ad63d80f
JP		 4309 for (;;) {
4310 rev = 0;
4311 {
129318bd 4312 /* this is atoi() that delimits on underscores */
9137345a 4313 const char *end = pos;
129318bd 4314 I32 mult = 1;
c812d146 4315 I32 orev;
9137345a 4316
129318bd
JP		 4317 /* the following if() will only be true after the decimal
4318 * point of a version originally created with a bare
4319 * floating point number, i.e. not quoted in any way
4320 */
e0218a61 4321 if ( !qv && s > start && saw_period == 1 ) {
c76df65e 4322 mult *= 100;
129318bd 4323 while ( s < end ) {
c812d146 4324 orev = rev;
129318bd
JP		 4325 rev += (*s - '0') * mult;
4326 mult /= 10;
c812d146
JP		 4327 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4328 || (PERL_ABS(rev) > VERSION_MAX )) {
4329 if(ckWARN(WARN_OVERFLOW))
4330 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4331 "Integer overflow in version %d",VERSION_MAX);
4332 s = end - 1;
4333 rev = VERSION_MAX;
4334 vinf = 1;
4335 }
129318bd 4336 s++;
9137345a
JP		 4337 if ( *s == '_' )
4338 s++;
129318bd
JP		 4339 }
4340 }
4341 else {
4342 while (--end >= s) {
c812d146 4343 orev = rev;
129318bd
JP		 4344 rev += (*end - '0') * mult;
4345 mult *= 10;
c812d146
JP		 4346 if ( (PERL_ABS(orev) > PERL_ABS(rev))
4347 || (PERL_ABS(rev) > VERSION_MAX )) {
4348 if(ckWARN(WARN_OVERFLOW))
4349 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4350 "Integer overflow in version");
4351 end = s - 1;
4352 rev = VERSION_MAX;
4353 vinf = 1;
4354 }
129318bd
JP		 4355 }
4356 }
4357 }
9137345a 4358
129318bd 4359 /* Append revision */
9137345a 4360 av_push(av, newSViv(rev));
c812d146
JP		 4361 if ( vinf ) {
4362 s = last;
4363 break;
4364 }
4365 else if ( *pos == '.' )
9137345a
JP		 4366 s = ++pos;
4367 else if ( *pos == '_' && isDIGIT(pos[1]) )
ad63d80f
JP		 4368 s = ++pos;
4369 else if ( isDIGIT(*pos) )
4370 s = pos;
b0f01acb 4371 else {
ad63d80f
JP		 4372 s = pos;
4373 break;
4374 }
9137345a
JP		 4375 if ( qv ) {
4376 while ( isDIGIT(*pos) )
4377 pos++;
4378 }
4379 else {
4380 int digits = 0;
4381 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4382 if ( *pos != '_' )
4383 digits++;
4384 pos++;
4385 }
b0f01acb
JP		 4386 }
4387 }
4388 }
9137345a
JP		 4389 if ( qv ) { /* quoted versions always get at least three terms*/
4390 I32 len = av_len(av);
4edfc503
NC		 4391 /* This for loop appears to trigger a compiler bug on OS X, as it
4392 loops infinitely. Yes, len is negative. No, it makes no sense.
4393 Compiler in question is:
4394 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4395 for ( len = 2 - len; len > 0; len-- )
4396 av_push((AV *)sv, newSViv(0));
4397 */
4398 len = 2 - len;
4399 while (len-- > 0)
9137345a 4400 av_push(av, newSViv(0));
b9381830 4401 }
9137345a 4402
8cb289bd 4403 /* need to save off the current version string for later */
c812d146
JP		 4404 if ( vinf ) {
4405 SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
85771703
NC		 4406 (void)hv_stores((HV *)hv, "original", orig);
4407 (void)hv_stores((HV *)hv, "vinf", newSViv(1));
c812d146
JP		 4408 }
4409 else if ( s > start ) {
8cb289bd
RGS		 4410 SV * orig = newSVpvn(start,s-start);
4411 if ( qv && saw_period == 1 && *start != 'v' ) {
4412 /* need to insert a v to be consistent */
4413 sv_insert(orig, 0, 0, "v", 1);
4414 }
85771703 4415 (void)hv_stores((HV *)hv, "original", orig);
8cb289bd
RGS		 4416 }
4417 else {
85771703 4418 (void)hv_stores((HV *)hv, "original", newSVpvn("0",1));
9137345a 4419 av_push(av, newSViv(0));
8cb289bd
RGS		 4420 }
4421
4422 /* And finally, store the AV in the hash */
85771703 4423 (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av));
9137345a 4424
92dcf8ce
JP		 4425 /* fix RT#19517 - special case 'undef' as string */
4426 if ( *s == 'u' && strEQ(s,"undef") ) {
4427 s += 5;
4428 }
4429
9137345a 4430 return s;
b0f01acb
JP		 4431}
4432
4433/*
4434=for apidoc new_version
4435
4436Returns a new version object based on the passed in SV:
4437
4438 SV *sv = new_version(SV *ver);
4439
4440Does not alter the passed in ver SV. See "upg_version" if you
4441want to upgrade the SV.
4442
4443=cut
4444*/
4445
4446SV *
4447Perl_new_version(pTHX_ SV *ver)
4448{
97aff369 4449 dVAR;
2d03de9c 4450 SV * const rv = newSV(0);
7918f24d 4451 PERL_ARGS_ASSERT_NEW_VERSION;
d7aa5382
JP		 4452 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4453 {
4454 I32 key;
53c1dcc0 4455 AV * const av = newAV();
9137345a
JP		 4456 AV *sav;
4457 /* This will get reblessed later if a derived class*/
e0218a61 4458 SV * const hv = newSVrv(rv, "version");
9137345a
JP		 4459 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4460
4461 if ( SvROK(ver) )
4462 ver = SvRV(ver);
4463
4464 /* Begin copying all of the elements */
4465 if ( hv_exists((HV *)ver, "qv", 2) )
72287d96 4466 (void)hv_stores((HV *)hv, "qv", newSViv(1));
9137345a
JP		 4467
4468 if ( hv_exists((HV *)ver, "alpha", 5) )
72287d96 4469 (void)hv_stores((HV *)hv, "alpha", newSViv(1));
9137345a
JP		 4470
4471 if ( hv_exists((HV*)ver, "width", 5 ) )
d7aa5382 4472 {
017a3ce5 4473 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
85771703 4474 (void)hv_stores((HV *)hv, "width", newSViv(width));
d7aa5382 4475 }
9137345a 4476
8cb289bd
RGS		 4477 if ( hv_exists((HV*)ver, "original", 8 ) )
4478 {
4479 SV * pv = *hv_fetchs((HV*)ver, "original", FALSE);
85771703 4480 (void)hv_stores((HV *)hv, "original", newSVsv(pv));
8cb289bd
RGS		 4481 }
4482
017a3ce5 4483 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
9137345a
JP		 4484 /* This will get reblessed later if a derived class*/
4485 for ( key = 0; key <= av_len(sav); key++ )
4486 {
4487 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4488 av_push(av, newSViv(rev));
4489 }
4490
85771703 4491 (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av));
d7aa5382
JP		 4492 return rv;
4493 }
ad63d80f 4494#ifdef SvVOK
4f2da183 4495 {
3c21775b 4496 const MAGIC* const mg = SvVSTRING_mg(ver);
4f2da183
NC		 4497 if ( mg ) { /* already a v-string */
4498 const STRLEN len = mg->mg_len;
4499 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4500 sv_setpvn(rv,version,len);
8cb289bd
RGS		 4501 /* this is for consistency with the pure Perl class */
4502 if ( *version != 'v' )
4503 sv_insert(rv, 0, 0, "v", 1);
4f2da183
NC		 4504 Safefree(version);
4505 }
4506 else {
ad63d80f 4507#endif
4f2da183 4508 sv_setsv(rv,ver); /* make a duplicate */
137d6fc0 4509#ifdef SvVOK
4f2da183 4510 }
26ec6fc3 4511 }
137d6fc0 4512#endif
ac0e6a2f 4513 return upg_version(rv, FALSE);
b0f01acb
JP		 4514}
4515
4516/*
4517=for apidoc upg_version
4518
4519In-place upgrade of the supplied SV to a version object.
4520
ac0e6a2f 4521 SV *sv = upg_version(SV *sv, bool qv);
b0f01acb 4522
ac0e6a2f
RGS		 4523Returns a pointer to the upgraded SV. Set the boolean qv if you want
4524to force this SV to be interpreted as an "extended" version.
b0f01acb
JP		 4525
4526=cut
4527*/
4528
4529SV *
ac0e6a2f 4530Perl_upg_version(pTHX_ SV *ver, bool qv)
b0f01acb 4531{
cd57dc11 4532 const char *version, *s;
4f2da183
NC		 4533#ifdef SvVOK
4534 const MAGIC *mg;
4535#endif
137d6fc0 4536
7918f24d
NC		 4537 PERL_ARGS_ASSERT_UPG_VERSION;
4538
ac0e6a2f 4539 if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
137d6fc0 4540 {
ac0e6a2f 4541 /* may get too much accuracy */
137d6fc0 4542 char tbuf[64];
b5b5a8f0
RGS		 4543#ifdef USE_LOCALE_NUMERIC
4544 char *loc = setlocale(LC_NUMERIC, "C");
4545#endif
63e3af20 4546 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
b5b5a8f0
RGS		 4547#ifdef USE_LOCALE_NUMERIC
4548 setlocale(LC_NUMERIC, loc);
4549#endif
c8a14fb6 4550 while (tbuf[len-1] == '0' && len > 0) len--;
8cb289bd 4551 if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
86c11942 4552 version = savepvn(tbuf, len);
137d6fc0 4553 }
ad63d80f 4554#ifdef SvVOK
666cce26 4555 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
ad63d80f 4556 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0 4557 qv = 1;
b0f01acb 4558 }
ad63d80f 4559#endif
137d6fc0
JP		 4560 else /* must be a string or something like a string */
4561 {
ac0e6a2f
RGS		 4562 STRLEN len;
4563 version = savepv(SvPV(ver,len));
4564#ifndef SvVOK
4565# if PERL_VERSION > 5
4566 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4567 if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4568 /* may be a v-string */
4569 SV * const nsv = sv_newmortal();
4570 const char *nver;
4571 const char *pos;
4572 int saw_period = 0;
8cb289bd 4573 sv_setpvf(nsv,"v%vd",ver);
ac0e6a2f
RGS		 4574 pos = nver = savepv(SvPV_nolen(nsv));
4575
4576 /* scan the resulting formatted string */
8cb289bd 4577 pos++; /* skip the leading 'v' */
ac0e6a2f
RGS		 4578 while ( *pos == '.' || isDIGIT(*pos) ) {
4579 if ( *pos == '.' )
4580 saw_period++ ;
4581 pos++;
4582 }
4583
4584 /* is definitely a v-string */
4585 if ( saw_period == 2 ) {
4586 Safefree(version);
4587 version = nver;
4588 }
4589 }
4590# endif
4591#endif
137d6fc0 4592 }
92dcf8ce 4593
cd57dc11 4594 s = scan_version(version, ver, qv);
808ee47e 4595 if ( *s != '\0' )
92dcf8ce 4596 if(ckWARN(WARN_MISC))
808ee47e 4597 Perl_warner(aTHX_ packWARN(WARN_MISC),
92dcf8ce
JP		 4598 "Version string '%s' contains invalid data; "
4599 "ignoring: '%s'", version, s);
137d6fc0 4600 Safefree(version);
ad63d80f 4601 return ver;
b0f01acb
JP		 4602}
4603
e0218a61
JP		 4604/*
4605=for apidoc vverify
4606
4607Validates that the SV contains a valid version object.
4608
4609 bool vverify(SV *vobj);
4610
4611Note that it only confirms the bare minimum structure (so as not to get
4612confused by derived classes which may contain additional hash entries):
4613
4614=over 4
4615
cb5772bb 4616=item * The SV contains a [reference to a] hash
e0218a61
JP		 4617
4618=item * The hash contains a "version" key
4619
cb5772bb 4620=item * The "version" key has [a reference to] an AV as its value
e0218a61
JP		 4621
4622=back
4623
4624=cut
4625*/
4626
4627bool
4628Perl_vverify(pTHX_ SV *vs)
4629{
4630 SV *sv;
7918f24d
NC		 4631
4632 PERL_ARGS_ASSERT_VVERIFY;
4633
e0218a61
JP		 4634 if ( SvROK(vs) )
4635 vs = SvRV(vs);
4636
4637 /* see if the appropriate elements exist */
4638 if ( SvTYPE(vs) == SVt_PVHV
4639 && hv_exists((HV*)vs, "version", 7)
017a3ce5 4640 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
e0218a61
JP		 4641 && SvTYPE(sv) == SVt_PVAV )
4642 return TRUE;
4643 else
4644 return FALSE;
4645}
b0f01acb
JP		 4646
4647/*
4648=for apidoc vnumify
4649
ad63d80f
JP		 4650Accepts a version object and returns the normalized floating
4651point representation. Call like:
b0f01acb 4652
ad63d80f 4653 sv = vnumify(rv);
b0f01acb 4654
ad63d80f
JP		 4655NOTE: you can pass either the object directly or the SV
4656contained within the RV.
b0f01acb
JP		 4657
4658=cut
4659*/
4660
4661SV *
ad63d80f 4662Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4663{
ad63d80f 4664 I32 i, len, digit;
9137345a
JP		 4665 int width;
4666 bool alpha = FALSE;
53c1dcc0 4667 SV * const sv = newSV(0);
9137345a 4668 AV *av;
7918f24d
NC		 4669
4670 PERL_ARGS_ASSERT_VNUMIFY;
4671
ad63d80f
JP		 4672 if ( SvROK(vs) )
4673 vs = SvRV(vs);
9137345a 4674
e0218a61
JP		 4675 if ( !vverify(vs) )
4676 Perl_croak(aTHX_ "Invalid version object");
4677
9137345a
JP		 4678 /* see if various flags exist */
4679 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4680 alpha = TRUE;
4681 if ( hv_exists((HV*)vs, "width", 5 ) )
017a3ce5 4682 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
9137345a
JP		 4683 else
4684 width = 3;
4685
4686
4687 /* attempt to retrieve the version array */
017a3ce5 4688 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
396482e1 4689 sv_catpvs(sv,"0");
9137345a
JP		 4690 return sv;
4691 }
4692
4693 len = av_len(av);
46314c13
JP		 4694 if ( len == -1 )
4695 {
396482e1 4696 sv_catpvs(sv,"0");
46314c13
JP		 4697 return sv;
4698 }
9137345a
JP		 4699
4700 digit = SvIV(*av_fetch(av, 0, 0));
261fcdab 4701 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
13f8f398 4702 for ( i = 1 ; i < len ; i++ )
b0f01acb 4703 {
9137345a
JP		 4704 digit = SvIV(*av_fetch(av, i, 0));
4705 if ( width < 3 ) {
43eaf59d 4706 const int denom = (width == 2 ? 10 : 100);
53c1dcc0 4707 const div_t term = div((int)PERL_ABS(digit),denom);
261fcdab 4708 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
9137345a
JP		 4709 }
4710 else {
261fcdab 4711 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
9137345a 4712 }
b0f01acb 4713 }
13f8f398
JP		 4714
4715 if ( len > 0 )
4716 {
9137345a
JP		 4717 digit = SvIV(*av_fetch(av, len, 0));
4718 if ( alpha && width == 3 ) /* alpha version */
396482e1 4719 sv_catpvs(sv,"_");
261fcdab 4720 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
13f8f398 4721 }
e0218a61 4722 else /* len == 0 */
13f8f398 4723 {
396482e1 4724 sv_catpvs(sv, "000");
13f8f398 4725 }
b0f01acb
JP		 4726 return sv;
4727}
4728
4729/*
b9381830 4730=for apidoc vnormal
b0f01acb 4731
ad63d80f
JP		 4732Accepts a version object and returns the normalized string
4733representation. Call like:
b0f01acb 4734
b9381830 4735 sv = vnormal(rv);
b0f01acb 4736
ad63d80f
JP		 4737NOTE: you can pass either the object directly or the SV
4738contained within the RV.
b0f01acb
JP		 4739
4740=cut
4741*/
4742
4743SV *
b9381830 4744Perl_vnormal(pTHX_ SV *vs)
b0f01acb 4745{
ad63d80f 4746 I32 i, len, digit;
9137345a 4747 bool alpha = FALSE;
2d03de9c 4748 SV * const sv = newSV(0);
9137345a 4749 AV *av;
7918f24d
NC		 4750
4751 PERL_ARGS_ASSERT_VNORMAL;
4752
ad63d80f
JP		 4753 if ( SvROK(vs) )
4754 vs = SvRV(vs);
9137345a 4755
e0218a61
JP		 4756 if ( !vverify(vs) )
4757 Perl_croak(aTHX_ "Invalid version object");
4758
9137345a
JP		 4759 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4760 alpha = TRUE;
017a3ce5 4761 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
9137345a
JP		 4762
4763 len = av_len(av);
e0218a61
JP		 4764 if ( len == -1 )
4765 {
396482e1 4766 sv_catpvs(sv,"");
46314c13
JP		 4767 return sv;
4768 }
9137345a 4769 digit = SvIV(*av_fetch(av, 0, 0));
261fcdab 4770 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
cb5772bb 4771 for ( i = 1 ; i < len ; i++ ) {
9137345a 4772 digit = SvIV(*av_fetch(av, i, 0));
261fcdab 4773 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
9137345a
JP		 4774 }
4775
e0218a61
JP		 4776 if ( len > 0 )
4777 {
9137345a
JP		 4778 /* handle last digit specially */
4779 digit = SvIV(*av_fetch(av, len, 0));
4780 if ( alpha )
261fcdab 4781 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
ad63d80f 4782 else
261fcdab 4783 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
b0f01acb 4784 }
9137345a 4785
137d6fc0
JP		 4786 if ( len <= 2 ) { /* short version, must be at least three */
4787 for ( len = 2 - len; len != 0; len-- )
396482e1 4788 sv_catpvs(sv,".0");
137d6fc0 4789 }
b0f01acb 4790 return sv;
9137345a 4791}
b0f01acb 4792
ad63d80f 4793/*
b9381830
JP		 4794=for apidoc vstringify
4795
4796In order to maintain maximum compatibility with earlier versions
4797of Perl, this function will return either the floating point
4798notation or the multiple dotted notation, depending on whether
4799the original version contained 1 or more dots, respectively
4800
4801=cut
4802*/
4803
4804SV *
4805Perl_vstringify(pTHX_ SV *vs)
4806{
8cb289bd 4807 SV *pv;
7918f24d
NC		 4808
4809 PERL_ARGS_ASSERT_VSTRINGIFY;
4810
b9381830
JP		 4811 if ( SvROK(vs) )
4812 vs = SvRV(vs);
e0218a61
JP		 4813
4814 if ( !vverify(vs) )
4815 Perl_croak(aTHX_ "Invalid version object");
4816
8cb289bd
RGS		 4817 pv = *hv_fetchs((HV*)vs, "original", FALSE);
4818 if ( SvPOK(pv) )
4819 return newSVsv(pv);
9137345a 4820 else
8cb289bd 4821 return &PL_sv_undef;
b9381830
JP		 4822}
4823
4824/*
ad63d80f
JP		 4825=for apidoc vcmp
4826
4827Version object aware cmp. Both operands must already have been
4828converted into version objects.
4829
4830=cut
4831*/
4832
4833int
9137345a 4834Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
ad63d80f
JP		 4835{
4836 I32 i,l,m,r,retval;
9137345a
JP		 4837 bool lalpha = FALSE;
4838 bool ralpha = FALSE;
4839 I32 left = 0;
4840 I32 right = 0;
4841 AV *lav, *rav;
7918f24d
NC		 4842
4843 PERL_ARGS_ASSERT_VCMP;
4844
9137345a
JP		 4845 if ( SvROK(lhv) )
4846 lhv = SvRV(lhv);
4847 if ( SvROK(rhv) )
4848 rhv = SvRV(rhv);
4849
e0218a61
JP		 4850 if ( !vverify(lhv) )
4851 Perl_croak(aTHX_ "Invalid version object");
4852
4853 if ( !vverify(rhv) )
4854 Perl_croak(aTHX_ "Invalid version object");
4855
9137345a 4856 /* get the left hand term */
017a3ce5 4857 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
9137345a
JP		 4858 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4859 lalpha = TRUE;
4860
4861 /* and the right hand term */
017a3ce5 4862 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
9137345a
JP		 4863 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4864 ralpha = TRUE;
4865
4866 l = av_len(lav);
4867 r = av_len(rav);
ad63d80f
JP		 4868 m = l < r ? l : r;
4869 retval = 0;
4870 i = 0;
4871 while ( i <= m && retval == 0 )
4872 {
9137345a
JP		 4873 left = SvIV(*av_fetch(lav,i,0));
4874 right = SvIV(*av_fetch(rav,i,0));
4875 if ( left < right )
ad63d80f 4876 retval = -1;
9137345a 4877 if ( left > right )
ad63d80f
JP		 4878 retval = +1;
4879 i++;
4880 }
4881
9137345a
JP		 4882 /* tiebreaker for alpha with identical terms */
4883 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4884 {
4885 if ( lalpha && !ralpha )
4886 {
4887 retval = -1;
4888 }
4889 else if ( ralpha && !lalpha)
4890 {
4891 retval = +1;
4892 }
4893 }
4894
137d6fc0 4895 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
129318bd 4896 {
137d6fc0 4897 if ( l < r )
129318bd 4898 {
137d6fc0
JP		 4899 while ( i <= r && retval == 0 )
4900 {
9137345a 4901 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
137d6fc0
JP		 4902 retval = -1; /* not a match after all */
4903 i++;
4904 }
4905 }
4906 else
4907 {
4908 while ( i <= l && retval == 0 )
4909 {
9137345a 4910 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
137d6fc0
JP		 4911 retval = +1; /* not a match after all */
4912 i++;
4913 }
129318bd
JP		 4914 }
4915 }
ad63d80f
JP		 4916 return retval;
4917}
4918
c95c94b1 4919#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4920# define EMULATE_SOCKETPAIR_UDP
4921#endif
4922
4923#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4924static int
4925S_socketpair_udp (int fd[2]) {
e10bb1e9 4926 dTHX;
02fc2eee
NC		 4927 /* Fake a datagram socketpair using UDP to localhost. */
4928 int sockets[2] = {-1, -1};
4929 struct sockaddr_in addresses[2];
4930 int i;
3aed30dc 4931 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4932 unsigned short port;
02fc2eee
NC		 4933 int got;
4934
3aed30dc 4935 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4936 i = 1;
4937 do {
3aed30dc
HS		 4938 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4939 if (sockets[i] == -1)
4940 goto tidy_up_and_fail;
4941
4942 addresses[i].sin_family = AF_INET;
4943 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4944 addresses[i].sin_port = 0; /* kernel choses port. */
4945 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4946 sizeof(struct sockaddr_in)) == -1)
4947 goto tidy_up_and_fail;
02fc2eee
NC		 4948 } while (i--);
4949
4950 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4951 for each connect the other socket to it. */
4952 i = 1;
4953 do {
3aed30dc
HS		 4954 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4955 &size) == -1)
4956 goto tidy_up_and_fail;
4957 if (size != sizeof(struct sockaddr_in))
4958 goto abort_tidy_up_and_fail;
4959 /* !1 is 0, !0 is 1 */
4960 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4961 sizeof(struct sockaddr_in)) == -1)
4962 goto tidy_up_and_fail;
02fc2eee
NC		 4963 } while (i--);
4964
4965 /* Now we have 2 sockets connected to each other. I don't trust some other
4966 process not to have already sent a packet to us (by random) so send
4967 a packet from each to the other. */
4968 i = 1;
4969 do {
3aed30dc
HS		 4970 /* I'm going to send my own port number. As a short.
4971 (Who knows if someone somewhere has sin_port as a bitfield and needs
4972 this routine. (I'm assuming crays have socketpair)) */
4973 port = addresses[i].sin_port;
4974 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4975 if (got != sizeof(port)) {
4976 if (got == -1)
4977 goto tidy_up_and_fail;
4978 goto abort_tidy_up_and_fail;
4979 }
02fc2eee
NC		 4980 } while (i--);
4981
4982 /* Packets sent. I don't trust them to have arrived though.
4983 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4984 connect to localhost will use a second kernel thread. In 2.6 the
4985 first thread running the connect() returns before the second completes,
4986 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4987 returns 0. Poor programs have tripped up. One poor program's authors'
4988 had a 50-1 reverse stock split. Not sure how connected these were.)
4989 So I don't trust someone not to have an unpredictable UDP stack.
4990 */
4991
4992 {
3aed30dc
HS		 4993 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4994 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4995 fd_set rset;
4996
4997 FD_ZERO(&rset);
ea407a0c
NC		 4998 FD_SET((unsigned int)sockets[0], &rset);
4999 FD_SET((unsigned int)sockets[1], &rset);
3aed30dc
HS		 5000
5001 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5002 if (got != 2 || !FD_ISSET(sockets[0], &rset)
5003 || !FD_ISSET(sockets[1], &rset)) {
5004 /* I hope this is portable and appropriate. */
5005 if (got == -1)
5006 goto tidy_up_and_fail;
5007 goto abort_tidy_up_and_fail;
5008 }
02fc2eee 5009 }
f4758303 5010
02fc2eee
NC		 5011 /* And the paranoia department even now doesn't trust it to have arrive
5012 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
5013 {
3aed30dc
HS		 5014 struct sockaddr_in readfrom;
5015 unsigned short buffer[2];
02fc2eee 5016
3aed30dc
HS		 5017 i = 1;
5018 do {
02fc2eee 5019#ifdef MSG_DONTWAIT
3aed30dc
HS		 5020 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5021 sizeof(buffer), MSG_DONTWAIT,
5022 (struct sockaddr *) &readfrom, &size);
02fc2eee 5023#else
3aed30dc
HS		 5024 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5025 sizeof(buffer), 0,
5026 (struct sockaddr *) &readfrom, &size);
e10bb1e9 5027#endif
02fc2eee 5028
3aed30dc
HS		 5029 if (got == -1)
5030 goto tidy_up_and_fail;
5031 if (got != sizeof(port)
5032 || size != sizeof(struct sockaddr_in)
5033 /* Check other socket sent us its port. */
5034 || buffer[0] != (unsigned short) addresses[!i].sin_port
5035 /* Check kernel says we got the datagram from that socket */
5036 || readfrom.sin_family != addresses[!i].sin_family
5037 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5038 || readfrom.sin_port != addresses[!i].sin_port)
5039 goto abort_tidy_up_and_fail;
5040 } while (i--);
02fc2eee
NC		 5041 }
5042 /* My caller (my_socketpair) has validated that this is non-NULL */
5043 fd[0] = sockets[0];
5044 fd[1] = sockets[1];
5045 /* I hereby declare this connection open. May God bless all who cross
5046 her. */
5047 return 0;
5048
5049 abort_tidy_up_and_fail:
5050 errno = ECONNABORTED;
5051 tidy_up_and_fail:
5052 {
4373e329 5053 const int save_errno = errno;
3aed30dc
HS		 5054 if (sockets[0] != -1)
5055 PerlLIO_close(sockets[0]);
5056 if (sockets[1] != -1)
5057 PerlLIO_close(sockets[1]);
5058 errno = save_errno;
5059 return -1;
02fc2eee
NC		 5060 }
5061}
85ca448a 5062#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 5063
b5ac89c3 5064#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 5065int
5066Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5067 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 5068 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 5069 dTHX;
02fc2eee
NC		 5070 int listener = -1;
5071 int connector = -1;
5072 int acceptor = -1;
5073 struct sockaddr_in listen_addr;
5074 struct sockaddr_in connect_addr;
5075 Sock_size_t size;
5076
50458334
JH		 5077 if (protocol
5078#ifdef AF_UNIX
5079 || family != AF_UNIX
5080#endif
3aed30dc
HS		 5081 ) {
5082 errno = EAFNOSUPPORT;
5083 return -1;
02fc2eee 5084 }
2948e0bd 5085 if (!fd) {
3aed30dc
HS		 5086 errno = EINVAL;
5087 return -1;
2948e0bd 5088 }
02fc2eee 5089
2bc69dc4 5090#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 5091 if (type == SOCK_DGRAM)
3aed30dc 5092 return S_socketpair_udp(fd);
2bc69dc4 5093#endif
02fc2eee 5094
3aed30dc 5095 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 5096 if (listener == -1)
3aed30dc
HS		 5097 return -1;
5098 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 5099 listen_addr.sin_family = AF_INET;
3aed30dc 5100 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 5101 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 5102 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5103 sizeof(listen_addr)) == -1)
5104 goto tidy_up_and_fail;
e10bb1e9 5105 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 5106 goto tidy_up_and_fail;
02fc2eee 5107
3aed30dc 5108 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 5109 if (connector == -1)
3aed30dc 5110 goto tidy_up_and_fail;
02fc2eee 5111 /* We want to find out the port number to connect to. */
3aed30dc
HS		 5112 size = sizeof(connect_addr);
5113 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5114 &size) == -1)
5115 goto tidy_up_and_fail;
5116 if (size != sizeof(connect_addr))
5117 goto abort_tidy_up_and_fail;
e10bb1e9 5118 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 5119 sizeof(connect_addr)) == -1)
5120 goto tidy_up_and_fail;
02fc2eee 5121
3aed30dc
HS		 5122 size = sizeof(listen_addr);
5123 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5124 &size);
02fc2eee 5125 if (acceptor == -1)
3aed30dc
HS		 5126 goto tidy_up_and_fail;
5127 if (size != sizeof(listen_addr))
5128 goto abort_tidy_up_and_fail;
5129 PerlLIO_close(listener);
02fc2eee
NC		 5130 /* Now check we are talking to ourself by matching port and host on the
5131 two sockets. */
3aed30dc
HS		 5132 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5133 &size) == -1)
5134 goto tidy_up_and_fail;
5135 if (size != sizeof(connect_addr)
5136 || listen_addr.sin_family != connect_addr.sin_family
5137 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5138 || listen_addr.sin_port != connect_addr.sin_port) {
5139 goto abort_tidy_up_and_fail;
02fc2eee
NC		 5140 }
5141 fd[0] = connector;
5142 fd[1] = acceptor;
5143 return 0;
5144
5145 abort_tidy_up_and_fail:
27da23d5
JH		 5146#ifdef ECONNABORTED
5147 errno = ECONNABORTED; /* This would be the standard thing to do. */
5148#else
5149# ifdef ECONNREFUSED
5150 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5151# else
5152 errno = ETIMEDOUT; /* Desperation time. */
5153# endif
5154#endif
02fc2eee
NC		 5155 tidy_up_and_fail:
5156 {
7452cf6a 5157 const int save_errno = errno;
3aed30dc
HS		 5158 if (listener != -1)
5159 PerlLIO_close(listener);
5160 if (connector != -1)
5161 PerlLIO_close(connector);
5162 if (acceptor != -1)
5163 PerlLIO_close(acceptor);
5164 errno = save_errno;
5165 return -1;
02fc2eee
NC		 5166 }
5167}
85ca448a 5168#else
48ea76d1
JH		 5169/* In any case have a stub so that there's code corresponding
5170 * to the my_socketpair in global.sym. */
5171int
5172Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 5173#ifdef HAS_SOCKETPAIR
48ea76d1 5174 return socketpair(family, type, protocol, fd);
daf16542
JH		 5175#else
5176 return -1;
5177#endif
48ea76d1
JH		 5178}
5179#endif
5180
68795e93
NIS		 5181/*
5182
5183=for apidoc sv_nosharing
5184
5185Dummy routine which "shares" an SV when there is no sharing module present.
d5b2b27b
NC		 5186Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5187Exists to avoid test for a NULL function pointer and because it could
5188potentially warn under some level of strict-ness.
68795e93
NIS		 5189
5190=cut
5191*/
5192
5193void
5194Perl_sv_nosharing(pTHX_ SV *sv)
5195{
96a5add6 5196 PERL_UNUSED_CONTEXT;
53c1dcc0 5197 PERL_UNUSED_ARG(sv);
68795e93
NIS		 5198}
5199
eba16661
JH		 5200/*
5201
5202=for apidoc sv_destroyable
5203
5204Dummy routine which reports that object can be destroyed when there is no
5205sharing module present. It ignores its single SV argument, and returns
5206'true'. Exists to avoid test for a NULL function pointer and because it
5207could potentially warn under some level of strict-ness.
5208
5209=cut
5210*/
5211
5212bool
5213Perl_sv_destroyable(pTHX_ SV *sv)
5214{
5215 PERL_UNUSED_CONTEXT;
5216 PERL_UNUSED_ARG(sv);
5217 return TRUE;
5218}
5219
a05d7ebb 5220U32
e1ec3a88 5221Perl_parse_unicode_opts(pTHX_ const char **popt)
a05d7ebb 5222{
e1ec3a88 5223 const char *p = *popt;
a05d7ebb
JH		 5224 U32 opt = 0;
5225
7918f24d
NC		 5226 PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5227
a05d7ebb
JH		 5228 if (*p) {
5229 if (isDIGIT(*p)) {
5230 opt = (U32) atoi(p);
35da51f7
AL		 5231 while (isDIGIT(*p))
5232 p++;
7c91f477 5233 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 5234 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5235 }
5236 else {
5237 for (; *p; p++) {
5238 switch (*p) {
5239 case PERL_UNICODE_STDIN:
5240 opt |= PERL_UNICODE_STDIN_FLAG; break;
5241 case PERL_UNICODE_STDOUT:
5242 opt |= PERL_UNICODE_STDOUT_FLAG; break;
5243 case PERL_UNICODE_STDERR:
5244 opt |= PERL_UNICODE_STDERR_FLAG; break;
5245 case PERL_UNICODE_STD:
5246 opt |= PERL_UNICODE_STD_FLAG; break;
5247 case PERL_UNICODE_IN:
5248 opt |= PERL_UNICODE_IN_FLAG; break;
5249 case PERL_UNICODE_OUT:
5250 opt |= PERL_UNICODE_OUT_FLAG; break;
5251 case PERL_UNICODE_INOUT:
5252 opt |= PERL_UNICODE_INOUT_FLAG; break;
5253 case PERL_UNICODE_LOCALE:
5254 opt |= PERL_UNICODE_LOCALE_FLAG; break;
5255 case PERL_UNICODE_ARGV:
5256 opt |= PERL_UNICODE_ARGV_FLAG; break;
5a22a2bb
NC		 5257 case PERL_UNICODE_UTF8CACHEASSERT:
5258 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
a05d7ebb 5259 default:
7c91f477
JH		 5260 if (*p != '\n' && *p != '\r')
5261 Perl_croak(aTHX_
5262 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 5263 }
5264 }
5265 }
5266 }
5267 else
5268 opt = PERL_UNICODE_DEFAULT_FLAGS;
5269
5270 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 5271 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 5272 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5273
5274 *popt = p;
5275
5276 return opt;
5277}
5278
132efe8b
JH		 5279U32
5280Perl_seed(pTHX)
5281{
97aff369 5282 dVAR;
132efe8b
JH		 5283 /*
5284 * This is really just a quick hack which grabs various garbage
5285 * values. It really should be a real hash algorithm which
5286 * spreads the effect of every input bit onto every output bit,
5287 * if someone who knows about such things would bother to write it.
5288 * Might be a good idea to add that function to CORE as well.
5289 * No numbers below come from careful analysis or anything here,
5290 * except they are primes and SEED_C1 > 1E6 to get a full-width
5291 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5292 * probably be bigger too.
5293 */
5294#if RANDBITS > 16
5295# define SEED_C1 1000003
5296#define SEED_C4 73819
5297#else
5298# define SEED_C1 25747
5299#define SEED_C4 20639
5300#endif
5301#define SEED_C2 3
5302#define SEED_C3 269
5303#define SEED_C5 26107
5304
5305#ifndef PERL_NO_DEV_RANDOM
5306 int fd;
5307#endif
5308 U32 u;
5309#ifdef VMS
5310# include <starlet.h>
5311 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5312 * in 100-ns units, typically incremented ever 10 ms. */
5313 unsigned int when[2];
5314#else
5315# ifdef HAS_GETTIMEOFDAY
5316 struct timeval when;
5317# else
5318 Time_t when;
5319# endif
5320#endif
5321
5322/* This test is an escape hatch, this symbol isn't set by Configure. */
5323#ifndef PERL_NO_DEV_RANDOM
5324#ifndef PERL_RANDOM_DEVICE
5325 /* /dev/random isn't used by default because reads from it will block
5326 * if there isn't enough entropy available. You can compile with
5327 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5328 * is enough real entropy to fill the seed. */
5329# define PERL_RANDOM_DEVICE "/dev/urandom"
5330#endif
5331 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5332 if (fd != -1) {
27da23d5 5333 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
132efe8b
JH		 5334 u = 0;
5335 PerlLIO_close(fd);
5336 if (u)
5337 return u;
5338 }
5339#endif
5340
5341#ifdef VMS
5342 _ckvmssts(sys$gettim(when));
5343 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5344#else
5345# ifdef HAS_GETTIMEOFDAY
5346 PerlProc_gettimeofday(&when,NULL);
5347 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5348# else
5349 (void)time(&when);
5350 u = (U32)SEED_C1 * when;
5351# endif
5352#endif
5353 u += SEED_C3 * (U32)PerlProc_getpid();
5354 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5355#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5356 u += SEED_C5 * (U32)PTR2UV(&when);
5357#endif
5358 return u;
5359}
5360
bed60192 5361UV
a783c5f4 5362Perl_get_hash_seed(pTHX)
bed60192 5363{
97aff369 5364 dVAR;
e1ec3a88 5365 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
bed60192
JH		 5366 UV myseed = 0;
5367
5368 if (s)
35da51f7
AL		 5369 while (isSPACE(*s))
5370 s++;
bed60192
JH		 5371 if (s && isDIGIT(*s))
5372 myseed = (UV)Atoul(s);
5373 else
5374#ifdef USE_HASH_SEED_EXPLICIT
5375 if (s)
5376#endif
5377 {
5378 /* Compute a random seed */
5379 (void)seedDrand01((Rand_seed_t)seed());
bed60192
JH		 5380 myseed = (UV)(Drand01() * (NV)UV_MAX);
5381#if RANDBITS < (UVSIZE * 8)
5382 /* Since there are not enough randbits to to reach all
5383 * the bits of a UV, the low bits might need extra
5384 * help. Sum in another random number that will
5385 * fill in the low bits. */
5386 myseed +=
5387 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5388#endif /* RANDBITS < (UVSIZE * 8) */
6cfd5ea7
JH		 5389 if (myseed == 0) { /* Superparanoia. */
5390 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5391 if (myseed == 0)
5392 Perl_croak(aTHX_ "Your random numbers are not that random");
5393 }
bed60192 5394 }
008fb0c0 5395 PL_rehash_seed_set = TRUE;
bed60192
JH		 5396
5397 return myseed;
5398}
27da23d5 5399
ed221c57
AL		 5400#ifdef USE_ITHREADS
5401bool
5402Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5403{
5404 const char * const stashpv = CopSTASHPV(c);
5405 const char * const name = HvNAME_get(hv);
96a5add6 5406 PERL_UNUSED_CONTEXT;
7918f24d 5407 PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
ed221c57
AL		 5408
5409 if (stashpv == name)
5410 return TRUE;
5411 if (stashpv && name)
5412 if (strEQ(stashpv, name))
5413 return TRUE;
5414 return FALSE;
5415}
5416#endif
5417
5418
27da23d5
JH		 5419#ifdef PERL_GLOBAL_STRUCT
5420
bae1192d
JH		 5421#define PERL_GLOBAL_STRUCT_INIT
5422#include "opcode.h" /* the ppaddr and check */
5423
27da23d5
JH		 5424struct perl_vars *
5425Perl_init_global_struct(pTHX)
5426{
5427 struct perl_vars *plvarsp = NULL;
bae1192d 5428# ifdef PERL_GLOBAL_STRUCT
7452cf6a
AL		 5429 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5430 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
27da23d5
JH		 5431# ifdef PERL_GLOBAL_STRUCT_PRIVATE
5432 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5433 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5434 if (!plvarsp)
5435 exit(1);
5436# else
5437 plvarsp = PL_VarsPtr;
5438# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
aadb217d
JH		 5439# undef PERLVAR
5440# undef PERLVARA
5441# undef PERLVARI
5442# undef PERLVARIC
5443# undef PERLVARISC
27da23d5
JH		 5444# define PERLVAR(var,type) /**/
5445# define PERLVARA(var,n,type) /**/
5446# define PERLVARI(var,type,init) plvarsp->var = init;
5447# define PERLVARIC(var,type,init) plvarsp->var = init;
5448# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5449# include "perlvars.h"
5450# undef PERLVAR
5451# undef PERLVARA
5452# undef PERLVARI
5453# undef PERLVARIC
5454# undef PERLVARISC
5455# ifdef PERL_GLOBAL_STRUCT
bae1192d
JH		 5456 plvarsp->Gppaddr =
5457 (Perl_ppaddr_t*)
5458 PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
27da23d5
JH		 5459 if (!plvarsp->Gppaddr)
5460 exit(1);
bae1192d
JH		 5461 plvarsp->Gcheck =
5462 (Perl_check_t*)
5463 PerlMem_malloc(ncheck * sizeof(Perl_check_t));
27da23d5
JH		 5464 if (!plvarsp->Gcheck)
5465 exit(1);
5466 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5467 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5468# endif
5469# ifdef PERL_SET_VARS
5470 PERL_SET_VARS(plvarsp);
5471# endif
bae1192d
JH		 5472# undef PERL_GLOBAL_STRUCT_INIT
5473# endif
27da23d5
JH		 5474 return plvarsp;
5475}
5476
5477#endif /* PERL_GLOBAL_STRUCT */
5478
5479#ifdef PERL_GLOBAL_STRUCT
5480
5481void
5482Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5483{
7918f24d 5484 PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
bae1192d 5485# ifdef PERL_GLOBAL_STRUCT
27da23d5
JH		 5486# ifdef PERL_UNSET_VARS
5487 PERL_UNSET_VARS(plvarsp);
5488# endif
5489 free(plvarsp->Gppaddr);
5490 free(plvarsp->Gcheck);
bae1192d 5491# ifdef PERL_GLOBAL_STRUCT_PRIVATE
27da23d5 5492 free(plvarsp);
bae1192d
JH		 5493# endif
5494# endif
27da23d5
JH		 5495}
5496
5497#endif /* PERL_GLOBAL_STRUCT */
5498
fe4f188c
JH		 5499#ifdef PERL_MEM_LOG
5500
65ceff02
JH		 5501/*
5502 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5503 *
5504 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5505 * variable PERL_MEM_LOG will be consulted, and if the integer value
5506 * of that is true, the logging will happen. (The default is to
5507 * always log if the PERL_MEM_LOG define was in effect.)
5508 */
5509
5510/*
5511 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5512 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5513 */
e352bcff
JH		 5514#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5515
65ceff02
JH		 5516/*
5517 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5518 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5519 * in which case the environment variable PERL_MEM_LOG_FD will be
5520 * consulted for the file descriptor number to use.
5521 */
5522#ifndef PERL_MEM_LOG_FD
5523# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5524#endif
5525
fe4f188c 5526Malloc_t
46c6c7e2 5527Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5528{
5529#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5530# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5531 char *s;
5532# endif
5533# ifdef PERL_MEM_LOG_ENV
5534 s = getenv("PERL_MEM_LOG");
5535 if (s ? atoi(s) : 0)
5536# endif
5537 {
5538 /* We can't use SVs or PerlIO for obvious reasons,
5539 * so we'll use stdio and low-level IO instead. */
5540 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5541# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02 5542 struct timeval tv;
5b692037 5543# ifdef HAS_GETTIMEOFDAY
65ceff02 5544 gettimeofday(&tv, 0);
5b692037
JH		 5545# endif
5546 /* If there are other OS specific ways of hires time than
5547 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5548 * probably that they would be used to fill in the struct
5549 * timeval. */
5550# endif
65ceff02
JH		 5551 {
5552 const STRLEN len =
d9fad198 5553 my_snprintf(buf,
d1307786 5554 sizeof(buf),
5b692037
JH		 5555# ifdef PERL_MEM_LOG_TIMESTAMP
5556 "%10d.%06d: "
5557# endif
d9fad198
JH		 5558 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5559 " %s = %"IVdf": %"UVxf"\n",
5b692037
JH		 5560# ifdef PERL_MEM_LOG_TIMESTAMP
5561 (int)tv.tv_sec, (int)tv.tv_usec,
5562# endif
d9fad198
JH		 5563 filename, linenumber, funcname, n, typesize,
5564 typename, n * typesize, PTR2UV(newalloc));
65ceff02
JH		 5565# ifdef PERL_MEM_LOG_ENV_FD
5566 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5567 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5568# else
5569 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5570#endif
5571 }
5572 }
fe4f188c
JH		 5573#endif
5574 return newalloc;
5575}
5576
5577Malloc_t
46c6c7e2 5578Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5579{
5580#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5581# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5582 char *s;
5583# endif
5584# ifdef PERL_MEM_LOG_ENV
5585 s = PerlEnv_getenv("PERL_MEM_LOG");
5586 if (s ? atoi(s) : 0)
5587# endif
5588 {
5589 /* We can't use SVs or PerlIO for obvious reasons,
5590 * so we'll use stdio and low-level IO instead. */
5591 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5592# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02
JH		 5593 struct timeval tv;
5594 gettimeofday(&tv, 0);
5b692037 5595# endif
65ceff02
JH		 5596 {
5597 const STRLEN len =
d9fad198 5598 my_snprintf(buf,
d1307786 5599 sizeof(buf),
5b692037
JH		 5600# ifdef PERL_MEM_LOG_TIMESTAMP
5601 "%10d.%06d: "
5602# endif
d9fad198
JH		 5603 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5604 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5b692037
JH		 5605# ifdef PERL_MEM_LOG_TIMESTAMP
5606 (int)tv.tv_sec, (int)tv.tv_usec,
5607# endif
d9fad198
JH		 5608 filename, linenumber, funcname, n, typesize,
5609 typename, n * typesize, PTR2UV(oldalloc),
5610 PTR2UV(newalloc));
65ceff02
JH		 5611# ifdef PERL_MEM_LOG_ENV_FD
5612 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5613 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5614# else
5615 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5616# endif
5617 }
5618 }
fe4f188c
JH		 5619#endif
5620 return newalloc;
5621}
5622
5623Malloc_t
46c6c7e2 5624Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5625{
5626#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5627# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5628 char *s;
5629# endif
5630# ifdef PERL_MEM_LOG_ENV
5631 s = PerlEnv_getenv("PERL_MEM_LOG");
5632 if (s ? atoi(s) : 0)
5633# endif
5634 {
5635 /* We can't use SVs or PerlIO for obvious reasons,
5636 * so we'll use stdio and low-level IO instead. */
5637 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5638# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02
JH		 5639 struct timeval tv;
5640 gettimeofday(&tv, 0);
5b692037 5641# endif
65ceff02
JH		 5642 {
5643 const STRLEN len =
d9fad198 5644 my_snprintf(buf,
d1307786 5645 sizeof(buf),
5b692037
JH		 5646# ifdef PERL_MEM_LOG_TIMESTAMP
5647 "%10d.%06d: "
5648# endif
5649 "free: %s:%d:%s: %"UVxf"\n",
5650# ifdef PERL_MEM_LOG_TIMESTAMP
d9fad198 5651 (int)tv.tv_sec, (int)tv.tv_usec,
5b692037 5652# endif
d9fad198
JH		 5653 filename, linenumber, funcname,
5654 PTR2UV(oldalloc));
65ceff02
JH		 5655# ifdef PERL_MEM_LOG_ENV_FD
5656 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5657 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5658# else
5659 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5660# endif
5661 }
5662 }
fe4f188c
JH		 5663#endif
5664 return oldalloc;
5665}
5666
5667#endif /* PERL_MEM_LOG */
5668
66610fdd 5669/*
ce582cee
NC		 5670=for apidoc my_sprintf
5671
5672The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5673the length of the string written to the buffer. Only rare pre-ANSI systems
5674need the wrapper function - usually this is a direct call to C<sprintf>.
5675
5676=cut
5677*/
5678#ifndef SPRINTF_RETURNS_STRLEN
5679int
5680Perl_my_sprintf(char *buffer, const char* pat, ...)
5681{
5682 va_list args;
7918f24d 5683 PERL_ARGS_ASSERT_MY_SPRINTF;
ce582cee
NC		 5684 va_start(args, pat);
5685 vsprintf(buffer, pat, args);
5686 va_end(args);
5687 return strlen(buffer);
5688}
5689#endif
5690
d9fad198
JH		 5691/*
5692=for apidoc my_snprintf
5693
5694The C library C<snprintf> functionality, if available and
5b692037 5695standards-compliant (uses C<vsnprintf>, actually). However, if the
d9fad198 5696C<vsnprintf> is not available, will unfortunately use the unsafe
5b692037
JH		 5697C<vsprintf> which can overrun the buffer (there is an overrun check,
5698but that may be too late). Consider using C<sv_vcatpvf> instead, or
5699getting C<vsnprintf>.
d9fad198
JH		 5700
5701=cut
5702*/
5703int
5704Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
d9fad198
JH		 5705{
5706 dTHX;
5707 int retval;
5708 va_list ap;
7918f24d 5709 PERL_ARGS_ASSERT_MY_SNPRINTF;
d9fad198 5710 va_start(ap, format);
5b692037 5711#ifdef HAS_VSNPRINTF
d9fad198
JH		 5712 retval = vsnprintf(buffer, len, format, ap);
5713#else
5714 retval = vsprintf(buffer, format, ap);
5715#endif
5716 va_end(ap);
1208b3dd 5717 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
625dac9d 5718 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5b692037 5719 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
d9fad198
JH		 5720 return retval;
5721}
5722
5723/*
5724=for apidoc my_vsnprintf
5725
5b692037
JH		 5726The C library C<vsnprintf> if available and standards-compliant.
5727However, if if the C<vsnprintf> is not available, will unfortunately
5728use the unsafe C<vsprintf> which can overrun the buffer (there is an
5729overrun check, but that may be too late). Consider using
5730C<sv_vcatpvf> instead, or getting C<vsnprintf>.
d9fad198
JH		 5731
5732=cut
5733*/
5734int
5735Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
d9fad198
JH		 5736{
5737 dTHX;
5738 int retval;
d9fad198
JH		 5739#ifdef NEED_VA_COPY
5740 va_list apc;
7918f24d
NC		 5741
5742 PERL_ARGS_ASSERT_MY_VSNPRINTF;
5743
239fec62 5744 Perl_va_copy(ap, apc);
5b692037 5745# ifdef HAS_VSNPRINTF
d9fad198
JH		 5746 retval = vsnprintf(buffer, len, format, apc);
5747# else
5748 retval = vsprintf(buffer, format, apc);
5749# endif
5750#else
5b692037 5751# ifdef HAS_VSNPRINTF
d9fad198
JH		 5752 retval = vsnprintf(buffer, len, format, ap);
5753# else
5754 retval = vsprintf(buffer, format, ap);
5755# endif
5b692037 5756#endif /* #ifdef NEED_VA_COPY */
1208b3dd 5757 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
625dac9d 5758 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5b692037 5759 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
d9fad198
JH		 5760 return retval;
5761}
5762
b0269e46
AB		 5763void
5764Perl_my_clearenv(pTHX)
5765{
5766 dVAR;
5767#if ! defined(PERL_MICRO)
5768# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5769 PerlEnv_clearenv();
5770# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5771# if defined(USE_ENVIRON_ARRAY)
5772# if defined(USE_ITHREADS)
5773 /* only the parent thread can clobber the process environment */
5774 if (PL_curinterp == aTHX)
5775# endif /* USE_ITHREADS */
5776 {
5777# if ! defined(PERL_USE_SAFE_PUTENV)
5778 if ( !PL_use_safe_putenv) {
5779 I32 i;
5780 if (environ == PL_origenviron)
5781 environ = (char**)safesysmalloc(sizeof(char*));
5782 else
5783 for (i = 0; environ[i]; i++)
5784 (void)safesysfree(environ[i]);
5785 }
5786 environ[0] = NULL;
5787# else /* PERL_USE_SAFE_PUTENV */
5788# if defined(HAS_CLEARENV)
5789 (void)clearenv();
5790# elif defined(HAS_UNSETENV)
5791 int bsiz = 80; /* Most envvar names will be shorter than this. */
d1307786
JH		 5792 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5793 char *buf = (char*)safesysmalloc(bufsiz);
b0269e46
AB		 5794 while (*environ != NULL) {
5795 char *e = strchr(*environ, '=');
b57a0404 5796 int l = e ? e - *environ : (int)strlen(*environ);
b0269e46
AB		 5797 if (bsiz < l + 1) {
5798 (void)safesysfree(buf);
1bdfa2de 5799 bsiz = l + 1; /* + 1 for the \0. */
d1307786 5800 buf = (char*)safesysmalloc(bufsiz);
b0269e46 5801 }
82d8bb49
NC		 5802 memcpy(buf, *environ, l);
5803 buf[l] = '\0';
b0269e46
AB		 5804 (void)unsetenv(buf);
5805 }
5806 (void)safesysfree(buf);
5807# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5808 /* Just null environ and accept the leakage. */
5809 *environ = NULL;
5810# endif /* HAS_CLEARENV || HAS_UNSETENV */
5811# endif /* ! PERL_USE_SAFE_PUTENV */
5812 }
5813# endif /* USE_ENVIRON_ARRAY */
5814# endif /* PERL_IMPLICIT_SYS || WIN32 */
5815#endif /* PERL_MICRO */
5816}
5817
f16dd614
DM		 5818#ifdef PERL_IMPLICIT_CONTEXT
5819
53d44271 5820/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
f16dd614
DM		 5821the global PL_my_cxt_index is incremented, and that value is assigned to
5822that module's static my_cxt_index (who's address is passed as an arg).
5823Then, for each interpreter this function is called for, it makes sure a
5824void* slot is available to hang the static data off, by allocating or
5825extending the interpreter's PL_my_cxt_list array */
5826
53d44271 5827#ifndef PERL_GLOBAL_STRUCT_PRIVATE
f16dd614
DM		 5828void *
5829Perl_my_cxt_init(pTHX_ int *index, size_t size)
5830{
97aff369 5831 dVAR;
f16dd614 5832 void *p;
7918f24d 5833 PERL_ARGS_ASSERT_MY_CXT_INIT;
f16dd614
DM		 5834 if (*index == -1) {
5835 /* this module hasn't been allocated an index yet */
5836 MUTEX_LOCK(&PL_my_ctx_mutex);
5837 *index = PL_my_cxt_index++;
5838 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5839 }
5840
5841 /* make sure the array is big enough */
4c901e72
DM		 5842 if (PL_my_cxt_size <= *index) {
5843 if (PL_my_cxt_size) {
5844 while (PL_my_cxt_size <= *index)
f16dd614
DM		 5845 PL_my_cxt_size *= 2;
5846 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5847 }
5848 else {
5849 PL_my_cxt_size = 16;
5850 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5851 }
5852 }
5853 /* newSV() allocates one more than needed */
5854 p = (void*)SvPVX(newSV(size-1));
5855 PL_my_cxt_list[*index] = p;
5856 Zero(p, size, char);
5857 return p;
5858}
53d44271
JH		 5859
5860#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5861
5862int
5863Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5864{
5865 dVAR;
5866 int index;
5867
7918f24d
NC		 5868 PERL_ARGS_ASSERT_MY_CXT_INDEX;
5869
53d44271
JH		 5870 for (index = 0; index < PL_my_cxt_index; index++) {
5871 const char *key = PL_my_cxt_keys[index];
5872 /* try direct pointer compare first - there are chances to success,
5873 * and it's much faster.
5874 */
5875 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5876 return index;
5877 }
5878 return -1;
5879}
5880
5881void *
5882Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5883{
5884 dVAR;
5885 void *p;
5886 int index;
5887
7918f24d
NC		 5888 PERL_ARGS_ASSERT_MY_CXT_INIT;
5889
53d44271
JH		 5890 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5891 if (index == -1) {
5892 /* this module hasn't been allocated an index yet */
5893 MUTEX_LOCK(&PL_my_ctx_mutex);
5894 index = PL_my_cxt_index++;
5895 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5896 }
5897
5898 /* make sure the array is big enough */
5899 if (PL_my_cxt_size <= index) {
5900 int old_size = PL_my_cxt_size;
5901 int i;
5902 if (PL_my_cxt_size) {
5903 while (PL_my_cxt_size <= index)
5904 PL_my_cxt_size *= 2;
5905 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5906 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5907 }
5908 else {
5909 PL_my_cxt_size = 16;
5910 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5911 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5912 }
5913 for (i = old_size; i < PL_my_cxt_size; i++) {
5914 PL_my_cxt_keys[i] = 0;
5915 PL_my_cxt_list[i] = 0;
5916 }
5917 }
5918 PL_my_cxt_keys[index] = my_cxt_key;
5919 /* newSV() allocates one more than needed */
5920 p = (void*)SvPVX(newSV(size-1));
5921 PL_my_cxt_list[index] = p;
5922 Zero(p, size, char);
5923 return p;
5924}
5925#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5926#endif /* PERL_IMPLICIT_CONTEXT */
f16dd614 5927
a6cc4119
SP		 5928#ifndef HAS_STRLCAT
5929Size_t
5930Perl_my_strlcat(char *dst, const char *src, Size_t size)
5931{
5932 Size_t used, length, copy;
5933
5934 used = strlen(dst);
5935 length = strlen(src);
5936 if (size > 0 && used < size - 1) {
5937 copy = (length >= size - used) ? size - used - 1 : length;
5938 memcpy(dst + used, src, copy);
5939 dst[used + copy] = '\0';
5940 }
5941 return used + length;
5942}
5943#endif
5944
5945#ifndef HAS_STRLCPY
5946Size_t
5947Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5948{
5949 Size_t length, copy;
5950
5951 length = strlen(src);
5952 if (size > 0) {
5953 copy = (length >= size) ? size - 1 : length;
5954 memcpy(dst, src, copy);
5955 dst[copy] = '\0';
5956 }
5957 return length;
5958}
5959#endif
5960
17dd9954
JH		 5961#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5962/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5963long _ftol( double ); /* Defined by VC6 C libs. */
5964long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5965#endif
5966
c51f309c
NC		 5967void
5968Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5969{
5970 dVAR;
5971 SV * const dbsv = GvSVn(PL_DBsub);
5972 /* We do not care about using sv to call CV;
5973 * it's for informational purposes only.
5974 */
5975
7918f24d
NC		 5976 PERL_ARGS_ASSERT_GET_DB_SUB;
5977
c51f309c
NC		 5978 save_item(dbsv);
5979 if (!PERLDB_SUB_NN) {
5980 GV * const gv = CvGV(cv);
5981
5982 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5983 || strEQ(GvNAME(gv), "END")
5984 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5985 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5986 /* Use GV from the stack as a fallback. */
5987 /* GV is potentially non-unique, or contain different CV. */
5988 SV * const tmp = newRV((SV*)cv);
5989 sv_setsv(dbsv, tmp);
5990 SvREFCNT_dec(tmp);
5991 }
5992 else {
5993 gv_efullname3(dbsv, gv, NULL);
5994 }
5995 }
5996 else {
5997 const int type = SvTYPE(dbsv);
5998 if (type < SVt_PVIV && type != SVt_IV)
5999 sv_upgrade(dbsv, SVt_PVIV);
6000 (void)SvIOK_on(dbsv);
6001 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
6002 }
6003}
6004
3497a01f 6005int
08ea85eb 6006Perl_my_dirfd(pTHX_ DIR * dir) {
3497a01f
SP		 6007
6008 /* Most dirfd implementations have problems when passed NULL. */
6009 if(!dir)
6010 return -1;
6011#ifdef HAS_DIRFD
6012 return dirfd(dir);
6013#elif defined(HAS_DIR_DD_FD)
6014 return dir->dd_fd;
6015#else
6016 Perl_die(aTHX_ PL_no_func, "dirfd");
6017 /* NOT REACHED */
6018 return 0;
6019#endif
6020}
6021
f7e71195
AB		 6022REGEXP *
6023Perl_get_re_arg(pTHX_ SV *sv) {
6024 SV *tmpsv;
f7e71195
AB		 6025
6026 if (sv) {
6027 if (SvMAGICAL(sv))
6028 mg_get(sv);
6029 if (SvROK(sv) &&
6030 (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */
5c35adbb 6031 SvTYPE(tmpsv) == SVt_REGEXP)
f7e71195 6032 {
d2f13c59 6033 return (REGEXP*) tmpsv;
f7e71195
AB		 6034 }
6035 }
6036
6037 return NULL;
6038}
6039
ce582cee 6040/*
66610fdd
RGS		 6041 * Local variables:
6042 * c-indentation-style: bsd
6043 * c-basic-offset: 4
6044 * indent-tabs-mode: t
6045 * End:
6046 *
37442d52
RGS		 6047 * ex: set ts=8 sts=4 sw=4 noet:
6048 */
Unnamed repository; edit this file 'description' to name the repository.