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