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