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