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