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