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