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