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