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
don't repopulate PADTMP slots with null SVs when freeing ops
[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 952STATIC COP*
8772537c 953S_closest_cop(pTHX_ COP *cop, const OP *o)
ae7d165c
PJ		 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
8772537c 980 return Null(COP *);
ae7d165c
PJ		 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 */
53c1dcc0 1054 const int e = errno;
7ff03255 1055#endif
53c1dcc0 1056 PerlIO * const serr = Perl_error_log;
7ff03255
SG		 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;
06bf62c7 1257 STRLEN msglen;
53c1dcc0
AL		 1258 SV * const msv = vmess(pat, args);
1259 const I32 utf8 = SvUTF8(msv);
1260 const char * const message = SvPV_const(msv, msglen);
a687059c 1261
3280af22 1262 if (PL_warnhook) {
cea2e8a9 1263 /* sv_2cv might call Perl_warn() */
53c1dcc0
AL		 1264 SV * const oldwarnhook = PL_warnhook;
1265 CV * cv;
1266 HV * stash;
1267 GV * gv;
1268
1738f5c4 1269 ENTER;
3280af22
NIS		 1270 SAVESPTR(PL_warnhook);
1271 PL_warnhook = Nullsv;
20cec16a 1272 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1738f5c4
CS		 1273 LEAVE;
1274 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1275 dSP;
774d564b 1276 SV *msg;
1277
1278 ENTER;
3a1f2dc9 1279 save_re_context();
06bf62c7 1280 msg = newSVpvn(message, msglen);
ff882698 1281 SvFLAGS(msg) |= utf8;
774d564b 1282 SvREADONLY_on(msg);
1283 SAVEFREESV(msg);
1284
e788e7d3 1285 PUSHSTACKi(PERLSI_WARNHOOK);
924508f0 1286 PUSHMARK(SP);
774d564b 1287 XPUSHs(msg);
20cec16a 1288 PUTBACK;
864dbfa3 1289 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1290 POPSTACK;
774d564b 1291 LEAVE;
20cec16a 1292 return;
1293 }
748a9306 1294 }
87582a92 1295
7ff03255 1296 write_to_stderr(message, msglen);
a687059c 1297}
8d063cd8 1298
c5be433b 1299#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1300void
1301Perl_warn_nocontext(const char *pat, ...)
1302{
1303 dTHX;
1304 va_list args;
1305 va_start(args, pat);
c5be433b 1306 vwarn(pat, &args);
cea2e8a9
GS		 1307 va_end(args);
1308}
1309#endif /* PERL_IMPLICIT_CONTEXT */
1310
954c1994
GS		 1311/*
1312=for apidoc warn
1313
966353fd
MF		 1314This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1315function the same way you call the C C<printf> function. See C<croak>.
954c1994
GS		 1316
1317=cut
1318*/
1319
cea2e8a9
GS		 1320void
1321Perl_warn(pTHX_ const char *pat, ...)
1322{
1323 va_list args;
1324 va_start(args, pat);
c5be433b 1325 vwarn(pat, &args);
cea2e8a9
GS		 1326 va_end(args);
1327}
1328
c5be433b
GS		 1329#if defined(PERL_IMPLICIT_CONTEXT)
1330void
1331Perl_warner_nocontext(U32 err, const char *pat, ...)
1332{
27da23d5 1333 dTHX;
c5be433b
GS		 1334 va_list args;
1335 va_start(args, pat);
1336 vwarner(err, pat, &args);
1337 va_end(args);
1338}
1339#endif /* PERL_IMPLICIT_CONTEXT */
1340
599cee73 1341void
864dbfa3 1342Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1343{
1344 va_list args;
c5be433b
GS		 1345 va_start(args, pat);
1346 vwarner(err, pat, &args);
1347 va_end(args);
1348}
1349
1350void
1351Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1352{
27da23d5 1353 dVAR;
d13b0d77 1354 if (ckDEAD(err)) {
a3b680e6 1355 SV * const msv = vmess(pat, args);
d13b0d77 1356 STRLEN msglen;
cfd0369c 1357 const char *message = SvPV_const(msv, msglen);
a3b680e6 1358 const I32 utf8 = SvUTF8(msv);
599cee73 1359
3aed30dc 1360 if (PL_diehook) {
63315e18
NC		 1361 assert(message);
1362 S_vdie_common(aTHX_ message, msglen, utf8);
3aed30dc
HS		 1363 }
1364 if (PL_in_eval) {
1365 PL_restartop = die_where(message, msglen);
ff882698 1366 SvFLAGS(ERRSV) |= utf8;
3aed30dc
HS		 1367 JMPENV_JUMP(3);
1368 }
7ff03255 1369 write_to_stderr(message, msglen);
3aed30dc 1370 my_failure_exit();
599cee73
PM		 1371 }
1372 else {
d13b0d77 1373 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 1374 }
1375}
1376
e6587932
DM		 1377/* since we've already done strlen() for both nam and val
1378 * we can use that info to make things faster than
1379 * sprintf(s, "%s=%s", nam, val)
1380 */
1381#define my_setenv_format(s, nam, nlen, val, vlen) \
1382 Copy(nam, s, nlen, char); \
1383 *(s+nlen) = '='; \
1384 Copy(val, s+(nlen+1), vlen, char); \
1385 *(s+(nlen+1+vlen)) = '\0'
1386
13b6e58c 1387#ifdef USE_ENVIRON_ARRAY
eccd403f 1388 /* VMS' my_setenv() is in vms.c */
2986a63f 1389#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1390void
e1ec3a88 1391Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1392{
27da23d5 1393 dVAR;
4efc5df6
GS		 1394#ifdef USE_ITHREADS
1395 /* only parent thread can modify process environment */
1396 if (PL_curinterp == aTHX)
1397#endif
1398 {
f2517201 1399#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1400 if (!PL_use_safe_putenv) {
f2517201 1401 /* most putenv()s leak, so we manipulate environ directly */
79072805 1402 register I32 i=setenv_getix(nam); /* where does it go? */
e6587932 1403 int nlen, vlen;
8d063cd8 1404
3280af22 1405 if (environ == PL_origenviron) { /* need we copy environment? */
79072805
LW		 1406 I32 j;
1407 I32 max;
fe14fcc3
LW		 1408 char **tmpenv;
1409
1410 for (max = i; environ[max]; max++) ;
f2517201
GS		 1411 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1412 for (j=0; j<max; j++) { /* copy environment */
e1ec3a88 1413 const int len = strlen(environ[j]);
3aed30dc
HS		 1414 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1415 Copy(environ[j], tmpenv[j], len+1, char);
f2517201 1416 }
fe14fcc3
LW		 1417 tmpenv[max] = Nullch;
1418 environ = tmpenv; /* tell exec where it is now */
1419 }
a687059c 1420 if (!val) {
f2517201 1421 safesysfree(environ[i]);
a687059c
LW		 1422 while (environ[i]) {
1423 environ[i] = environ[i+1];
1424 i++;
1425 }
1426 return;
1427 }
8d063cd8 1428 if (!environ[i]) { /* does not exist yet */
f2517201 1429 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
8d063cd8
LW		 1430 environ[i+1] = Nullch; /* make sure it's null terminated */
1431 }
fe14fcc3 1432 else
f2517201 1433 safesysfree(environ[i]);
e6587932
DM		 1434 nlen = strlen(nam);
1435 vlen = strlen(val);
f2517201 1436
e6587932
DM		 1437 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1438 /* all that work just for this */
1439 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95
MS		 1440 } else {
1441# endif
27da23d5 1442# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
47dafe4d
EF		 1443 setenv(nam, val, 1);
1444# else
f2517201 1445 char *new_env;
53c1dcc0
AL		 1446 const int nlen = strlen(nam);
1447 int vlen;
e6587932 1448 if (!val) {
3aed30dc 1449 val = "";
e6587932
DM		 1450 }
1451 vlen = strlen(val);
1452 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1453 /* all that work just for this */
1454 my_setenv_format(new_env, nam, nlen, val, vlen);
f2517201 1455 (void)putenv(new_env);
47dafe4d 1456# endif /* __CYGWIN__ */
50acdf95
MS		 1457#ifndef PERL_USE_SAFE_PUTENV
1458 }
1459#endif
4efc5df6 1460 }
8d063cd8
LW		 1461}
1462
2986a63f 1463#else /* WIN32 || NETWARE */
68dc0745 1464
1465void
72229eff 1466Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1467{
27da23d5 1468 dVAR;
ac5c734f 1469 register char *envstr;
e1ec3a88
AL		 1470 const int nlen = strlen(nam);
1471 int vlen;
e6587932 1472
ac5c734f
GS		 1473 if (!val) {
1474 val = "";
1475 }
e6587932
DM		 1476 vlen = strlen(val);
1477 New(904, envstr, nlen+vlen+2, char);
1478 my_setenv_format(envstr, nam, nlen, val, vlen);
ac5c734f
GS		 1479 (void)PerlEnv_putenv(envstr);
1480 Safefree(envstr);
3e3baf6d
TB		 1481}
1482
2986a63f 1483#endif /* WIN32 || NETWARE */
3e3baf6d 1484
2f42fcb0 1485#ifndef PERL_MICRO
3e3baf6d 1486I32
e1ec3a88 1487Perl_setenv_getix(pTHX_ const char *nam)
3e3baf6d 1488{
53c1dcc0
AL		 1489 register I32 i;
1490 const register I32 len = strlen(nam);
3e3baf6d
TB		 1491
1492 for (i = 0; environ[i]; i++) {
1493 if (
1494#ifdef WIN32
1495 strnicmp(environ[i],nam,len) == 0
1496#else
1497 strnEQ(environ[i],nam,len)
1498#endif
1499 && environ[i][len] == '=')
1500 break; /* strnEQ must come first to avoid */
1501 } /* potential SEGV's */
1502 return i;
68dc0745 1503}
2f42fcb0 1504#endif /* !PERL_MICRO */
68dc0745 1505
ed79a026 1506#endif /* !VMS && !EPOC*/
378cc40b 1507
16d20bd9 1508#ifdef UNLINK_ALL_VERSIONS
79072805 1509I32
864dbfa3 1510Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
378cc40b 1511{
79072805 1512 I32 i;
378cc40b 1513
6ad3d225 1514 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
378cc40b
LW		 1515 return i ? 0 : -1;
1516}
1517#endif
1518
7a3f2258 1519/* this is a drop-in replacement for bcopy() */
2253333f 1520#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1521char *
7a3f2258 1522Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b
LW		 1523{
1524 char *retval = to;
1525
7c0587c8
LW		 1526 if (from - to >= 0) {
1527 while (len--)
1528 *to++ = *from++;
1529 }
1530 else {
1531 to += len;
1532 from += len;
1533 while (len--)
faf8582f 1534 *(--to) = *(--from);
7c0587c8 1535 }
378cc40b
LW		 1536 return retval;
1537}
ffed7fef 1538#endif
378cc40b 1539
7a3f2258 1540/* this is a drop-in replacement for memset() */
fc36a67e 1541#ifndef HAS_MEMSET
1542void *
7a3f2258 1543Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1544{
1545 char *retval = loc;
1546
1547 while (len--)
1548 *loc++ = ch;
1549 return retval;
1550}
1551#endif
1552
7a3f2258 1553/* this is a drop-in replacement for bzero() */
7c0587c8 1554#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1555char *
7a3f2258 1556Perl_my_bzero(register char *loc, register I32 len)
378cc40b
LW		 1557{
1558 char *retval = loc;
1559
1560 while (len--)
1561 *loc++ = 0;
1562 return retval;
1563}
1564#endif
7c0587c8 1565
7a3f2258 1566/* this is a drop-in replacement for memcmp() */
36477c24 1567#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1568I32
7a3f2258 1569Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1570{
e1ec3a88
AL		 1571 register const U8 *a = (const U8 *)s1;
1572 register const U8 *b = (const U8 *)s2;
79072805 1573 register I32 tmp;
7c0587c8
LW		 1574
1575 while (len--) {
27da23d5 1576 if ((tmp = *a++ - *b++))
7c0587c8
LW		 1577 return tmp;
1578 }
1579 return 0;
1580}
36477c24 1581#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1582
fe14fcc3 1583#ifndef HAS_VPRINTF
a687059c 1584
85e6fe83 1585#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1586char *
1587#else
1588int
1589#endif
08105a92 1590vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 1591{
1592 FILE fakebuf;
1593
1594 fakebuf._ptr = dest;
1595 fakebuf._cnt = 32767;
35c8bce7
LW		 1596#ifndef _IOSTRG
1597#define _IOSTRG 0
1598#endif
a687059c
LW		 1599 fakebuf._flag = _IOWRT|_IOSTRG;
1600 _doprnt(pat, args, &fakebuf); /* what a kludge */
1601 (void)putc('\0', &fakebuf);
85e6fe83 1602#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1603 return(dest);
1604#else
1605 return 0; /* perl doesn't use return value */
1606#endif
1607}
1608
fe14fcc3 1609#endif /* HAS_VPRINTF */
a687059c
LW		 1610
1611#ifdef MYSWAP
ffed7fef 1612#if BYTEORDER != 0x4321
a687059c 1613short
864dbfa3 1614Perl_my_swap(pTHX_ short s)
a687059c
LW		 1615{
1616#if (BYTEORDER & 1) == 0
1617 short result;
1618
1619 result = ((s & 255) << 8) + ((s >> 8) & 255);
1620 return result;
1621#else
1622 return s;
1623#endif
1624}
1625
1626long
864dbfa3 1627Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1628{
1629 union {
1630 long result;
ffed7fef 1631 char c[sizeof(long)];
a687059c
LW		 1632 } u;
1633
ffed7fef 1634#if BYTEORDER == 0x1234
a687059c
LW		 1635 u.c[0] = (l >> 24) & 255;
1636 u.c[1] = (l >> 16) & 255;
1637 u.c[2] = (l >> 8) & 255;
1638 u.c[3] = l & 255;
1639 return u.result;
1640#else
ffed7fef 1641#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1642 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1643#else
79072805
LW		 1644 register I32 o;
1645 register I32 s;
a687059c 1646
ffed7fef
LW		 1647 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1648 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1649 }
1650 return u.result;
1651#endif
1652#endif
1653}
1654
1655long
864dbfa3 1656Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1657{
1658 union {
1659 long l;
ffed7fef 1660 char c[sizeof(long)];
a687059c
LW		 1661 } u;
1662
ffed7fef 1663#if BYTEORDER == 0x1234
a687059c
LW		 1664 u.c[0] = (l >> 24) & 255;
1665 u.c[1] = (l >> 16) & 255;
1666 u.c[2] = (l >> 8) & 255;
1667 u.c[3] = l & 255;
1668 return u.l;
1669#else
ffed7fef 1670#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1671 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1672#else
79072805
LW		 1673 register I32 o;
1674 register I32 s;
a687059c
LW		 1675
1676 u.l = l;
1677 l = 0;
ffed7fef
LW		 1678 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1679 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1680 }
1681 return l;
1682#endif
1683#endif
1684}
1685
ffed7fef 1686#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1687#endif /* MYSWAP */
1688
1689/*
1690 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1691 * If these functions are defined,
1692 * the BYTEORDER is neither 0x1234 nor 0x4321.
1693 * However, this is not assumed.
1694 * -DWS
1695 */
1696
1109a392 1697#define HTOLE(name,type) \
988174c1 1698 type \
ba106d47 1699 name (register type n) \
988174c1
LW		 1700 { \
1701 union { \
1702 type value; \
1703 char c[sizeof(type)]; \
1704 } u; \
79072805 1705 register I32 i; \
1109a392
MHM		 1706 register I32 s = 0; \
1707 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW		 1708 u.c[i] = (n >> s) & 0xFF; \
1709 } \
1710 return u.value; \
1711 }
1712
1109a392 1713#define LETOH(name,type) \
988174c1 1714 type \
ba106d47 1715 name (register type n) \
988174c1
LW		 1716 { \
1717 union { \
1718 type value; \
1719 char c[sizeof(type)]; \
1720 } u; \
79072805 1721 register I32 i; \
1109a392 1722 register I32 s = 0; \
988174c1
LW		 1723 u.value = n; \
1724 n = 0; \
1109a392
MHM		 1725 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1726 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW		 1727 } \
1728 return n; \
1729 }
1730
1109a392
MHM		 1731/*
1732 * Big-endian byte order functions.
1733 */
1734
1735#define HTOBE(name,type) \
1736 type \
1737 name (register type n) \
1738 { \
1739 union { \
1740 type value; \
1741 char c[sizeof(type)]; \
1742 } u; \
1743 register I32 i; \
1744 register I32 s = 8*(sizeof(u.c)-1); \
1745 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1746 u.c[i] = (n >> s) & 0xFF; \
1747 } \
1748 return u.value; \
1749 }
1750
1751#define BETOH(name,type) \
1752 type \
1753 name (register type n) \
1754 { \
1755 union { \
1756 type value; \
1757 char c[sizeof(type)]; \
1758 } u; \
1759 register I32 i; \
1760 register I32 s = 8*(sizeof(u.c)-1); \
1761 u.value = n; \
1762 n = 0; \
1763 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1764 n |= ((type)(u.c[i] & 0xFF)) << s; \
1765 } \
1766 return n; \
1767 }
1768
1769/*
1770 * If we just can't do it...
1771 */
1772
1773#define NOT_AVAIL(name,type) \
1774 type \
1775 name (register type n) \
1776 { \
1777 Perl_croak_nocontext(#name "() not available"); \
1778 return n; /* not reached */ \
1779 }
1780
1781
988174c1 1782#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 1783HTOLE(htovs,short)
988174c1
LW		 1784#endif
1785#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 1786HTOLE(htovl,long)
988174c1
LW		 1787#endif
1788#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 1789LETOH(vtohs,short)
988174c1
LW		 1790#endif
1791#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM		 1792LETOH(vtohl,long)
1793#endif
1794
1795#ifdef PERL_NEED_MY_HTOLE16
1796# if U16SIZE == 2
1797HTOLE(Perl_my_htole16,U16)
1798# else
1799NOT_AVAIL(Perl_my_htole16,U16)
1800# endif
1801#endif
1802#ifdef PERL_NEED_MY_LETOH16
1803# if U16SIZE == 2
1804LETOH(Perl_my_letoh16,U16)
1805# else
1806NOT_AVAIL(Perl_my_letoh16,U16)
1807# endif
1808#endif
1809#ifdef PERL_NEED_MY_HTOBE16
1810# if U16SIZE == 2
1811HTOBE(Perl_my_htobe16,U16)
1812# else
1813NOT_AVAIL(Perl_my_htobe16,U16)
1814# endif
1815#endif
1816#ifdef PERL_NEED_MY_BETOH16
1817# if U16SIZE == 2
1818BETOH(Perl_my_betoh16,U16)
1819# else
1820NOT_AVAIL(Perl_my_betoh16,U16)
1821# endif
1822#endif
1823
1824#ifdef PERL_NEED_MY_HTOLE32
1825# if U32SIZE == 4
1826HTOLE(Perl_my_htole32,U32)
1827# else
1828NOT_AVAIL(Perl_my_htole32,U32)
1829# endif
1830#endif
1831#ifdef PERL_NEED_MY_LETOH32
1832# if U32SIZE == 4
1833LETOH(Perl_my_letoh32,U32)
1834# else
1835NOT_AVAIL(Perl_my_letoh32,U32)
1836# endif
1837#endif
1838#ifdef PERL_NEED_MY_HTOBE32
1839# if U32SIZE == 4
1840HTOBE(Perl_my_htobe32,U32)
1841# else
1842NOT_AVAIL(Perl_my_htobe32,U32)
1843# endif
1844#endif
1845#ifdef PERL_NEED_MY_BETOH32
1846# if U32SIZE == 4
1847BETOH(Perl_my_betoh32,U32)
1848# else
1849NOT_AVAIL(Perl_my_betoh32,U32)
1850# endif
1851#endif
1852
1853#ifdef PERL_NEED_MY_HTOLE64
1854# if U64SIZE == 8
1855HTOLE(Perl_my_htole64,U64)
1856# else
1857NOT_AVAIL(Perl_my_htole64,U64)
1858# endif
1859#endif
1860#ifdef PERL_NEED_MY_LETOH64
1861# if U64SIZE == 8
1862LETOH(Perl_my_letoh64,U64)
1863# else
1864NOT_AVAIL(Perl_my_letoh64,U64)
1865# endif
1866#endif
1867#ifdef PERL_NEED_MY_HTOBE64
1868# if U64SIZE == 8
1869HTOBE(Perl_my_htobe64,U64)
1870# else
1871NOT_AVAIL(Perl_my_htobe64,U64)
1872# endif
1873#endif
1874#ifdef PERL_NEED_MY_BETOH64
1875# if U64SIZE == 8
1876BETOH(Perl_my_betoh64,U64)
1877# else
1878NOT_AVAIL(Perl_my_betoh64,U64)
1879# endif
988174c1 1880#endif
a687059c 1881
1109a392
MHM		 1882#ifdef PERL_NEED_MY_HTOLES
1883HTOLE(Perl_my_htoles,short)
1884#endif
1885#ifdef PERL_NEED_MY_LETOHS
1886LETOH(Perl_my_letohs,short)
1887#endif
1888#ifdef PERL_NEED_MY_HTOBES
1889HTOBE(Perl_my_htobes,short)
1890#endif
1891#ifdef PERL_NEED_MY_BETOHS
1892BETOH(Perl_my_betohs,short)
1893#endif
1894
1895#ifdef PERL_NEED_MY_HTOLEI
1896HTOLE(Perl_my_htolei,int)
1897#endif
1898#ifdef PERL_NEED_MY_LETOHI
1899LETOH(Perl_my_letohi,int)
1900#endif
1901#ifdef PERL_NEED_MY_HTOBEI
1902HTOBE(Perl_my_htobei,int)
1903#endif
1904#ifdef PERL_NEED_MY_BETOHI
1905BETOH(Perl_my_betohi,int)
1906#endif
1907
1908#ifdef PERL_NEED_MY_HTOLEL
1909HTOLE(Perl_my_htolel,long)
1910#endif
1911#ifdef PERL_NEED_MY_LETOHL
1912LETOH(Perl_my_letohl,long)
1913#endif
1914#ifdef PERL_NEED_MY_HTOBEL
1915HTOBE(Perl_my_htobel,long)
1916#endif
1917#ifdef PERL_NEED_MY_BETOHL
1918BETOH(Perl_my_betohl,long)
1919#endif
1920
1921void
1922Perl_my_swabn(void *ptr, int n)
1923{
1924 register char *s = (char *)ptr;
1925 register char *e = s + (n-1);
1926 register char tc;
1927
1928 for (n /= 2; n > 0; s++, e--, n--) {
1929 tc = *s;
1930 *s = *e;
1931 *e = tc;
1932 }
1933}
1934
4a7d1889
NIS		 1935PerlIO *
1936Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1937{
2986a63f 1938#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1f852d0d
NIS		 1939 int p[2];
1940 register I32 This, that;
1941 register Pid_t pid;
1942 SV *sv;
1943 I32 did_pipes = 0;
1944 int pp[2];
1945
1946 PERL_FLUSHALL_FOR_CHILD;
1947 This = (*mode == 'w');
1948 that = !This;
1949 if (PL_tainting) {
1950 taint_env();
1951 taint_proper("Insecure %s%s", "EXEC");
1952 }
1953 if (PerlProc_pipe(p) < 0)
1954 return Nullfp;
1955 /* Try for another pipe pair for error return */
1956 if (PerlProc_pipe(pp) >= 0)
1957 did_pipes = 1;
52e18b1f 1958 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 1959 if (errno != EAGAIN) {
1960 PerlLIO_close(p[This]);
4e6dfe71 1961 PerlLIO_close(p[that]);
1f852d0d
NIS		 1962 if (did_pipes) {
1963 PerlLIO_close(pp[0]);
1964 PerlLIO_close(pp[1]);
1965 }
1966 return Nullfp;
1967 }
1968 sleep(5);
1969 }
1970 if (pid == 0) {
1971 /* Child */
1f852d0d
NIS		 1972#undef THIS
1973#undef THAT
1974#define THIS that
1975#define THAT This
1f852d0d
NIS		 1976 /* Close parent's end of error status pipe (if any) */
1977 if (did_pipes) {
1978 PerlLIO_close(pp[0]);
1979#if defined(HAS_FCNTL) && defined(F_SETFD)
1980 /* Close error pipe automatically if exec works */
1981 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1982#endif
1983 }
1984 /* Now dup our end of _the_ pipe to right position */
1985 if (p[THIS] != (*mode == 'r')) {
1986 PerlLIO_dup2(p[THIS], *mode == 'r');
1987 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 1988 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1989 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 1990 }
4e6dfe71
GS		 1991 else
1992 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 1993#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1994 /* No automatic close - do it by hand */
b7953727
JH		 1995# ifndef NOFILE
1996# define NOFILE 20
1997# endif
a080fe3d
NIS		 1998 {
1999 int fd;
2000
2001 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2002 if (fd != pp[1])
a080fe3d
NIS		 2003 PerlLIO_close(fd);
2004 }
1f852d0d
NIS		 2005 }
2006#endif
2007 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2008 PerlProc__exit(1);
2009#undef THIS
2010#undef THAT
2011 }
2012 /* Parent */
52e18b1f 2013 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2014 if (did_pipes)
2015 PerlLIO_close(pp[1]);
2016 /* Keep the lower of the two fd numbers */
2017 if (p[that] < p[This]) {
2018 PerlLIO_dup2(p[This], p[that]);
2019 PerlLIO_close(p[This]);
2020 p[This] = p[that];
2021 }
4e6dfe71
GS		 2022 else
2023 PerlLIO_close(p[that]); /* close child's end of pipe */
2024
1f852d0d
NIS		 2025 LOCK_FDPID_MUTEX;
2026 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2027 UNLOCK_FDPID_MUTEX;
862a34c6 2028 SvUPGRADE(sv,SVt_IV);
45977657 2029 SvIV_set(sv, pid);
1f852d0d
NIS		 2030 PL_forkprocess = pid;
2031 /* If we managed to get status pipe check for exec fail */
2032 if (did_pipes && pid > 0) {
2033 int errkid;
2034 int n = 0, n1;
2035
2036 while (n < sizeof(int)) {
2037 n1 = PerlLIO_read(pp[0],
2038 (void*)(((char*)&errkid)+n),
2039 (sizeof(int)) - n);
2040 if (n1 <= 0)
2041 break;
2042 n += n1;
2043 }
2044 PerlLIO_close(pp[0]);
2045 did_pipes = 0;
2046 if (n) { /* Error */
2047 int pid2, status;
8c51524e 2048 PerlLIO_close(p[This]);
1f852d0d
NIS		 2049 if (n != sizeof(int))
2050 Perl_croak(aTHX_ "panic: kid popen errno read");
2051 do {
2052 pid2 = wait4pid(pid, &status, 0);
2053 } while (pid2 == -1 && errno == EINTR);
2054 errno = errkid; /* Propagate errno from kid */
2055 return Nullfp;
2056 }
2057 }
2058 if (did_pipes)
2059 PerlLIO_close(pp[0]);
2060 return PerlIO_fdopen(p[This], mode);
2061#else
4a7d1889
NIS		 2062 Perl_croak(aTHX_ "List form of piped open not implemented");
2063 return (PerlIO *) NULL;
1f852d0d 2064#endif
4a7d1889
NIS		 2065}
2066
5f05dabc 2067 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2068#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2069PerlIO *
864dbfa3 2070Perl_my_popen(pTHX_ char *cmd, char *mode)
a687059c
LW		 2071{
2072 int p[2];
8ac85365 2073 register I32 This, that;
d8a83dd3 2074 register Pid_t pid;
79072805 2075 SV *sv;
770526c1 2076 I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2077 I32 did_pipes = 0;
2078 int pp[2];
a687059c 2079
45bc9206 2080 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2081#ifdef OS2
2082 if (doexec) {
23da6c43 2083 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2084 }
a1d180c4 2085#endif
8ac85365
NIS		 2086 This = (*mode == 'w');
2087 that = !This;
3280af22 2088 if (doexec && PL_tainting) {
bbce6d69 2089 taint_env();
2090 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2091 }
c2267164
IZ		 2092 if (PerlProc_pipe(p) < 0)
2093 return Nullfp;
e446cec8
IZ		 2094 if (doexec && PerlProc_pipe(pp) >= 0)
2095 did_pipes = 1;
52e18b1f 2096 while ((pid = PerlProc_fork()) < 0) {
a687059c 2097 if (errno != EAGAIN) {
6ad3d225 2098 PerlLIO_close(p[This]);
b5ac89c3 2099 PerlLIO_close(p[that]);
e446cec8
IZ		 2100 if (did_pipes) {
2101 PerlLIO_close(pp[0]);
2102 PerlLIO_close(pp[1]);
2103 }
a687059c 2104 if (!doexec)
cea2e8a9 2105 Perl_croak(aTHX_ "Can't fork");
a687059c
LW		 2106 return Nullfp;
2107 }
2108 sleep(5);
2109 }
2110 if (pid == 0) {
79072805
LW		 2111 GV* tmpgv;
2112
30ac6d9b
GS		 2113#undef THIS
2114#undef THAT
a687059c 2115#define THIS that
8ac85365 2116#define THAT This
e446cec8
IZ		 2117 if (did_pipes) {
2118 PerlLIO_close(pp[0]);
2119#if defined(HAS_FCNTL) && defined(F_SETFD)
2120 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2121#endif
2122 }
a687059c 2123 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2124 PerlLIO_dup2(p[THIS], *mode == 'r');
2125 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2126 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2127 PerlLIO_close(p[THAT]);
a687059c 2128 }
b5ac89c3
NIS		 2129 else
2130 PerlLIO_close(p[THAT]);
4435c477 2131#ifndef OS2
a687059c 2132 if (doexec) {
a0d0e21e 2133#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2134#ifndef NOFILE
2135#define NOFILE 20
2136#endif
a080fe3d 2137 {
3aed30dc 2138 int fd;
a080fe3d
NIS		 2139
2140 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2141 if (fd != pp[1])
3aed30dc 2142 PerlLIO_close(fd);
a080fe3d 2143 }
ae986130 2144#endif
a080fe3d
NIS		 2145 /* may or may not use the shell */
2146 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2147 PerlProc__exit(1);
a687059c 2148 }
4435c477 2149#endif /* defined OS2 */
306196c3 2150 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4d76a344 2151 SvREADONLY_off(GvSV(tmpgv));
7766f137 2152 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2153 SvREADONLY_on(GvSV(tmpgv));
2154 }
2155#ifdef THREADS_HAVE_PIDS
2156 PL_ppid = (IV)getppid();
2157#endif
3280af22
NIS		 2158 PL_forkprocess = 0;
2159 hv_clear(PL_pidstatus); /* we have no children */
a687059c
LW		 2160 return Nullfp;
2161#undef THIS
2162#undef THAT
2163 }
b5ac89c3 2164 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2165 if (did_pipes)
2166 PerlLIO_close(pp[1]);
8ac85365 2167 if (p[that] < p[This]) {
6ad3d225
GS		 2168 PerlLIO_dup2(p[This], p[that]);
2169 PerlLIO_close(p[This]);
8ac85365 2170 p[This] = p[that];
62b28dd9 2171 }
b5ac89c3
NIS		 2172 else
2173 PerlLIO_close(p[that]);
2174
4755096e 2175 LOCK_FDPID_MUTEX;
3280af22 2176 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2177 UNLOCK_FDPID_MUTEX;
862a34c6 2178 SvUPGRADE(sv,SVt_IV);
45977657 2179 SvIV_set(sv, pid);
3280af22 2180 PL_forkprocess = pid;
e446cec8
IZ		 2181 if (did_pipes && pid > 0) {
2182 int errkid;
2183 int n = 0, n1;
2184
2185 while (n < sizeof(int)) {
2186 n1 = PerlLIO_read(pp[0],
2187 (void*)(((char*)&errkid)+n),
2188 (sizeof(int)) - n);
2189 if (n1 <= 0)
2190 break;
2191 n += n1;
2192 }
2f96c702
IZ		 2193 PerlLIO_close(pp[0]);
2194 did_pipes = 0;
e446cec8 2195 if (n) { /* Error */
faa466a7 2196 int pid2, status;
8c51524e 2197 PerlLIO_close(p[This]);
e446cec8 2198 if (n != sizeof(int))
cea2e8a9 2199 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2200 do {
2201 pid2 = wait4pid(pid, &status, 0);
2202 } while (pid2 == -1 && errno == EINTR);
e446cec8
IZ		 2203 errno = errkid; /* Propagate errno from kid */
2204 return Nullfp;
2205 }
2206 }
2207 if (did_pipes)
2208 PerlLIO_close(pp[0]);
8ac85365 2209 return PerlIO_fdopen(p[This], mode);
a687059c 2210}
7c0587c8 2211#else
85ca448a 2212#if defined(atarist) || defined(EPOC)
7c0587c8 2213FILE *popen();
760ac839 2214PerlIO *
864dbfa3 2215Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2216{
45bc9206 2217 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2218 /* Call system's popen() to get a FILE *, then import it.
2219 used 0 for 2nd parameter to PerlIO_importFILE;
2220 apparently not used
2221 */
2222 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2223}
2b96b0a5
JH		 2224#else
2225#if defined(DJGPP)
2226FILE *djgpp_popen();
2227PerlIO *
2228Perl_my_popen(pTHX_ char *cmd, char *mode)
2229{
2230 PERL_FLUSHALL_FOR_CHILD;
2231 /* Call system's popen() to get a FILE *, then import it.
2232 used 0 for 2nd parameter to PerlIO_importFILE;
2233 apparently not used
2234 */
2235 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2236}
2237#endif
7c0587c8
LW		 2238#endif
2239
2240#endif /* !DOSISH */
a687059c 2241
52e18b1f
GS		 2242/* this is called in parent before the fork() */
2243void
2244Perl_atfork_lock(void)
2245{
27da23d5 2246 dVAR;
3db8f154 2247#if defined(USE_ITHREADS)
52e18b1f
GS		 2248 /* locks must be held in locking order (if any) */
2249# ifdef MYMALLOC
2250 MUTEX_LOCK(&PL_malloc_mutex);
2251# endif
2252 OP_REFCNT_LOCK;
2253#endif
2254}
2255
2256/* this is called in both parent and child after the fork() */
2257void
2258Perl_atfork_unlock(void)
2259{
27da23d5 2260 dVAR;
3db8f154 2261#if defined(USE_ITHREADS)
52e18b1f
GS		 2262 /* locks must be released in same order as in atfork_lock() */
2263# ifdef MYMALLOC
2264 MUTEX_UNLOCK(&PL_malloc_mutex);
2265# endif
2266 OP_REFCNT_UNLOCK;
2267#endif
2268}
2269
2270Pid_t
2271Perl_my_fork(void)
2272{
2273#if defined(HAS_FORK)
2274 Pid_t pid;
3db8f154 2275#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2276 atfork_lock();
2277 pid = fork();
2278 atfork_unlock();
2279#else
2280 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2281 * handlers elsewhere in the code */
2282 pid = fork();
2283#endif
2284 return pid;
2285#else
2286 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2287 Perl_croak_nocontext("fork() not available");
b961a566 2288 return 0;
52e18b1f
GS		 2289#endif /* HAS_FORK */
2290}
2291
748a9306 2292#ifdef DUMP_FDS
35ff7856 2293void
864dbfa3 2294Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2295{
2296 int fd;
c623ac67 2297 Stat_t tmpstatbuf;
ae986130 2298
bf49b057 2299 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2300 for (fd = 0; fd < 32; fd++) {
6ad3d225 2301 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2302 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2303 }
bf49b057 2304 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2305 return;
ae986130 2306}
35ff7856 2307#endif /* DUMP_FDS */
ae986130 2308
fe14fcc3 2309#ifndef HAS_DUP2
fec02dd3 2310int
ba106d47 2311dup2(int oldfd, int newfd)
a687059c 2312{
a0d0e21e 2313#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2314 if (oldfd == newfd)
2315 return oldfd;
6ad3d225 2316 PerlLIO_close(newfd);
fec02dd3 2317 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2318#else
fc36a67e 2319#define DUP2_MAX_FDS 256
2320 int fdtmp[DUP2_MAX_FDS];
79072805 2321 I32 fdx = 0;
ae986130
LW		 2322 int fd;
2323
fe14fcc3 2324 if (oldfd == newfd)
fec02dd3 2325 return oldfd;
6ad3d225 2326 PerlLIO_close(newfd);
fc36a67e 2327 /* good enough for low fd's... */
6ad3d225 2328 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2329 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2330 PerlLIO_close(fd);
fc36a67e 2331 fd = -1;
2332 break;
2333 }
ae986130 2334 fdtmp[fdx++] = fd;
fc36a67e 2335 }
ae986130 2336 while (fdx > 0)
6ad3d225 2337 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2338 return fd;
62b28dd9 2339#endif
a687059c
LW		 2340}
2341#endif
2342
64ca3a65 2343#ifndef PERL_MICRO
ff68c719 2344#ifdef HAS_SIGACTION
2345
abea2c45
HS		 2346#ifdef MACOS_TRADITIONAL
2347/* We don't want restart behavior on MacOS */
2348#undef SA_RESTART
2349#endif
2350
ff68c719 2351Sighandler_t
864dbfa3 2352Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2353{
27da23d5 2354 dVAR;
ff68c719 2355 struct sigaction act, oact;
2356
a10b1e10
JH		 2357#ifdef USE_ITHREADS
2358 /* only "parent" interpreter can diddle signals */
2359 if (PL_curinterp != aTHX)
2360 return SIG_ERR;
2361#endif
2362
ff68c719 2363 act.sa_handler = handler;
2364 sigemptyset(&act.sa_mask);
2365 act.sa_flags = 0;
2366#ifdef SA_RESTART
4ffa73a3
JH		 2367 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2368 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2369#endif
358837b8 2370#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
85264bed
CS		 2371 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2372 act.sa_flags |= SA_NOCLDWAIT;
2373#endif
ff68c719 2374 if (sigaction(signo, &act, &oact) == -1)
36477c24 2375 return SIG_ERR;
ff68c719 2376 else
36477c24 2377 return oact.sa_handler;
ff68c719 2378}
2379
2380Sighandler_t
864dbfa3 2381Perl_rsignal_state(pTHX_ int signo)
ff68c719 2382{
2383 struct sigaction oact;
2384
2385 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3aed30dc 2386 return SIG_ERR;
ff68c719 2387 else
3aed30dc 2388 return oact.sa_handler;
ff68c719 2389}
2390
2391int
864dbfa3 2392Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2393{
27da23d5 2394 dVAR;
ff68c719 2395 struct sigaction act;
2396
a10b1e10
JH		 2397#ifdef USE_ITHREADS
2398 /* only "parent" interpreter can diddle signals */
2399 if (PL_curinterp != aTHX)
2400 return -1;
2401#endif
2402
ff68c719 2403 act.sa_handler = handler;
2404 sigemptyset(&act.sa_mask);
2405 act.sa_flags = 0;
2406#ifdef SA_RESTART
4ffa73a3
JH		 2407 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2408 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2409#endif
36b5d377 2410#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
85264bed
CS		 2411 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2412 act.sa_flags |= SA_NOCLDWAIT;
2413#endif
ff68c719 2414 return sigaction(signo, &act, save);
2415}
2416
2417int
864dbfa3 2418Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2419{
27da23d5 2420 dVAR;
a10b1e10
JH		 2421#ifdef USE_ITHREADS
2422 /* only "parent" interpreter can diddle signals */
2423 if (PL_curinterp != aTHX)
2424 return -1;
2425#endif
2426
ff68c719 2427 return sigaction(signo, save, (struct sigaction *)NULL);
2428}
2429
2430#else /* !HAS_SIGACTION */
2431
2432Sighandler_t
864dbfa3 2433Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2434{
39f1703b 2435#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2436 /* only "parent" interpreter can diddle signals */
2437 if (PL_curinterp != aTHX)
2438 return SIG_ERR;
2439#endif
2440
6ad3d225 2441 return PerlProc_signal(signo, handler);
ff68c719 2442}
2443
ff68c719 2444static
2445Signal_t
4e35701f 2446sig_trap(int signo)
ff68c719 2447{
27da23d5
JH		 2448 dVAR;
2449 PL_sig_trapped++;
ff68c719 2450}
2451
2452Sighandler_t
864dbfa3 2453Perl_rsignal_state(pTHX_ int signo)
ff68c719 2454{
27da23d5 2455 dVAR;
ff68c719 2456 Sighandler_t oldsig;
2457
39f1703b 2458#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2459 /* only "parent" interpreter can diddle signals */
2460 if (PL_curinterp != aTHX)
2461 return SIG_ERR;
2462#endif
2463
27da23d5 2464 PL_sig_trapped = 0;
6ad3d225
GS		 2465 oldsig = PerlProc_signal(signo, sig_trap);
2466 PerlProc_signal(signo, oldsig);
27da23d5 2467 if (PL_sig_trapped)
3aed30dc 2468 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2469 return oldsig;
2470}
2471
2472int
864dbfa3 2473Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2474{
39f1703b 2475#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2476 /* only "parent" interpreter can diddle signals */
2477 if (PL_curinterp != aTHX)
2478 return -1;
2479#endif
6ad3d225 2480 *save = PerlProc_signal(signo, handler);
ff68c719 2481 return (*save == SIG_ERR) ? -1 : 0;
2482}
2483
2484int
864dbfa3 2485Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2486{
39f1703b 2487#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2488 /* only "parent" interpreter can diddle signals */
2489 if (PL_curinterp != aTHX)
2490 return -1;
2491#endif
6ad3d225 2492 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2493}
2494
2495#endif /* !HAS_SIGACTION */
64ca3a65 2496#endif /* !PERL_MICRO */
ff68c719 2497
5f05dabc 2498 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2499#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2500I32
864dbfa3 2501Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2502{
ff68c719 2503 Sigsave_t hstat, istat, qstat;
a687059c 2504 int status;
a0d0e21e 2505 SV **svp;
d8a83dd3
JH		 2506 Pid_t pid;
2507 Pid_t pid2;
03136e13 2508 bool close_failed;
b7953727 2509 int saved_errno = 0;
22fae026
TM		 2510#ifdef WIN32
2511 int saved_win32_errno;
2512#endif
a687059c 2513
4755096e 2514 LOCK_FDPID_MUTEX;
3280af22 2515 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2516 UNLOCK_FDPID_MUTEX;
25d92023 2517 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2518 SvREFCNT_dec(*svp);
3280af22 2519 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2520#ifdef OS2
2521 if (pid == -1) { /* Opened by popen. */
2522 return my_syspclose(ptr);
2523 }
a1d180c4 2524#endif
03136e13
CS		 2525 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2526 saved_errno = errno;
22fae026
TM		 2527#ifdef WIN32
2528 saved_win32_errno = GetLastError();
2529#endif
03136e13 2530 }
7c0587c8 2531#ifdef UTS
6ad3d225 2532 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2533#endif
64ca3a65 2534#ifndef PERL_MICRO
ff68c719 2535 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2536 rsignal_save(SIGINT, SIG_IGN, &istat);
2537 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2538#endif
748a9306 2539 do {
1d3434b8
GS		 2540 pid2 = wait4pid(pid, &status, 0);
2541 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2542#ifndef PERL_MICRO
ff68c719 2543 rsignal_restore(SIGHUP, &hstat);
2544 rsignal_restore(SIGINT, &istat);
2545 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2546#endif
03136e13 2547 if (close_failed) {
ce6e1103 2548 SETERRNO(saved_errno, 0);
03136e13
CS		 2549 return -1;
2550 }
1d3434b8 2551 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2552}
4633a7c4
LW		 2553#endif /* !DOSISH */
2554
2986a63f 2555#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2556I32
d8a83dd3 2557Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2558{
27da23d5 2559 I32 result = 0;
b7953727
JH		 2560 if (!pid)
2561 return -1;
2562#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2563 {
cf28e18a 2564 char spid[TYPE_CHARS(IV)];
20188a90 2565
3aed30dc 2566 if (pid > 0) {
27da23d5 2567 SV** svp;
7b0972df 2568 sprintf(spid, "%"IVdf, (IV)pid);
3aed30dc
HS		 2569 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2570 if (svp && *svp != &PL_sv_undef) {
2571 *statusp = SvIVX(*svp);
2572 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2573 return pid;
2574 }
2575 }
2576 else {
2577 HE *entry;
2578
2579 hv_iterinit(PL_pidstatus);
2580 if ((entry = hv_iternext(PL_pidstatus))) {
27da23d5
JH		 2581 SV *sv = hv_iterval(PL_pidstatus,entry);
2582
3aed30dc 2583 pid = atoi(hv_iterkey(entry,(I32*)statusp));
3aed30dc
HS		 2584 *statusp = SvIVX(sv);
2585 sprintf(spid, "%"IVdf, (IV)pid);
2586 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2587 return pid;
2588 }
20188a90
LW		 2589 }
2590 }
68a29c53 2591#endif
79072805 2592#ifdef HAS_WAITPID
367f3c24
IZ		 2593# ifdef HAS_WAITPID_RUNTIME
2594 if (!HAS_WAITPID_RUNTIME)
2595 goto hard_way;
2596# endif
cddd4526 2597 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2598 goto finish;
367f3c24
IZ		 2599#endif
2600#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
cddd4526 2601 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
dfcfdb64 2602 goto finish;
367f3c24
IZ		 2603#endif
2604#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
27da23d5 2605#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2606 hard_way:
27da23d5 2607#endif
a0d0e21e 2608 {
a0d0e21e 2609 if (flags)
cea2e8a9 2610 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2611 else {
76e3520e 2612 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2613 pidgone(result,*statusp);
2614 if (result < 0)
2615 *statusp = -1;
2616 }
a687059c
LW		 2617 }
2618#endif
27da23d5 2619#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2620 finish:
27da23d5 2621#endif
cddd4526
NIS		 2622 if (result < 0 && errno == EINTR) {
2623 PERL_ASYNC_CHECK();
2624 }
2625 return result;
a687059c 2626}
2986a63f 2627#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2628
7c0587c8 2629void
d8a83dd3 2630Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2631{
79072805 2632 register SV *sv;
cf28e18a 2633 char spid[TYPE_CHARS(IV)];
a687059c 2634
7b0972df 2635 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2636 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
862a34c6 2637 SvUPGRADE(sv,SVt_IV);
45977657 2638 SvIV_set(sv, status);
20188a90 2639 return;
a687059c
LW		 2640}
2641
85ca448a 2642#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2643int pclose();
ddcf38b7
IZ		 2644#ifdef HAS_FORK
2645int /* Cannot prototype with I32
2646 in os2ish.h. */
ba106d47 2647my_syspclose(PerlIO *ptr)
ddcf38b7 2648#else
79072805 2649I32
864dbfa3 2650Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2651#endif
a687059c 2652{
760ac839
LW		 2653 /* Needs work for PerlIO ! */
2654 FILE *f = PerlIO_findFILE(ptr);
2655 I32 result = pclose(f);
2b96b0a5
JH		 2656 PerlIO_releaseFILE(ptr,f);
2657 return result;
2658}
2659#endif
2660
933fea7f 2661#if defined(DJGPP)
2b96b0a5
JH		 2662int djgpp_pclose();
2663I32
2664Perl_my_pclose(pTHX_ PerlIO *ptr)
2665{
2666 /* Needs work for PerlIO ! */
2667 FILE *f = PerlIO_findFILE(ptr);
2668 I32 result = djgpp_pclose(f);
933fea7f 2669 result = (result << 8) & 0xff00;
760ac839
LW		 2670 PerlIO_releaseFILE(ptr,f);
2671 return result;
a687059c 2672}
7c0587c8 2673#endif
9f68db38
LW		 2674
2675void
864dbfa3 2676Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2677{
79072805 2678 register I32 todo;
08105a92 2679 register const char *frombase = from;
9f68db38
LW		 2680
2681 if (len == 1) {
08105a92 2682 register const char c = *from;
9f68db38 2683 while (count-- > 0)
5926133d 2684 *to++ = c;
9f68db38
LW		 2685 return;
2686 }
2687 while (count-- > 0) {
2688 for (todo = len; todo > 0; todo--) {
2689 *to++ = *from++;
2690 }
2691 from = frombase;
2692 }
2693}
0f85fab0 2694
fe14fcc3 2695#ifndef HAS_RENAME
79072805 2696I32
4373e329 2697Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 2698{
93a17b20
LW		 2699 char *fa = strrchr(a,'/');
2700 char *fb = strrchr(b,'/');
c623ac67
GS		 2701 Stat_t tmpstatbuf1;
2702 Stat_t tmpstatbuf2;
46fc3d4c 2703 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2704
2705 if (fa)
2706 fa++;
2707 else
2708 fa = a;
2709 if (fb)
2710 fb++;
2711 else
2712 fb = b;
2713 if (strNE(a,b))
2714 return FALSE;
2715 if (fa == a)
616d8c9c 2716 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2717 else
46fc3d4c 2718 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 2719 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2720 return FALSE;
2721 if (fb == b)
616d8c9c 2722 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2723 else
46fc3d4c 2724 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 2725 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2726 return FALSE;
2727 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2728 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2729}
fe14fcc3
LW		 2730#endif /* !HAS_RENAME */
2731
491527d0 2732char*
e1ec3a88 2733Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
491527d0 2734{
e1ec3a88 2735 const char *xfound = Nullch;
491527d0 2736 char *xfailed = Nullch;
0f31cffe 2737 char tmpbuf[MAXPATHLEN];
491527d0 2738 register char *s;
5f74f29c 2739 I32 len = 0;
491527d0
GS		 2740 int retval;
2741#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2742# define SEARCH_EXTS ".bat", ".cmd", NULL
2743# define MAX_EXT_LEN 4
2744#endif
2745#ifdef OS2
2746# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2747# define MAX_EXT_LEN 4
2748#endif
2749#ifdef VMS
2750# define SEARCH_EXTS ".pl", ".com", NULL
2751# define MAX_EXT_LEN 4
2752#endif
2753 /* additional extensions to try in each dir if scriptname not found */
2754#ifdef SEARCH_EXTS
e1ec3a88
AL		 2755 const char *exts[] = { SEARCH_EXTS };
2756 const char **ext = search_ext ? search_ext : exts;
491527d0 2757 int extidx = 0, i = 0;
e1ec3a88 2758 const char *curext = Nullch;
491527d0 2759#else
53c1dcc0 2760 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 2761# define MAX_EXT_LEN 0
2762#endif
2763
2764 /*
2765 * If dosearch is true and if scriptname does not contain path
2766 * delimiters, search the PATH for scriptname.
2767 *
2768 * If SEARCH_EXTS is also defined, will look for each
2769 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2770 * while searching the PATH.
2771 *
2772 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2773 * proceeds as follows:
2774 * If DOSISH or VMSISH:
2775 * + look for ./scriptname{,.foo,.bar}
2776 * + search the PATH for scriptname{,.foo,.bar}
2777 *
2778 * If !DOSISH:
2779 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2780 * this will not look in '.' if it's not in the PATH)
2781 */
84486fc6 2782 tmpbuf[0] = '\0';
491527d0
GS		 2783
2784#ifdef VMS
2785# ifdef ALWAYS_DEFTYPES
2786 len = strlen(scriptname);
2787 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2788 int hasdir, idx = 0, deftypes = 1;
2789 bool seen_dot = 1;
2790
2791 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2792# else
2793 if (dosearch) {
2794 int hasdir, idx = 0, deftypes = 1;
2795 bool seen_dot = 1;
2796
2797 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2798# endif
2799 /* The first time through, just add SEARCH_EXTS to whatever we
2800 * already have, so we can check for default file types. */
2801 while (deftypes ||
84486fc6 2802 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 2803 {
2804 if (deftypes) {
2805 deftypes = 0;
84486fc6 2806 *tmpbuf = '\0';
491527d0 2807 }
84486fc6
GS		 2808 if ((strlen(tmpbuf) + strlen(scriptname)
2809 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 2810 continue; /* don't search dir with too-long name */
84486fc6 2811 strcat(tmpbuf, scriptname);
491527d0
GS		 2812#else /* !VMS */
2813
2814#ifdef DOSISH
2815 if (strEQ(scriptname, "-"))
2816 dosearch = 0;
2817 if (dosearch) { /* Look in '.' first. */
fe2774ed 2818 const char *cur = scriptname;
491527d0
GS		 2819#ifdef SEARCH_EXTS
2820 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2821 while (ext[i])
2822 if (strEQ(ext[i++],curext)) {
2823 extidx = -1; /* already has an ext */
2824 break;
2825 }
2826 do {
2827#endif
2828 DEBUG_p(PerlIO_printf(Perl_debug_log,
2829 "Looking for %s\n",cur));
017f25f1
IZ		 2830 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2831 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 2832 dosearch = 0;
2833 scriptname = cur;
2834#ifdef SEARCH_EXTS
2835 break;
2836#endif
2837 }
2838#ifdef SEARCH_EXTS
2839 if (cur == scriptname) {
2840 len = strlen(scriptname);
84486fc6 2841 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 2842 break;
84486fc6 2843 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 2844 }
2845 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 2846 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 2847#endif
2848 }
2849#endif
2850
cd39f2b6
JH		 2851#ifdef MACOS_TRADITIONAL
2852 if (dosearch && !strchr(scriptname, ':') &&
2853 (s = PerlEnv_getenv("Commands")))
2854#else
491527d0
GS		 2855 if (dosearch && !strchr(scriptname, '/')
2856#ifdef DOSISH
2857 && !strchr(scriptname, '\\')
2858#endif
cd39f2b6
JH		 2859 && (s = PerlEnv_getenv("PATH")))
2860#endif
2861 {
491527d0 2862 bool seen_dot = 0;
92f0c265 2863
3280af22
NIS		 2864 PL_bufend = s + strlen(s);
2865 while (s < PL_bufend) {
cd39f2b6
JH		 2866#ifdef MACOS_TRADITIONAL
2867 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2868 ',',
2869 &len);
2870#else
491527d0
GS		 2871#if defined(atarist) || defined(DOSISH)
2872 for (len = 0; *s
2873# ifdef atarist
2874 && *s != ','
2875# endif
2876 && *s != ';'; len++, s++) {
84486fc6
GS		 2877 if (len < sizeof tmpbuf)
2878 tmpbuf[len] = *s;
491527d0 2879 }
84486fc6
GS		 2880 if (len < sizeof tmpbuf)
2881 tmpbuf[len] = '\0';
491527d0 2882#else /* ! (atarist || DOSISH) */
3280af22 2883 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 2884 ':',
2885 &len);
2886#endif /* ! (atarist || DOSISH) */
cd39f2b6 2887#endif /* MACOS_TRADITIONAL */
3280af22 2888 if (s < PL_bufend)
491527d0 2889 s++;
84486fc6 2890 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 2891 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 2892#ifdef MACOS_TRADITIONAL
2893 if (len && tmpbuf[len - 1] != ':')
2894 tmpbuf[len++] = ':';
2895#else
491527d0 2896 if (len
61ae2fbf 2897#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 2898 && tmpbuf[len - 1] != '/'
2899 && tmpbuf[len - 1] != '\\'
491527d0
GS		 2900#endif
2901 )
84486fc6
GS		 2902 tmpbuf[len++] = '/';
2903 if (len == 2 && tmpbuf[0] == '.')
491527d0 2904 seen_dot = 1;
cd39f2b6 2905#endif
84486fc6 2906 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 2907#endif /* !VMS */
2908
2909#ifdef SEARCH_EXTS
84486fc6 2910 len = strlen(tmpbuf);
491527d0
GS		 2911 if (extidx > 0) /* reset after previous loop */
2912 extidx = 0;
2913 do {
2914#endif
84486fc6 2915 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 2916 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 2917 if (S_ISDIR(PL_statbuf.st_mode)) {
2918 retval = -1;
2919 }
491527d0
GS		 2920#ifdef SEARCH_EXTS
2921 } while ( retval < 0 /* not there */
2922 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 2923 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 2924 );
2925#endif
2926 if (retval < 0)
2927 continue;
3280af22
NIS		 2928 if (S_ISREG(PL_statbuf.st_mode)
2929 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 2930#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 2931 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 2932#endif
2933 )
2934 {
3aed30dc 2935 xfound = tmpbuf; /* bingo! */
491527d0
GS		 2936 break;
2937 }
2938 if (!xfailed)
84486fc6 2939 xfailed = savepv(tmpbuf);
491527d0
GS		 2940 }
2941#ifndef DOSISH
017f25f1 2942 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 2943 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 2944 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 2945#endif
2946 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 2947 if (!xfound) {
2948 if (flags & 1) { /* do or die? */
3aed30dc 2949 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 2950 (xfailed ? "execute" : "find"),
2951 (xfailed ? xfailed : scriptname),
2952 (xfailed ? "" : " on PATH"),
2953 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2954 }
2955 scriptname = Nullch;
2956 }
491527d0
GS		 2957 if (xfailed)
2958 Safefree(xfailed);
2959 scriptname = xfound;
2960 }
9ccb31f9 2961 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 2962}
2963
ba869deb
GS		 2964#ifndef PERL_GET_CONTEXT_DEFINED
2965
2966void *
2967Perl_get_context(void)
2968{
27da23d5 2969 dVAR;
3db8f154 2970#if defined(USE_ITHREADS)
ba869deb
GS		 2971# ifdef OLD_PTHREADS_API
2972 pthread_addr_t t;
2973 if (pthread_getspecific(PL_thr_key, &t))
2974 Perl_croak_nocontext("panic: pthread_getspecific");
2975 return (void*)t;
2976# else
bce813aa 2977# ifdef I_MACH_CTHREADS
8b8b35ab 2978 return (void*)cthread_data(cthread_self());
bce813aa 2979# else
8b8b35ab
JH		 2980 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2981# endif
c44d3fdb 2982# endif
ba869deb
GS		 2983#else
2984 return (void*)NULL;
2985#endif
2986}
2987
2988void
2989Perl_set_context(void *t)
2990{
8772537c 2991 dVAR;
3db8f154 2992#if defined(USE_ITHREADS)
c44d3fdb
GS		 2993# ifdef I_MACH_CTHREADS
2994 cthread_set_data(cthread_self(), t);
2995# else
ba869deb
GS		 2996 if (pthread_setspecific(PL_thr_key, t))
2997 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 2998# endif
b464bac0 2999#else
8772537c 3000 PERL_UNUSED_ARG(t);
ba869deb
GS		 3001#endif
3002}
3003
3004#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3005
27da23d5 3006#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3007struct perl_vars *
864dbfa3 3008Perl_GetVars(pTHX)
22239a37 3009{
533c011a 3010 return &PL_Vars;
22239a37 3011}
31fb1209
NIS		 3012#endif
3013
1cb0ed9b 3014char **
864dbfa3 3015Perl_get_op_names(pTHX)
31fb1209 3016{
27da23d5 3017 return (char **)PL_op_name;
31fb1209
NIS		 3018}
3019
1cb0ed9b 3020char **
864dbfa3 3021Perl_get_op_descs(pTHX)
31fb1209 3022{
27da23d5 3023 return (char **)PL_op_desc;
31fb1209 3024}
9e6b2b00 3025
e1ec3a88 3026const char *
864dbfa3 3027Perl_get_no_modify(pTHX)
9e6b2b00 3028{
e1ec3a88 3029 return PL_no_modify;
9e6b2b00
GS		 3030}
3031
3032U32 *
864dbfa3 3033Perl_get_opargs(pTHX)
9e6b2b00 3034{
27da23d5 3035 return (U32 *)PL_opargs;
9e6b2b00 3036}
51aa15f3 3037
0cb96387
GS		 3038PPADDR_t*
3039Perl_get_ppaddr(pTHX)
3040{
27da23d5 3041 dVAR;
12ae5dfc 3042 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3043}
3044
a6c40364
GS		 3045#ifndef HAS_GETENV_LEN
3046char *
bf4acbe4 3047Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3048{
8772537c 3049 char * const env_trans = PerlEnv_getenv(env_elem);
a6c40364
GS		 3050 if (env_trans)
3051 *len = strlen(env_trans);
3052 return env_trans;
f675dbe5
CB		 3053}
3054#endif
3055
dc9e4912
GS		 3056
3057MGVTBL*
864dbfa3 3058Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3059{
27da23d5 3060 const MGVTBL* result = Null(MGVTBL*);
dc9e4912
GS		 3061
3062 switch(vtbl_id) {
3063 case want_vtbl_sv:
3064 result = &PL_vtbl_sv;
3065 break;
3066 case want_vtbl_env:
3067 result = &PL_vtbl_env;
3068 break;
3069 case want_vtbl_envelem:
3070 result = &PL_vtbl_envelem;
3071 break;
3072 case want_vtbl_sig:
3073 result = &PL_vtbl_sig;
3074 break;
3075 case want_vtbl_sigelem:
3076 result = &PL_vtbl_sigelem;
3077 break;
3078 case want_vtbl_pack:
3079 result = &PL_vtbl_pack;
3080 break;
3081 case want_vtbl_packelem:
3082 result = &PL_vtbl_packelem;
3083 break;
3084 case want_vtbl_dbline:
3085 result = &PL_vtbl_dbline;
3086 break;
3087 case want_vtbl_isa:
3088 result = &PL_vtbl_isa;
3089 break;
3090 case want_vtbl_isaelem:
3091 result = &PL_vtbl_isaelem;
3092 break;
3093 case want_vtbl_arylen:
3094 result = &PL_vtbl_arylen;
3095 break;
3096 case want_vtbl_glob:
3097 result = &PL_vtbl_glob;
3098 break;
3099 case want_vtbl_mglob:
3100 result = &PL_vtbl_mglob;
3101 break;
3102 case want_vtbl_nkeys:
3103 result = &PL_vtbl_nkeys;
3104 break;
3105 case want_vtbl_taint:
3106 result = &PL_vtbl_taint;
3107 break;
3108 case want_vtbl_substr:
3109 result = &PL_vtbl_substr;
3110 break;
3111 case want_vtbl_vec:
3112 result = &PL_vtbl_vec;
3113 break;
3114 case want_vtbl_pos:
3115 result = &PL_vtbl_pos;
3116 break;
3117 case want_vtbl_bm:
3118 result = &PL_vtbl_bm;
3119 break;
3120 case want_vtbl_fm:
3121 result = &PL_vtbl_fm;
3122 break;
3123 case want_vtbl_uvar:
3124 result = &PL_vtbl_uvar;
3125 break;
dc9e4912
GS		 3126 case want_vtbl_defelem:
3127 result = &PL_vtbl_defelem;
3128 break;
3129 case want_vtbl_regexp:
3130 result = &PL_vtbl_regexp;
3131 break;
3132 case want_vtbl_regdata:
3133 result = &PL_vtbl_regdata;
3134 break;
3135 case want_vtbl_regdatum:
3136 result = &PL_vtbl_regdatum;
3137 break;
3c90161d 3138#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3139 case want_vtbl_collxfrm:
3140 result = &PL_vtbl_collxfrm;
3141 break;
3c90161d 3142#endif
dc9e4912
GS		 3143 case want_vtbl_amagic:
3144 result = &PL_vtbl_amagic;
3145 break;
3146 case want_vtbl_amagicelem:
3147 result = &PL_vtbl_amagicelem;
3148 break;
810b8aa5
GS		 3149 case want_vtbl_backref:
3150 result = &PL_vtbl_backref;
3151 break;
7e8c5dac
HS		 3152 case want_vtbl_utf8:
3153 result = &PL_vtbl_utf8;
3154 break;
dc9e4912 3155 }
27da23d5 3156 return (MGVTBL*)result;
dc9e4912
GS		 3157}
3158
767df6a1 3159I32
864dbfa3 3160Perl_my_fflush_all(pTHX)
767df6a1 3161{
f800e14d 3162#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3163 return PerlIO_flush(NULL);
767df6a1 3164#else
8fbdfb7c 3165# if defined(HAS__FWALK)
f13a2bc0 3166 extern int fflush(FILE *);
74cac757
JH		 3167 /* undocumented, unprototyped, but very useful BSDism */
3168 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3169 _fwalk(&fflush);
74cac757 3170 return 0;
8fa7f367 3171# else
8fbdfb7c 3172# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3173 long open_max = -1;
8fbdfb7c 3174# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3175 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3176# else
8fa7f367 3177# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3178 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3179# else
3180# ifdef FOPEN_MAX
74cac757 3181 open_max = FOPEN_MAX;
8fa7f367
JH		 3182# else
3183# ifdef OPEN_MAX
74cac757 3184 open_max = OPEN_MAX;
8fa7f367
JH		 3185# else
3186# ifdef _NFILE
d2201af2 3187 open_max = _NFILE;
8fa7f367
JH		 3188# endif
3189# endif
74cac757 3190# endif
767df6a1
JH		 3191# endif
3192# endif
767df6a1
JH		 3193 if (open_max > 0) {
3194 long i;
3195 for (i = 0; i < open_max; i++)
d2201af2
AD		 3196 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3197 STDIO_STREAM_ARRAY[i]._file < open_max &&
3198 STDIO_STREAM_ARRAY[i]._flag)
3199 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3200 return 0;
3201 }
8fbdfb7c 3202# endif
93189314 3203 SETERRNO(EBADF,RMS_IFI);
767df6a1 3204 return EOF;
74cac757 3205# endif
767df6a1
JH		 3206#endif
3207}
097ee67d 3208
69282e91 3209void
e1ec3a88 3210Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
bc37a18f 3211{
e1ec3a88 3212 const char *func =
66fc2fa5
JH		 3213 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3214 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
bc37a18f 3215 PL_op_desc[op];
e1ec3a88
AL		 3216 const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3217 const char *type = OP_IS_SOCKET(op)
3aed30dc
HS		 3218 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3219 ? "socket" : "filehandle";
e1ec3a88 3220 const char *name = NULL;
bc37a18f 3221
66fc2fa5 3222 if (gv && isGV(gv)) {
f62cb720 3223 name = GvENAME(gv);
66fc2fa5
JH		 3224 }
3225
4c80c0b2 3226 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3227 if (ckWARN(WARN_IO)) {
fd322ea4 3228 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3aed30dc
HS		 3229 if (name && *name)
3230 Perl_warner(aTHX_ packWARN(WARN_IO),
3231 "Filehandle %s opened only for %sput",
fd322ea4 3232 name, direction);
3aed30dc
HS		 3233 else
3234 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3235 "Filehandle opened only for %sput", direction);
3aed30dc 3236 }
2dd78f96
JH		 3237 }
3238 else {
e1ec3a88 3239 const char *vile;
3aed30dc
HS		 3240 I32 warn_type;
3241
3242 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3243 vile = "closed";
3244 warn_type = WARN_CLOSED;
3245 }
3246 else {
3247 vile = "unopened";
3248 warn_type = WARN_UNOPENED;
3249 }
3250
3251 if (ckWARN(warn_type)) {
3252 if (name && *name) {
3253 Perl_warner(aTHX_ packWARN(warn_type),
3254 "%s%s on %s %s %s", func, pars, vile, type, name);
3255 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3256 Perl_warner(
3257 aTHX_ packWARN(warn_type),
3258 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3259 func, pars, name
3260 );
3261 }
3262 else {
3263 Perl_warner(aTHX_ packWARN(warn_type),
3264 "%s%s on %s %s", func, pars, vile, type);
3265 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3266 Perl_warner(
3267 aTHX_ packWARN(warn_type),
3268 "\t(Are you trying to call %s%s on dirhandle?)\n",
3269 func, pars
3270 );
3271 }
3272 }
bc37a18f 3273 }
69282e91 3274}
a926ef6b
JH		 3275
3276#ifdef EBCDIC
cbebf344
JH		 3277/* in ASCII order, not that it matters */
3278static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3279
a926ef6b
JH		 3280int
3281Perl_ebcdic_control(pTHX_ int ch)
3282{
3aed30dc 3283 if (ch > 'a') {
e1ec3a88 3284 const char *ctlp;
3aed30dc
HS		 3285
3286 if (islower(ch))
3287 ch = toupper(ch);
3288
3289 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3290 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3291 }
3aed30dc
HS		 3292
3293 if (ctlp == controllablechars)
3294 return('\177'); /* DEL */
3295 else
3296 return((unsigned char)(ctlp - controllablechars - 1));
3297 } else { /* Want uncontrol */
3298 if (ch == '\177' || ch == -1)
3299 return('?');
3300 else if (ch == '\157')
3301 return('\177');
3302 else if (ch == '\174')
3303 return('\000');
3304 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3305 return('\036');
3306 else if (ch == '\155')
3307 return('\037');
3308 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3309 return(controllablechars[ch+1]);
3310 else
3311 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3312 }
a926ef6b
JH		 3313}
3314#endif
e72cf795 3315
f6adc668 3316/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3317 * system to give us a reasonable struct to copy. This fix means that
3318 * strftime uses the tm_zone and tm_gmtoff values returned by
3319 * localtime(time()). That should give the desired result most of the
3320 * time. But probably not always!
3321 *
f6adc668
JH		 3322 * This does not address tzname aspects of NETaa14816.
3323 *
e72cf795 3324 */
f6adc668 3325
e72cf795
JH		 3326#ifdef HAS_GNULIBC
3327# ifndef STRUCT_TM_HASZONE
3328# define STRUCT_TM_HASZONE
3329# endif
3330#endif
3331
f6adc668
JH		 3332#ifdef STRUCT_TM_HASZONE /* Backward compat */
3333# ifndef HAS_TM_TM_ZONE
3334# define HAS_TM_TM_ZONE
3335# endif
3336#endif
3337
e72cf795 3338void
f1208910 3339Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3340{
f6adc668 3341#ifdef HAS_TM_TM_ZONE
e72cf795 3342 Time_t now;
1b6737cc 3343 const struct tm* my_tm;
e72cf795 3344 (void)time(&now);
82c57498 3345 my_tm = localtime(&now);
ca46b8ee
SP		 3346 if (my_tm)
3347 Copy(my_tm, ptm, 1, struct tm);
1b6737cc
AL		 3348#else
3349 PERL_UNUSED_ARG(ptm);
e72cf795
JH		 3350#endif
3351}
3352
3353/*
3354 * mini_mktime - normalise struct tm values without the localtime()
3355 * semantics (and overhead) of mktime().
3356 */
3357void
f1208910 3358Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3359{
3360 int yearday;
3361 int secs;
3362 int month, mday, year, jday;
3363 int odd_cent, odd_year;
3364
3365#define DAYS_PER_YEAR 365
3366#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3367#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3368#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3369#define SECS_PER_HOUR (60*60)
3370#define SECS_PER_DAY (24*SECS_PER_HOUR)
3371/* parentheses deliberately absent on these two, otherwise they don't work */
3372#define MONTH_TO_DAYS 153/5
3373#define DAYS_TO_MONTH 5/153
3374/* offset to bias by March (month 4) 1st between month/mday & year finding */
3375#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3376/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3377#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3378
3379/*
3380 * Year/day algorithm notes:
3381 *
3382 * With a suitable offset for numeric value of the month, one can find
3383 * an offset into the year by considering months to have 30.6 (153/5) days,
3384 * using integer arithmetic (i.e., with truncation). To avoid too much
3385 * messing about with leap days, we consider January and February to be
3386 * the 13th and 14th month of the previous year. After that transformation,
3387 * we need the month index we use to be high by 1 from 'normal human' usage,
3388 * so the month index values we use run from 4 through 15.
3389 *
3390 * Given that, and the rules for the Gregorian calendar (leap years are those
3391 * divisible by 4 unless also divisible by 100, when they must be divisible
3392 * by 400 instead), we can simply calculate the number of days since some
3393 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3394 * the days we derive from our month index, and adding in the day of the
3395 * month. The value used here is not adjusted for the actual origin which
3396 * it normally would use (1 January A.D. 1), since we're not exposing it.
3397 * We're only building the value so we can turn around and get the
3398 * normalised values for the year, month, day-of-month, and day-of-year.
3399 *
3400 * For going backward, we need to bias the value we're using so that we find
3401 * the right year value. (Basically, we don't want the contribution of
3402 * March 1st to the number to apply while deriving the year). Having done
3403 * that, we 'count up' the contribution to the year number by accounting for
3404 * full quadracenturies (400-year periods) with their extra leap days, plus
3405 * the contribution from full centuries (to avoid counting in the lost leap
3406 * days), plus the contribution from full quad-years (to count in the normal
3407 * leap days), plus the leftover contribution from any non-leap years.
3408 * At this point, if we were working with an actual leap day, we'll have 0
3409 * days left over. This is also true for March 1st, however. So, we have
3410 * to special-case that result, and (earlier) keep track of the 'odd'
3411 * century and year contributions. If we got 4 extra centuries in a qcent,
3412 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3413 * Otherwise, we add back in the earlier bias we removed (the 123 from
3414 * figuring in March 1st), find the month index (integer division by 30.6),
3415 * and the remainder is the day-of-month. We then have to convert back to
3416 * 'real' months (including fixing January and February from being 14/15 in
3417 * the previous year to being in the proper year). After that, to get
3418 * tm_yday, we work with the normalised year and get a new yearday value for
3419 * January 1st, which we subtract from the yearday value we had earlier,
3420 * representing the date we've re-built. This is done from January 1
3421 * because tm_yday is 0-origin.
3422 *
3423 * Since POSIX time routines are only guaranteed to work for times since the
3424 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3425 * applies Gregorian calendar rules even to dates before the 16th century
3426 * doesn't bother me. Besides, you'd need cultural context for a given
3427 * date to know whether it was Julian or Gregorian calendar, and that's
3428 * outside the scope for this routine. Since we convert back based on the
3429 * same rules we used to build the yearday, you'll only get strange results
3430 * for input which needed normalising, or for the 'odd' century years which
3431 * were leap years in the Julian calander but not in the Gregorian one.
3432 * I can live with that.
3433 *
3434 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3435 * that's still outside the scope for POSIX time manipulation, so I don't
3436 * care.
3437 */
3438
3439 year = 1900 + ptm->tm_year;
3440 month = ptm->tm_mon;
3441 mday = ptm->tm_mday;
3442 /* allow given yday with no month & mday to dominate the result */
3443 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3444 month = 0;
3445 mday = 0;
3446 jday = 1 + ptm->tm_yday;
3447 }
3448 else {
3449 jday = 0;
3450 }
3451 if (month >= 2)
3452 month+=2;
3453 else
3454 month+=14, year--;
3455 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3456 yearday += month*MONTH_TO_DAYS + mday + jday;
3457 /*
3458 * Note that we don't know when leap-seconds were or will be,
3459 * so we have to trust the user if we get something which looks
3460 * like a sensible leap-second. Wild values for seconds will
3461 * be rationalised, however.
3462 */
3463 if ((unsigned) ptm->tm_sec <= 60) {
3464 secs = 0;
3465 }
3466 else {
3467 secs = ptm->tm_sec;
3468 ptm->tm_sec = 0;
3469 }
3470 secs += 60 * ptm->tm_min;
3471 secs += SECS_PER_HOUR * ptm->tm_hour;
3472 if (secs < 0) {
3473 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3474 /* got negative remainder, but need positive time */
3475 /* back off an extra day to compensate */
3476 yearday += (secs/SECS_PER_DAY)-1;
3477 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3478 }
3479 else {
3480 yearday += (secs/SECS_PER_DAY);
3481 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3482 }
3483 }
3484 else if (secs >= SECS_PER_DAY) {
3485 yearday += (secs/SECS_PER_DAY);
3486 secs %= SECS_PER_DAY;
3487 }
3488 ptm->tm_hour = secs/SECS_PER_HOUR;
3489 secs %= SECS_PER_HOUR;
3490 ptm->tm_min = secs/60;
3491 secs %= 60;
3492 ptm->tm_sec += secs;
3493 /* done with time of day effects */
3494 /*
3495 * The algorithm for yearday has (so far) left it high by 428.
3496 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3497 * bias it by 123 while trying to figure out what year it
3498 * really represents. Even with this tweak, the reverse
3499 * translation fails for years before A.D. 0001.
3500 * It would still fail for Feb 29, but we catch that one below.
3501 */
3502 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3503 yearday -= YEAR_ADJUST;
3504 year = (yearday / DAYS_PER_QCENT) * 400;
3505 yearday %= DAYS_PER_QCENT;
3506 odd_cent = yearday / DAYS_PER_CENT;
3507 year += odd_cent * 100;
3508 yearday %= DAYS_PER_CENT;
3509 year += (yearday / DAYS_PER_QYEAR) * 4;
3510 yearday %= DAYS_PER_QYEAR;
3511 odd_year = yearday / DAYS_PER_YEAR;
3512 year += odd_year;
3513 yearday %= DAYS_PER_YEAR;
3514 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3515 month = 1;
3516 yearday = 29;
3517 }
3518 else {
3519 yearday += YEAR_ADJUST; /* recover March 1st crock */
3520 month = yearday*DAYS_TO_MONTH;
3521 yearday -= month*MONTH_TO_DAYS;
3522 /* recover other leap-year adjustment */
3523 if (month > 13) {
3524 month-=14;
3525 year++;
3526 }
3527 else {
3528 month-=2;
3529 }
3530 }
3531 ptm->tm_year = year - 1900;
3532 if (yearday) {
3533 ptm->tm_mday = yearday;
3534 ptm->tm_mon = month;
3535 }
3536 else {
3537 ptm->tm_mday = 31;
3538 ptm->tm_mon = month - 1;
3539 }
3540 /* re-build yearday based on Jan 1 to get tm_yday */
3541 year--;
3542 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3543 yearday += 14*MONTH_TO_DAYS + 1;
3544 ptm->tm_yday = jday - yearday;
3545 /* fix tm_wday if not overridden by caller */
3546 if ((unsigned)ptm->tm_wday > 6)
3547 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3548}
b3c85772
JH		 3549
3550char *
e1ec3a88 3551Perl_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		 3552{
3553#ifdef HAS_STRFTIME
3554 char *buf;
3555 int buflen;
3556 struct tm mytm;
3557 int len;
3558
3559 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3560 mytm.tm_sec = sec;
3561 mytm.tm_min = min;
3562 mytm.tm_hour = hour;
3563 mytm.tm_mday = mday;
3564 mytm.tm_mon = mon;
3565 mytm.tm_year = year;
3566 mytm.tm_wday = wday;
3567 mytm.tm_yday = yday;
3568 mytm.tm_isdst = isdst;
3569 mini_mktime(&mytm);
c473feec
SR		 3570 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3571#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3572 STMT_START {
3573 struct tm mytm2;
3574 mytm2 = mytm;
3575 mktime(&mytm2);
3576#ifdef HAS_TM_TM_GMTOFF
3577 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3578#endif
3579#ifdef HAS_TM_TM_ZONE
3580 mytm.tm_zone = mytm2.tm_zone;
3581#endif
3582 } STMT_END;
3583#endif
b3c85772
JH		 3584 buflen = 64;
3585 New(0, buf, buflen, char);
3586 len = strftime(buf, buflen, fmt, &mytm);
3587 /*
877f6a72 3588 ** The following is needed to handle to the situation where
b3c85772
JH		 3589 ** tmpbuf overflows. Basically we want to allocate a buffer
3590 ** and try repeatedly. The reason why it is so complicated
3591 ** is that getting a return value of 0 from strftime can indicate
3592 ** one of the following:
3593 ** 1. buffer overflowed,
3594 ** 2. illegal conversion specifier, or
3595 ** 3. the format string specifies nothing to be returned(not
3596 ** an error). This could be because format is an empty string
3597 ** or it specifies %p that yields an empty string in some locale.
3598 ** If there is a better way to make it portable, go ahead by
3599 ** all means.
3600 */
3601 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3602 return buf;
3603 else {
3604 /* Possibly buf overflowed - try again with a bigger buf */
e1ec3a88
AL		 3605 const int fmtlen = strlen(fmt);
3606 const int bufsize = fmtlen + buflen;
877f6a72 3607
b3c85772
JH		 3608 New(0, buf, bufsize, char);
3609 while (buf) {
3610 buflen = strftime(buf, bufsize, fmt, &mytm);
3611 if (buflen > 0 && buflen < bufsize)
3612 break;
3613 /* heuristic to prevent out-of-memory errors */
3614 if (bufsize > 100*fmtlen) {
3615 Safefree(buf);
3616 buf = NULL;
3617 break;
3618 }
e1ec3a88 3619 Renew(buf, bufsize*2, char);
b3c85772
JH		 3620 }
3621 return buf;
3622 }
3623#else
3624 Perl_croak(aTHX_ "panic: no strftime");
27da23d5 3625 return NULL;
b3c85772
JH		 3626#endif
3627}
3628
877f6a72
NIS		 3629
3630#define SV_CWD_RETURN_UNDEF \
3631sv_setsv(sv, &PL_sv_undef); \
3632return FALSE
3633
3634#define SV_CWD_ISDOT(dp) \
3635 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3636 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3637
3638/*
ccfc67b7
JH		 3639=head1 Miscellaneous Functions
3640
89423764 3641=for apidoc getcwd_sv
877f6a72
NIS		 3642
3643Fill the sv with current working directory
3644
3645=cut
3646*/
3647
3648/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3649 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3650 * getcwd(3) if available
3651 * Comments from the orignal:
3652 * This is a faster version of getcwd. It's also more dangerous
3653 * because you might chdir out of a directory that you can't chdir
3654 * back into. */
3655
877f6a72 3656int
89423764 3657Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3658{
3659#ifndef PERL_MICRO
3660
ea715489
JH		 3661#ifndef INCOMPLETE_TAINTS
3662 SvTAINTED_on(sv);
3663#endif
3664
8f95b30d
JH		 3665#ifdef HAS_GETCWD
3666 {
60e110a8
DM		 3667 char buf[MAXPATHLEN];
3668
3aed30dc 3669 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3670 * size from the heap if they are given a NULL buffer pointer.
3671 * The problem is that this behaviour is not portable. */
3aed30dc 3672 if (getcwd(buf, sizeof(buf) - 1)) {
4373e329 3673 sv_setpvn(sv, buf, strlen(buf));
3aed30dc
HS		 3674 return TRUE;
3675 }
3676 else {
3677 sv_setsv(sv, &PL_sv_undef);
3678 return FALSE;
3679 }
8f95b30d
JH		 3680 }
3681
3682#else
3683
c623ac67 3684 Stat_t statbuf;
877f6a72 3685 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4373e329 3686 int pathlen=0;
877f6a72 3687 Direntry_t *dp;
877f6a72 3688
862a34c6 3689 SvUPGRADE(sv, SVt_PV);
877f6a72 3690
877f6a72 3691 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3692 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3693 }
3694
3695 orig_cdev = statbuf.st_dev;
3696 orig_cino = statbuf.st_ino;
3697 cdev = orig_cdev;
3698 cino = orig_cino;
3699
3700 for (;;) {
4373e329 3701 DIR *dir;
3aed30dc
HS		 3702 odev = cdev;
3703 oino = cino;
3704
3705 if (PerlDir_chdir("..") < 0) {
3706 SV_CWD_RETURN_UNDEF;
3707 }
3708 if (PerlLIO_stat(".", &statbuf) < 0) {
3709 SV_CWD_RETURN_UNDEF;
3710 }
3711
3712 cdev = statbuf.st_dev;
3713 cino = statbuf.st_ino;
3714
3715 if (odev == cdev && oino == cino) {
3716 break;
3717 }
3718 if (!(dir = PerlDir_open("."))) {
3719 SV_CWD_RETURN_UNDEF;
3720 }
3721
3722 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3723#ifdef DIRNAMLEN
4373e329 3724 const int namelen = dp->d_namlen;
877f6a72 3725#else
4373e329 3726 const int namelen = strlen(dp->d_name);
877f6a72 3727#endif
3aed30dc
HS		 3728 /* skip . and .. */
3729 if (SV_CWD_ISDOT(dp)) {
3730 continue;
3731 }
3732
3733 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3734 SV_CWD_RETURN_UNDEF;
3735 }
3736
3737 tdev = statbuf.st_dev;
3738 tino = statbuf.st_ino;
3739 if (tino == oino && tdev == odev) {
3740 break;
3741 }
cb5953d6
JH		 3742 }
3743
3aed30dc
HS		 3744 if (!dp) {
3745 SV_CWD_RETURN_UNDEF;
3746 }
3747
3748 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3749 SV_CWD_RETURN_UNDEF;
3750 }
877f6a72 3751
3aed30dc
HS		 3752 SvGROW(sv, pathlen + namelen + 1);
3753
3754 if (pathlen) {
3755 /* shift down */
95a20fc0 3756 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3aed30dc 3757 }
877f6a72 3758
3aed30dc
HS		 3759 /* prepend current directory to the front */
3760 *SvPVX(sv) = '/';
3761 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3762 pathlen += (namelen + 1);
877f6a72
NIS		 3763
3764#ifdef VOID_CLOSEDIR
3aed30dc 3765 PerlDir_close(dir);
877f6a72 3766#else
3aed30dc
HS		 3767 if (PerlDir_close(dir) < 0) {
3768 SV_CWD_RETURN_UNDEF;
3769 }
877f6a72
NIS		 3770#endif
3771 }
3772
60e110a8 3773 if (pathlen) {
3aed30dc
HS		 3774 SvCUR_set(sv, pathlen);
3775 *SvEND(sv) = '\0';
3776 SvPOK_only(sv);
877f6a72 3777
95a20fc0 3778 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3aed30dc
HS		 3779 SV_CWD_RETURN_UNDEF;
3780 }
877f6a72
NIS		 3781 }
3782 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 3783 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3784 }
3785
3786 cdev = statbuf.st_dev;
3787 cino = statbuf.st_ino;
3788
3789 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 3790 Perl_croak(aTHX_ "Unstable directory path, "
3791 "current directory changed unexpectedly");
877f6a72 3792 }
877f6a72
NIS		 3793
3794 return TRUE;
793b8d8e
JH		 3795#endif
3796
877f6a72
NIS		 3797#else
3798 return FALSE;
3799#endif
3800}
3801
f4758303 3802/*
b0f01acb
JP		 3803=for apidoc scan_version
3804
3805Returns a pointer to the next character after the parsed
3806version string, as well as upgrading the passed in SV to
3807an RV.
3808
3809Function must be called with an already existing SV like
3810
137d6fc0
JP		 3811 sv = newSV(0);
3812 s = scan_version(s,SV *sv, bool qv);
b0f01acb
JP		 3813
3814Performs some preprocessing to the string to ensure that
3815it has the correct characteristics of a version. Flags the
3816object if it contains an underscore (which denotes this
137d6fc0
JP		 3817is a alpha version). The boolean qv denotes that the version
3818should be interpreted as if it had multiple decimals, even if
3819it doesn't.
b0f01acb
JP		 3820
3821=cut
3822*/
3823
9137345a 3824const char *
e1ec3a88 3825Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
b0f01acb 3826{
e568f1a0 3827 const char *start = s;
9137345a
JP		 3828 const char *pos;
3829 const char *last;
3830 int saw_period = 0;
3831 int saw_under = 0;
3832 int width = 3;
3833 AV *av = newAV();
3834 SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3835 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3a242bf8
NC		 3836#ifndef NODEFAULT_SHAREKEYS
3837 HvSHAREKEYS_on(hv); /* key-sharing on by default */
3838#endif
9137345a
JP		 3839
3840 if (*s == 'v') {
3841 s++; /* get past 'v' */
3842 qv = 1; /* force quoted version processing */
3843 }
3844
3845 last = pos = s;
3846
3847 /* pre-scan the input string to check for decimals/underbars */
ad63d80f
JP		 3848 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3849 {
3850 if ( *pos == '.' )
3851 {
3852 if ( saw_under )
5f89c282 3853 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 3854 saw_period++ ;
9137345a 3855 last = pos;
46314c13 3856 }
ad63d80f
JP		 3857 else if ( *pos == '_' )
3858 {
3859 if ( saw_under )
5f89c282 3860 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
ad63d80f 3861 saw_under = 1;
9137345a 3862 width = pos - last - 1; /* natural width of sub-version */
ad63d80f
JP		 3863 }
3864 pos++;
3865 }
ad63d80f 3866
9137345a 3867 if ( saw_period > 1 ) {
137d6fc0
JP		 3868 qv = 1; /* force quoted version processing */
3869 }
9137345a
JP		 3870
3871 pos = s;
3872
3873 if ( qv )
3874 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
3875 if ( saw_under ) {
3876 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
3877 }
3878 if ( !qv && width < 3 )
3879 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
3880
ad63d80f 3881 while (isDIGIT(*pos))
46314c13 3882 pos++;
ad63d80f
JP		 3883 if (!isALPHA(*pos)) {
3884 I32 rev;
3885
ad63d80f
JP		 3886 for (;;) {
3887 rev = 0;
3888 {
129318bd 3889 /* this is atoi() that delimits on underscores */
9137345a 3890 const char *end = pos;
129318bd
JP		 3891 I32 mult = 1;
3892 I32 orev;
9137345a 3893
129318bd
JP		 3894 /* the following if() will only be true after the decimal
3895 * point of a version originally created with a bare
3896 * floating point number, i.e. not quoted in any way
3897 */
13f8f398 3898 if ( !qv && s > start+1 && saw_period == 1 ) {
c76df65e 3899 mult *= 100;
129318bd
JP		 3900 while ( s < end ) {
3901 orev = rev;
3902 rev += (*s - '0') * mult;
3903 mult /= 10;
32fdb065 3904 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3905 Perl_croak(aTHX_ "Integer overflow in version");
3906 s++;
9137345a
JP		 3907 if ( *s == '_' )
3908 s++;
129318bd
JP		 3909 }
3910 }
3911 else {
3912 while (--end >= s) {
3913 orev = rev;
3914 rev += (*end - '0') * mult;
3915 mult *= 10;
32fdb065 3916 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3917 Perl_croak(aTHX_ "Integer overflow in version");
3918 }
3919 }
3920 }
9137345a 3921
129318bd 3922 /* Append revision */
9137345a
JP		 3923 av_push(av, newSViv(rev));
3924 if ( *pos == '.' && isDIGIT(pos[1]) )
3925 s = ++pos;
3926 else if ( *pos == '_' && isDIGIT(pos[1]) )
ad63d80f
JP		 3927 s = ++pos;
3928 else if ( isDIGIT(*pos) )
3929 s = pos;
b0f01acb 3930 else {
ad63d80f
JP		 3931 s = pos;
3932 break;
3933 }
9137345a
JP		 3934 if ( qv ) {
3935 while ( isDIGIT(*pos) )
3936 pos++;
3937 }
3938 else {
3939 int digits = 0;
3940 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
3941 if ( *pos != '_' )
3942 digits++;
3943 pos++;
3944 }
b0f01acb
JP		 3945 }
3946 }
3947 }
9137345a
JP		 3948 if ( qv ) { /* quoted versions always get at least three terms*/
3949 I32 len = av_len(av);
4edfc503
NC		 3950 /* This for loop appears to trigger a compiler bug on OS X, as it
3951 loops infinitely. Yes, len is negative. No, it makes no sense.
3952 Compiler in question is:
3953 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3954 for ( len = 2 - len; len > 0; len-- )
3955 av_push((AV *)sv, newSViv(0));
3956 */
3957 len = 2 - len;
3958 while (len-- > 0)
9137345a 3959 av_push(av, newSViv(0));
b9381830 3960 }
9137345a
JP		 3961
3962 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
3963 av_push(av, newSViv(0));
3964
3965 /* And finally, store the AV in the hash */
3966 hv_store((HV *)hv, "version", 7, (SV *)av, 0);
3967 return s;
b0f01acb
JP		 3968}
3969
3970/*
3971=for apidoc new_version
3972
3973Returns a new version object based on the passed in SV:
3974
3975 SV *sv = new_version(SV *ver);
3976
3977Does not alter the passed in ver SV. See "upg_version" if you
3978want to upgrade the SV.
3979
3980=cut
3981*/
3982
3983SV *
3984Perl_new_version(pTHX_ SV *ver)
3985{
129318bd 3986 SV *rv = newSV(0);
d7aa5382
JP		 3987 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3988 {
3989 I32 key;
53c1dcc0 3990 AV * const av = newAV();
9137345a
JP		 3991 AV *sav;
3992 /* This will get reblessed later if a derived class*/
53c1dcc0 3993 SV* const hv = newSVrv(rv, "version");
9137345a 3994 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3a242bf8
NC		 3995#ifndef NODEFAULT_SHAREKEYS
3996 HvSHAREKEYS_on(hv); /* key-sharing on by default */
3997#endif
9137345a
JP		 3998
3999 if ( SvROK(ver) )
4000 ver = SvRV(ver);
4001
4002 /* Begin copying all of the elements */
4003 if ( hv_exists((HV *)ver, "qv", 2) )
4004 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4005
4006 if ( hv_exists((HV *)ver, "alpha", 5) )
4007 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4008
4009 if ( hv_exists((HV*)ver, "width", 5 ) )
d7aa5382 4010 {
53c1dcc0 4011 const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
9137345a 4012 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
d7aa5382 4013 }
9137345a
JP		 4014
4015 sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE);
4016 /* This will get reblessed later if a derived class*/
4017 for ( key = 0; key <= av_len(sav); key++ )
4018 {
4019 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4020 av_push(av, newSViv(rev));
4021 }
4022
4023 hv_store((HV *)hv, "version", 7, (SV *)av, 0);
d7aa5382
JP		 4024 return rv;
4025 }
ad63d80f 4026#ifdef SvVOK
137d6fc0
JP		 4027 if ( SvVOK(ver) ) { /* already a v-string */
4028 char *version;
b0f01acb
JP		 4029 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4030 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0
JP		 4031 sv_setpv(rv,version);
4032 Safefree(version);
b0f01acb 4033 }
137d6fc0 4034 else {
ad63d80f 4035#endif
137d6fc0
JP		 4036 sv_setsv(rv,ver); /* make a duplicate */
4037#ifdef SvVOK
26ec6fc3 4038 }
137d6fc0
JP		 4039#endif
4040 upg_version(rv);
b0f01acb
JP		 4041 return rv;
4042}
4043
4044/*
4045=for apidoc upg_version
4046
4047In-place upgrade of the supplied SV to a version object.
4048
4049 SV *sv = upg_version(SV *sv);
4050
4051Returns a pointer to the upgraded SV.
4052
4053=cut
4054*/
4055
4056SV *
ad63d80f 4057Perl_upg_version(pTHX_ SV *ver)
b0f01acb 4058{
137d6fc0
JP		 4059 char *version;
4060 bool qv = 0;
4061
4062 if ( SvNOK(ver) ) /* may get too much accuracy */
4063 {
4064 char tbuf[64];
4065 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4066 version = savepv(tbuf);
4067 }
ad63d80f 4068#ifdef SvVOK
137d6fc0 4069 else if ( SvVOK(ver) ) { /* already a v-string */
ad63d80f
JP		 4070 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4071 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0 4072 qv = 1;
b0f01acb 4073 }
ad63d80f 4074#endif
137d6fc0
JP		 4075 else /* must be a string or something like a string */
4076 {
9137345a 4077 version = savepv(SvPV_nolen(ver));
137d6fc0
JP		 4078 }
4079 (void)scan_version(version, ver, qv);
4080 Safefree(version);
ad63d80f 4081 return ver;
b0f01acb
JP		 4082}
4083
4084
4085/*
4086=for apidoc vnumify
4087
ad63d80f
JP		 4088Accepts a version object and returns the normalized floating
4089point representation. Call like:
b0f01acb 4090
ad63d80f 4091 sv = vnumify(rv);
b0f01acb 4092
ad63d80f
JP		 4093NOTE: you can pass either the object directly or the SV
4094contained within the RV.
b0f01acb
JP		 4095
4096=cut
4097*/
4098
4099SV *
ad63d80f 4100Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4101{
ad63d80f 4102 I32 i, len, digit;
9137345a
JP		 4103 int width;
4104 bool alpha = FALSE;
53c1dcc0 4105 SV * const sv = newSV(0);
9137345a 4106 AV *av;
ad63d80f
JP		 4107 if ( SvROK(vs) )
4108 vs = SvRV(vs);
9137345a
JP		 4109
4110 /* see if various flags exist */
4111 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4112 alpha = TRUE;
4113 if ( hv_exists((HV*)vs, "width", 5 ) )
4114 width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
4115 else
4116 width = 3;
4117
4118
4119 /* attempt to retrieve the version array */
4120 if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) {
53c1dcc0 4121 sv_catpvn(sv,"0",1);
9137345a
JP		 4122 return sv;
4123 }
4124
4125 len = av_len(av);
46314c13
JP		 4126 if ( len == -1 )
4127 {
b66123c5 4128 sv_catpvn(sv,"0",1);
46314c13
JP		 4129 return sv;
4130 }
9137345a
JP		 4131
4132 digit = SvIV(*av_fetch(av, 0, 0));
c0fd1b42 4133 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
13f8f398 4134 for ( i = 1 ; i < len ; i++ )
b0f01acb 4135 {
9137345a
JP		 4136 digit = SvIV(*av_fetch(av, i, 0));
4137 if ( width < 3 ) {
53c1dcc0
AL		 4138 const int denom = (int)pow(10,(3-width));
4139 const div_t term = div((int)PERL_ABS(digit),denom);
9137345a
JP		 4140 Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
4141 }
4142 else {
4143 Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
4144 }
b0f01acb 4145 }
13f8f398
JP		 4146
4147 if ( len > 0 )
4148 {
9137345a
JP		 4149 digit = SvIV(*av_fetch(av, len, 0));
4150 if ( alpha && width == 3 ) /* alpha version */
4151 Perl_sv_catpv(aTHX_ sv,"_");
4152 /* Don't display additional trailing zeros */
4153 if ( digit > 0 )
4154 Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
13f8f398 4155 }
9137345a 4156 else /* len == 1 */
13f8f398 4157 {
b66123c5 4158 sv_catpvn(sv,"000",3);
13f8f398 4159 }
b0f01acb
JP		 4160 return sv;
4161}
4162
4163/*
b9381830 4164=for apidoc vnormal
b0f01acb 4165
ad63d80f
JP		 4166Accepts a version object and returns the normalized string
4167representation. Call like:
b0f01acb 4168
b9381830 4169 sv = vnormal(rv);
b0f01acb 4170
ad63d80f
JP		 4171NOTE: you can pass either the object directly or the SV
4172contained within the RV.
b0f01acb
JP		 4173
4174=cut
4175*/
4176
4177SV *
b9381830 4178Perl_vnormal(pTHX_ SV *vs)
b0f01acb 4179{
ad63d80f 4180 I32 i, len, digit;
9137345a 4181 bool alpha = FALSE;
137d6fc0 4182 SV *sv = newSV(0);
9137345a 4183 AV *av;
ad63d80f
JP		 4184 if ( SvROK(vs) )
4185 vs = SvRV(vs);
9137345a
JP		 4186
4187 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4188 alpha = TRUE;
4189 av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE);
4190
4191 len = av_len(av);
4192 if ( len == -1 ) {
b66123c5 4193 sv_catpvn(sv,"",0);
46314c13
JP		 4194 return sv;
4195 }
9137345a
JP		 4196 digit = SvIV(*av_fetch(av, 0, 0));
4197 Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit);
4198 for ( i = 1 ; i <= len-1 ; i++ ) {
4199 digit = SvIV(*av_fetch(av, i, 0));
4200 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4201 }
4202
4203 if ( len > 0 ) {
4204 /* handle last digit specially */
4205 digit = SvIV(*av_fetch(av, len, 0));
4206 if ( alpha )
4207 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
ad63d80f 4208 else
9137345a 4209 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
b0f01acb 4210 }
9137345a 4211
137d6fc0
JP		 4212 if ( len <= 2 ) { /* short version, must be at least three */
4213 for ( len = 2 - len; len != 0; len-- )
b66123c5 4214 sv_catpvn(sv,".0",2);
137d6fc0
JP		 4215 }
4216
b0f01acb 4217 return sv;
9137345a 4218}
b0f01acb 4219
ad63d80f 4220/*
b9381830
JP		 4221=for apidoc vstringify
4222
4223In order to maintain maximum compatibility with earlier versions
4224of Perl, this function will return either the floating point
4225notation or the multiple dotted notation, depending on whether
4226the original version contained 1 or more dots, respectively
4227
4228=cut
4229*/
4230
4231SV *
4232Perl_vstringify(pTHX_ SV *vs)
4233{
9137345a 4234 I32 qv = 0;
b9381830
JP		 4235 if ( SvROK(vs) )
4236 vs = SvRV(vs);
b9381830 4237
9137345a
JP		 4238 if ( hv_exists((HV *)vs, "qv", 2) )
4239 qv = 1;
4240
4241 if ( qv )
b9381830 4242 return vnormal(vs);
9137345a
JP		 4243 else
4244 return vnumify(vs);
b9381830
JP		 4245}
4246
4247/*
ad63d80f
JP		 4248=for apidoc vcmp
4249
4250Version object aware cmp. Both operands must already have been
4251converted into version objects.
4252
4253=cut
4254*/
4255
4256int
9137345a 4257Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
ad63d80f
JP		 4258{
4259 I32 i,l,m,r,retval;
9137345a
JP		 4260 bool lalpha = FALSE;
4261 bool ralpha = FALSE;
4262 I32 left = 0;
4263 I32 right = 0;
4264 AV *lav, *rav;
4265 if ( SvROK(lhv) )
4266 lhv = SvRV(lhv);
4267 if ( SvROK(rhv) )
4268 rhv = SvRV(rhv);
4269
4270 /* get the left hand term */
4271 lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE);
4272 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4273 lalpha = TRUE;
4274
4275 /* and the right hand term */
4276 rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE);
4277 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4278 ralpha = TRUE;
4279
4280 l = av_len(lav);
4281 r = av_len(rav);
ad63d80f
JP		 4282 m = l < r ? l : r;
4283 retval = 0;
4284 i = 0;
4285 while ( i <= m && retval == 0 )
4286 {
9137345a
JP		 4287 left = SvIV(*av_fetch(lav,i,0));
4288 right = SvIV(*av_fetch(rav,i,0));
4289 if ( left < right )
ad63d80f 4290 retval = -1;
9137345a 4291 if ( left > right )
ad63d80f
JP		 4292 retval = +1;
4293 i++;
4294 }
4295
9137345a
JP		 4296 /* tiebreaker for alpha with identical terms */
4297 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4298 {
4299 if ( lalpha && !ralpha )
4300 {
4301 retval = -1;
4302 }
4303 else if ( ralpha && !lalpha)
4304 {
4305 retval = +1;
4306 }
4307 }
4308
137d6fc0 4309 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
129318bd 4310 {
137d6fc0 4311 if ( l < r )
129318bd 4312 {
137d6fc0
JP		 4313 while ( i <= r && retval == 0 )
4314 {
9137345a 4315 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
137d6fc0
JP		 4316 retval = -1; /* not a match after all */
4317 i++;
4318 }
4319 }
4320 else
4321 {
4322 while ( i <= l && retval == 0 )
4323 {
9137345a 4324 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
137d6fc0
JP		 4325 retval = +1; /* not a match after all */
4326 i++;
4327 }
129318bd
JP		 4328 }
4329 }
ad63d80f
JP		 4330 return retval;
4331}
4332
c95c94b1 4333#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4334# define EMULATE_SOCKETPAIR_UDP
4335#endif
4336
4337#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4338static int
4339S_socketpair_udp (int fd[2]) {
e10bb1e9 4340 dTHX;
02fc2eee
NC		 4341 /* Fake a datagram socketpair using UDP to localhost. */
4342 int sockets[2] = {-1, -1};
4343 struct sockaddr_in addresses[2];
4344 int i;
3aed30dc 4345 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4346 unsigned short port;
02fc2eee
NC		 4347 int got;
4348
3aed30dc 4349 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4350 i = 1;
4351 do {
3aed30dc
HS		 4352 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4353 if (sockets[i] == -1)
4354 goto tidy_up_and_fail;
4355
4356 addresses[i].sin_family = AF_INET;
4357 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4358 addresses[i].sin_port = 0; /* kernel choses port. */
4359 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4360 sizeof(struct sockaddr_in)) == -1)
4361 goto tidy_up_and_fail;
02fc2eee
NC		 4362 } while (i--);
4363
4364 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4365 for each connect the other socket to it. */
4366 i = 1;
4367 do {
3aed30dc
HS		 4368 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4369 &size) == -1)
4370 goto tidy_up_and_fail;
4371 if (size != sizeof(struct sockaddr_in))
4372 goto abort_tidy_up_and_fail;
4373 /* !1 is 0, !0 is 1 */
4374 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4375 sizeof(struct sockaddr_in)) == -1)
4376 goto tidy_up_and_fail;
02fc2eee
NC		 4377 } while (i--);
4378
4379 /* Now we have 2 sockets connected to each other. I don't trust some other
4380 process not to have already sent a packet to us (by random) so send
4381 a packet from each to the other. */
4382 i = 1;
4383 do {
3aed30dc
HS		 4384 /* I'm going to send my own port number. As a short.
4385 (Who knows if someone somewhere has sin_port as a bitfield and needs
4386 this routine. (I'm assuming crays have socketpair)) */
4387 port = addresses[i].sin_port;
4388 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4389 if (got != sizeof(port)) {
4390 if (got == -1)
4391 goto tidy_up_and_fail;
4392 goto abort_tidy_up_and_fail;
4393 }
02fc2eee
NC		 4394 } while (i--);
4395
4396 /* Packets sent. I don't trust them to have arrived though.
4397 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4398 connect to localhost will use a second kernel thread. In 2.6 the
4399 first thread running the connect() returns before the second completes,
4400 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4401 returns 0. Poor programs have tripped up. One poor program's authors'
4402 had a 50-1 reverse stock split. Not sure how connected these were.)
4403 So I don't trust someone not to have an unpredictable UDP stack.
4404 */
4405
4406 {
3aed30dc
HS		 4407 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4408 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4409 fd_set rset;
4410
4411 FD_ZERO(&rset);
4412 FD_SET(sockets[0], &rset);
4413 FD_SET(sockets[1], &rset);
4414
4415 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4416 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4417 || !FD_ISSET(sockets[1], &rset)) {
4418 /* I hope this is portable and appropriate. */
4419 if (got == -1)
4420 goto tidy_up_and_fail;
4421 goto abort_tidy_up_and_fail;
4422 }
02fc2eee 4423 }
f4758303 4424
02fc2eee
NC		 4425 /* And the paranoia department even now doesn't trust it to have arrive
4426 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4427 {
3aed30dc
HS		 4428 struct sockaddr_in readfrom;
4429 unsigned short buffer[2];
02fc2eee 4430
3aed30dc
HS		 4431 i = 1;
4432 do {
02fc2eee 4433#ifdef MSG_DONTWAIT
3aed30dc
HS		 4434 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4435 sizeof(buffer), MSG_DONTWAIT,
4436 (struct sockaddr *) &readfrom, &size);
02fc2eee 4437#else
3aed30dc
HS		 4438 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4439 sizeof(buffer), 0,
4440 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4441#endif
02fc2eee 4442
3aed30dc
HS		 4443 if (got == -1)
4444 goto tidy_up_and_fail;
4445 if (got != sizeof(port)
4446 || size != sizeof(struct sockaddr_in)
4447 /* Check other socket sent us its port. */
4448 || buffer[0] != (unsigned short) addresses[!i].sin_port
4449 /* Check kernel says we got the datagram from that socket */
4450 || readfrom.sin_family != addresses[!i].sin_family
4451 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4452 || readfrom.sin_port != addresses[!i].sin_port)
4453 goto abort_tidy_up_and_fail;
4454 } while (i--);
02fc2eee
NC		 4455 }
4456 /* My caller (my_socketpair) has validated that this is non-NULL */
4457 fd[0] = sockets[0];
4458 fd[1] = sockets[1];
4459 /* I hereby declare this connection open. May God bless all who cross
4460 her. */
4461 return 0;
4462
4463 abort_tidy_up_and_fail:
4464 errno = ECONNABORTED;
4465 tidy_up_and_fail:
4466 {
4373e329 4467 const int save_errno = errno;
3aed30dc
HS		 4468 if (sockets[0] != -1)
4469 PerlLIO_close(sockets[0]);
4470 if (sockets[1] != -1)
4471 PerlLIO_close(sockets[1]);
4472 errno = save_errno;
4473 return -1;
02fc2eee
NC		 4474 }
4475}
85ca448a 4476#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4477
b5ac89c3 4478#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4479int
4480Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4481 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4482 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4483 dTHX;
02fc2eee
NC		 4484 int listener = -1;
4485 int connector = -1;
4486 int acceptor = -1;
4487 struct sockaddr_in listen_addr;
4488 struct sockaddr_in connect_addr;
4489 Sock_size_t size;
4490
50458334
JH		 4491 if (protocol
4492#ifdef AF_UNIX
4493 || family != AF_UNIX
4494#endif
3aed30dc
HS		 4495 ) {
4496 errno = EAFNOSUPPORT;
4497 return -1;
02fc2eee 4498 }
2948e0bd 4499 if (!fd) {
3aed30dc
HS		 4500 errno = EINVAL;
4501 return -1;
2948e0bd 4502 }
02fc2eee 4503
2bc69dc4 4504#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4505 if (type == SOCK_DGRAM)
3aed30dc 4506 return S_socketpair_udp(fd);
2bc69dc4 4507#endif
02fc2eee 4508
3aed30dc 4509 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4510 if (listener == -1)
3aed30dc
HS		 4511 return -1;
4512 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4513 listen_addr.sin_family = AF_INET;
3aed30dc 4514 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4515 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4516 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4517 sizeof(listen_addr)) == -1)
4518 goto tidy_up_and_fail;
e10bb1e9 4519 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4520 goto tidy_up_and_fail;
02fc2eee 4521
3aed30dc 4522 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4523 if (connector == -1)
3aed30dc 4524 goto tidy_up_and_fail;
02fc2eee 4525 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4526 size = sizeof(connect_addr);
4527 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4528 &size) == -1)
4529 goto tidy_up_and_fail;
4530 if (size != sizeof(connect_addr))
4531 goto abort_tidy_up_and_fail;
e10bb1e9 4532 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4533 sizeof(connect_addr)) == -1)
4534 goto tidy_up_and_fail;
02fc2eee 4535
3aed30dc
HS		 4536 size = sizeof(listen_addr);
4537 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4538 &size);
02fc2eee 4539 if (acceptor == -1)
3aed30dc
HS		 4540 goto tidy_up_and_fail;
4541 if (size != sizeof(listen_addr))
4542 goto abort_tidy_up_and_fail;
4543 PerlLIO_close(listener);
02fc2eee
NC		 4544 /* Now check we are talking to ourself by matching port and host on the
4545 two sockets. */
3aed30dc
HS		 4546 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4547 &size) == -1)
4548 goto tidy_up_and_fail;
4549 if (size != sizeof(connect_addr)
4550 || listen_addr.sin_family != connect_addr.sin_family
4551 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4552 || listen_addr.sin_port != connect_addr.sin_port) {
4553 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4554 }
4555 fd[0] = connector;
4556 fd[1] = acceptor;
4557 return 0;
4558
4559 abort_tidy_up_and_fail:
27da23d5
JH		 4560#ifdef ECONNABORTED
4561 errno = ECONNABORTED; /* This would be the standard thing to do. */
4562#else
4563# ifdef ECONNREFUSED
4564 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4565# else
4566 errno = ETIMEDOUT; /* Desperation time. */
4567# endif
4568#endif
02fc2eee
NC		 4569 tidy_up_and_fail:
4570 {
3aed30dc
HS		 4571 int save_errno = errno;
4572 if (listener != -1)
4573 PerlLIO_close(listener);
4574 if (connector != -1)
4575 PerlLIO_close(connector);
4576 if (acceptor != -1)
4577 PerlLIO_close(acceptor);
4578 errno = save_errno;
4579 return -1;
02fc2eee
NC		 4580 }
4581}
85ca448a 4582#else
48ea76d1
JH		 4583/* In any case have a stub so that there's code corresponding
4584 * to the my_socketpair in global.sym. */
4585int
4586Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4587#ifdef HAS_SOCKETPAIR
48ea76d1 4588 return socketpair(family, type, protocol, fd);
daf16542
JH		 4589#else
4590 return -1;
4591#endif
48ea76d1
JH		 4592}
4593#endif
4594
68795e93
NIS		 4595/*
4596
4597=for apidoc sv_nosharing
4598
4599Dummy routine which "shares" an SV when there is no sharing module present.
4600Exists to avoid test for a NULL function pointer and because it could potentially warn under
4601some level of strict-ness.
4602
4603=cut
4604*/
4605
4606void
4607Perl_sv_nosharing(pTHX_ SV *sv)
4608{
53c1dcc0 4609 PERL_UNUSED_ARG(sv);
68795e93
NIS		 4610}
4611
4612/*
4613=for apidoc sv_nolocking
4614
4615Dummy routine which "locks" an SV when there is no locking module present.
4616Exists to avoid test for a NULL function pointer and because it could potentially warn under
4617some level of strict-ness.
4618
4619=cut
4620*/
4621
4622void
4623Perl_sv_nolocking(pTHX_ SV *sv)
4624{
53c1dcc0 4625 PERL_UNUSED_ARG(sv);
68795e93
NIS		 4626}
4627
4628
4629/*
4630=for apidoc sv_nounlocking
4631
4632Dummy routine which "unlocks" an SV when there is no locking module present.
4633Exists to avoid test for a NULL function pointer and because it could potentially warn under
4634some level of strict-ness.
4635
4636=cut
4637*/
4638
4639void
4640Perl_sv_nounlocking(pTHX_ SV *sv)
4641{
53c1dcc0 4642 PERL_UNUSED_ARG(sv);
68795e93
NIS		 4643}
4644
a05d7ebb 4645U32
e1ec3a88 4646Perl_parse_unicode_opts(pTHX_ const char **popt)
a05d7ebb 4647{
e1ec3a88 4648 const char *p = *popt;
a05d7ebb
JH		 4649 U32 opt = 0;
4650
4651 if (*p) {
4652 if (isDIGIT(*p)) {
4653 opt = (U32) atoi(p);
4654 while (isDIGIT(*p)) p++;
7c91f477 4655 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 4656 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4657 }
4658 else {
4659 for (; *p; p++) {
4660 switch (*p) {
4661 case PERL_UNICODE_STDIN:
4662 opt |= PERL_UNICODE_STDIN_FLAG; break;
4663 case PERL_UNICODE_STDOUT:
4664 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4665 case PERL_UNICODE_STDERR:
4666 opt |= PERL_UNICODE_STDERR_FLAG; break;
4667 case PERL_UNICODE_STD:
4668 opt |= PERL_UNICODE_STD_FLAG; break;
4669 case PERL_UNICODE_IN:
4670 opt |= PERL_UNICODE_IN_FLAG; break;
4671 case PERL_UNICODE_OUT:
4672 opt |= PERL_UNICODE_OUT_FLAG; break;
4673 case PERL_UNICODE_INOUT:
4674 opt |= PERL_UNICODE_INOUT_FLAG; break;
4675 case PERL_UNICODE_LOCALE:
4676 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4677 case PERL_UNICODE_ARGV:
4678 opt |= PERL_UNICODE_ARGV_FLAG; break;
4679 default:
7c91f477
JH		 4680 if (*p != '\n' && *p != '\r')
4681 Perl_croak(aTHX_
4682 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 4683 }
4684 }
4685 }
4686 }
4687 else
4688 opt = PERL_UNICODE_DEFAULT_FLAGS;
4689
4690 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 4691 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 4692 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4693
4694 *popt = p;
4695
4696 return opt;
4697}
4698
132efe8b
JH		 4699U32
4700Perl_seed(pTHX)
4701{
4702 /*
4703 * This is really just a quick hack which grabs various garbage
4704 * values. It really should be a real hash algorithm which
4705 * spreads the effect of every input bit onto every output bit,
4706 * if someone who knows about such things would bother to write it.
4707 * Might be a good idea to add that function to CORE as well.
4708 * No numbers below come from careful analysis or anything here,
4709 * except they are primes and SEED_C1 > 1E6 to get a full-width
4710 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4711 * probably be bigger too.
4712 */
4713#if RANDBITS > 16
4714# define SEED_C1 1000003
4715#define SEED_C4 73819
4716#else
4717# define SEED_C1 25747
4718#define SEED_C4 20639
4719#endif
4720#define SEED_C2 3
4721#define SEED_C3 269
4722#define SEED_C5 26107
4723
4724#ifndef PERL_NO_DEV_RANDOM
4725 int fd;
4726#endif
4727 U32 u;
4728#ifdef VMS
4729# include <starlet.h>
4730 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4731 * in 100-ns units, typically incremented ever 10 ms. */
4732 unsigned int when[2];
4733#else
4734# ifdef HAS_GETTIMEOFDAY
4735 struct timeval when;
4736# else
4737 Time_t when;
4738# endif
4739#endif
4740
4741/* This test is an escape hatch, this symbol isn't set by Configure. */
4742#ifndef PERL_NO_DEV_RANDOM
4743#ifndef PERL_RANDOM_DEVICE
4744 /* /dev/random isn't used by default because reads from it will block
4745 * if there isn't enough entropy available. You can compile with
4746 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4747 * is enough real entropy to fill the seed. */
4748# define PERL_RANDOM_DEVICE "/dev/urandom"
4749#endif
4750 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4751 if (fd != -1) {
27da23d5 4752 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
132efe8b
JH		 4753 u = 0;
4754 PerlLIO_close(fd);
4755 if (u)
4756 return u;
4757 }
4758#endif
4759
4760#ifdef VMS
4761 _ckvmssts(sys$gettim(when));
4762 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4763#else
4764# ifdef HAS_GETTIMEOFDAY
4765 PerlProc_gettimeofday(&when,NULL);
4766 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4767# else
4768 (void)time(&when);
4769 u = (U32)SEED_C1 * when;
4770# endif
4771#endif
4772 u += SEED_C3 * (U32)PerlProc_getpid();
4773 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4774#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4775 u += SEED_C5 * (U32)PTR2UV(&when);
4776#endif
4777 return u;
4778}
4779
bed60192 4780UV
a783c5f4 4781Perl_get_hash_seed(pTHX)
bed60192 4782{
e1ec3a88 4783 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
bed60192
JH		 4784 UV myseed = 0;
4785
4786 if (s)
4787 while (isSPACE(*s)) s++;
4788 if (s && isDIGIT(*s))
4789 myseed = (UV)Atoul(s);
4790 else
4791#ifdef USE_HASH_SEED_EXPLICIT
4792 if (s)
4793#endif
4794 {
4795 /* Compute a random seed */
4796 (void)seedDrand01((Rand_seed_t)seed());
bed60192
JH		 4797 myseed = (UV)(Drand01() * (NV)UV_MAX);
4798#if RANDBITS < (UVSIZE * 8)
4799 /* Since there are not enough randbits to to reach all
4800 * the bits of a UV, the low bits might need extra
4801 * help. Sum in another random number that will
4802 * fill in the low bits. */
4803 myseed +=
4804 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4805#endif /* RANDBITS < (UVSIZE * 8) */
6cfd5ea7
JH		 4806 if (myseed == 0) { /* Superparanoia. */
4807 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4808 if (myseed == 0)
4809 Perl_croak(aTHX_ "Your random numbers are not that random");
4810 }
bed60192 4811 }
008fb0c0 4812 PL_rehash_seed_set = TRUE;
bed60192
JH		 4813
4814 return myseed;
4815}
27da23d5 4816
ed221c57
AL		 4817#ifdef USE_ITHREADS
4818bool
4819Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
4820{
4821 const char * const stashpv = CopSTASHPV(c);
4822 const char * const name = HvNAME_get(hv);
4823
4824 if (stashpv == name)
4825 return TRUE;
4826 if (stashpv && name)
4827 if (strEQ(stashpv, name))
4828 return TRUE;
4829 return FALSE;
4830}
4831#endif
4832
4833
27da23d5
JH		 4834#ifdef PERL_GLOBAL_STRUCT
4835
4836struct perl_vars *
4837Perl_init_global_struct(pTHX)
4838{
4839 struct perl_vars *plvarsp = NULL;
4840#ifdef PERL_GLOBAL_STRUCT
4841# define PERL_GLOBAL_STRUCT_INIT
4842# include "opcode.h" /* the ppaddr and check */
4843 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4844 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4845# ifdef PERL_GLOBAL_STRUCT_PRIVATE
4846 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4847 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4848 if (!plvarsp)
4849 exit(1);
4850# else
4851 plvarsp = PL_VarsPtr;
4852# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
aadb217d
JH		 4853# undef PERLVAR
4854# undef PERLVARA
4855# undef PERLVARI
4856# undef PERLVARIC
4857# undef PERLVARISC
27da23d5
JH		 4858# define PERLVAR(var,type) /**/
4859# define PERLVARA(var,n,type) /**/
4860# define PERLVARI(var,type,init) plvarsp->var = init;
4861# define PERLVARIC(var,type,init) plvarsp->var = init;
4862# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4863# include "perlvars.h"
4864# undef PERLVAR
4865# undef PERLVARA
4866# undef PERLVARI
4867# undef PERLVARIC
4868# undef PERLVARISC
4869# ifdef PERL_GLOBAL_STRUCT
4870 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4871 if (!plvarsp->Gppaddr)
4872 exit(1);
4873 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4874 if (!plvarsp->Gcheck)
4875 exit(1);
4876 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4877 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4878# endif
4879# ifdef PERL_SET_VARS
4880 PERL_SET_VARS(plvarsp);
4881# endif
4882# undef PERL_GLOBAL_STRUCT_INIT
4883#endif
4884 return plvarsp;
4885}
4886
4887#endif /* PERL_GLOBAL_STRUCT */
4888
4889#ifdef PERL_GLOBAL_STRUCT
4890
4891void
4892Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4893{
4894#ifdef PERL_GLOBAL_STRUCT
4895# ifdef PERL_UNSET_VARS
4896 PERL_UNSET_VARS(plvarsp);
4897# endif
4898 free(plvarsp->Gppaddr);
4899 free(plvarsp->Gcheck);
4900# ifdef PERL_GLOBAL_STRUCT_PRIVATE
4901 free(plvarsp);
4902# endif
4903#endif
4904}
4905
4906#endif /* PERL_GLOBAL_STRUCT */
4907
66610fdd
RGS		 4908/*
4909 * Local variables:
4910 * c-indentation-style: bsd
4911 * c-basic-offset: 4
4912 * indent-tabs-mode: t
4913 * End:
4914 *
37442d52
RGS		 4915 * ex: set ts=8 sts=4 sw=4 noet:
4916 */
Unnamed repository; edit this file 'description' to name the repository.