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