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