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