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