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