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