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