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