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