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