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