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