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