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
Silence some warnings
[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;
10edeb5d
JH		 885 Newx(newaddr, pvlen, char);
886 return (char*)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 }
10edeb5d 942 return (char*)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 1539
10edeb5d
JH		 1540 buffer = (STRLEN*)
1541 (specialWARN(buffer) ?
1542 PerlMemShared_malloc(len_wanted) :
1543 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC		 1544 buffer[0] = size;
1545 Copy(bits, (buffer + 1), size, char);
1546 return buffer;
1547}
f54ba1c2 1548
e6587932
DM		 1549/* since we've already done strlen() for both nam and val
1550 * we can use that info to make things faster than
1551 * sprintf(s, "%s=%s", nam, val)
1552 */
1553#define my_setenv_format(s, nam, nlen, val, vlen) \
1554 Copy(nam, s, nlen, char); \
1555 *(s+nlen) = '='; \
1556 Copy(val, s+(nlen+1), vlen, char); \
1557 *(s+(nlen+1+vlen)) = '\0'
1558
c5d12488
JH		 1559#ifdef USE_ENVIRON_ARRAY
1560 /* VMS' my_setenv() is in vms.c */
1561#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1562void
e1ec3a88 1563Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1564{
27da23d5 1565 dVAR;
4efc5df6
GS		 1566#ifdef USE_ITHREADS
1567 /* only parent thread can modify process environment */
1568 if (PL_curinterp == aTHX)
1569#endif
1570 {
f2517201 1571#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1572 if (!PL_use_safe_putenv) {
c5d12488
JH		 1573 /* most putenv()s leak, so we manipulate environ directly */
1574 register I32 i=setenv_getix(nam); /* where does it go? */
1575 int nlen, vlen;
1576
1577 if (environ == PL_origenviron) { /* need we copy environment? */
1578 I32 j;
1579 I32 max;
1580 char **tmpenv;
1581
1582 max = i;
1583 while (environ[max])
1584 max++;
1585 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1586 for (j=0; j<max; j++) { /* copy environment */
1587 const int len = strlen(environ[j]);
1588 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1589 Copy(environ[j], tmpenv[j], len+1, char);
1590 }
1591 tmpenv[max] = NULL;
1592 environ = tmpenv; /* tell exec where it is now */
1593 }
1594 if (!val) {
1595 safesysfree(environ[i]);
1596 while (environ[i]) {
1597 environ[i] = environ[i+1];
1598 i++;
a687059c 1599 }
c5d12488
JH		 1600 return;
1601 }
1602 if (!environ[i]) { /* does not exist yet */
1603 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1604 environ[i+1] = NULL; /* make sure it's null terminated */
1605 }
1606 else
1607 safesysfree(environ[i]);
1608 nlen = strlen(nam);
1609 vlen = strlen(val);
1610
1611 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1612 /* all that work just for this */
1613 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1614 } else {
c5d12488 1615# endif
7ee146b1 1616# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB		 1617# if defined(HAS_UNSETENV)
1618 if (val == NULL) {
1619 (void)unsetenv(nam);
1620 } else {
1621 (void)setenv(nam, val, 1);
1622 }
1623# else /* ! HAS_UNSETENV */
1624 (void)setenv(nam, val, 1);
1625# endif /* HAS_UNSETENV */
47dafe4d 1626# else
88f5bc07
AB		 1627# if defined(HAS_UNSETENV)
1628 if (val == NULL) {
1629 (void)unsetenv(nam);
1630 } else {
c4420975
AL		 1631 const int nlen = strlen(nam);
1632 const int vlen = strlen(val);
1633 char * const new_env =
88f5bc07
AB		 1634 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1635 my_setenv_format(new_env, nam, nlen, val, vlen);
1636 (void)putenv(new_env);
1637 }
1638# else /* ! HAS_UNSETENV */
1639 char *new_env;
c4420975
AL		 1640 const int nlen = strlen(nam);
1641 int vlen;
88f5bc07
AB		 1642 if (!val) {
1643 val = "";
1644 }
1645 vlen = strlen(val);
1646 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1647 /* all that work just for this */
1648 my_setenv_format(new_env, nam, nlen, val, vlen);
1649 (void)putenv(new_env);
1650# endif /* HAS_UNSETENV */
47dafe4d 1651# endif /* __CYGWIN__ */
50acdf95
MS		 1652#ifndef PERL_USE_SAFE_PUTENV
1653 }
1654#endif
4efc5df6 1655 }
8d063cd8
LW		 1656}
1657
c5d12488 1658#else /* WIN32 || NETWARE */
68dc0745 1659
1660void
72229eff 1661Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1662{
27da23d5 1663 dVAR;
c5d12488
JH		 1664 register char *envstr;
1665 const int nlen = strlen(nam);
1666 int vlen;
e6587932 1667
c5d12488
JH		 1668 if (!val) {
1669 val = "";
ac5c734f 1670 }
c5d12488
JH		 1671 vlen = strlen(val);
1672 Newx(envstr, nlen+vlen+2, char);
1673 my_setenv_format(envstr, nam, nlen, val, vlen);
1674 (void)PerlEnv_putenv(envstr);
1675 Safefree(envstr);
3e3baf6d
TB		 1676}
1677
c5d12488 1678#endif /* WIN32 || NETWARE */
3e3baf6d 1679
c5d12488 1680#ifndef PERL_MICRO
3e3baf6d 1681I32
e1ec3a88 1682Perl_setenv_getix(pTHX_ const char *nam)
3e3baf6d 1683{
c5d12488 1684 register I32 i;
0d46e09a 1685 register const I32 len = strlen(nam);
96a5add6 1686 PERL_UNUSED_CONTEXT;
3e3baf6d
TB		 1687
1688 for (i = 0; environ[i]; i++) {
1689 if (
1690#ifdef WIN32
1691 strnicmp(environ[i],nam,len) == 0
1692#else
1693 strnEQ(environ[i],nam,len)
1694#endif
1695 && environ[i][len] == '=')
1696 break; /* strnEQ must come first to avoid */
1697 } /* potential SEGV's */
1698 return i;
68dc0745 1699}
c5d12488 1700#endif /* !PERL_MICRO */
68dc0745 1701
c5d12488 1702#endif /* !VMS && !EPOC*/
378cc40b 1703
16d20bd9 1704#ifdef UNLINK_ALL_VERSIONS
79072805 1705I32
6e732051 1706Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 1707{
35da51f7 1708 I32 retries = 0;
378cc40b 1709
35da51f7
AL		 1710 while (PerlLIO_unlink(f) >= 0)
1711 retries++;
1712 return retries ? 0 : -1;
378cc40b
LW		 1713}
1714#endif
1715
7a3f2258 1716/* this is a drop-in replacement for bcopy() */
2253333f 1717#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1718char *
7a3f2258 1719Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b 1720{
2d03de9c 1721 char * const retval = to;
378cc40b 1722
7c0587c8
LW		 1723 if (from - to >= 0) {
1724 while (len--)
1725 *to++ = *from++;
1726 }
1727 else {
1728 to += len;
1729 from += len;
1730 while (len--)
faf8582f 1731 *(--to) = *(--from);
7c0587c8 1732 }
378cc40b
LW		 1733 return retval;
1734}
ffed7fef 1735#endif
378cc40b 1736
7a3f2258 1737/* this is a drop-in replacement for memset() */
fc36a67e 1738#ifndef HAS_MEMSET
1739void *
7a3f2258 1740Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1741{
2d03de9c 1742 char * const retval = loc;
fc36a67e 1743
1744 while (len--)
1745 *loc++ = ch;
1746 return retval;
1747}
1748#endif
1749
7a3f2258 1750/* this is a drop-in replacement for bzero() */
7c0587c8 1751#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1752char *
7a3f2258 1753Perl_my_bzero(register char *loc, register I32 len)
378cc40b 1754{
2d03de9c 1755 char * const retval = loc;
378cc40b
LW		 1756
1757 while (len--)
1758 *loc++ = 0;
1759 return retval;
1760}
1761#endif
7c0587c8 1762
7a3f2258 1763/* this is a drop-in replacement for memcmp() */
36477c24 1764#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1765I32
7a3f2258 1766Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1767{
e1ec3a88
AL		 1768 register const U8 *a = (const U8 *)s1;
1769 register const U8 *b = (const U8 *)s2;
79072805 1770 register I32 tmp;
7c0587c8
LW		 1771
1772 while (len--) {
27da23d5 1773 if ((tmp = *a++ - *b++))
7c0587c8
LW		 1774 return tmp;
1775 }
1776 return 0;
1777}
36477c24 1778#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1779
fe14fcc3 1780#ifndef HAS_VPRINTF
a687059c 1781
85e6fe83 1782#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1783char *
1784#else
1785int
1786#endif
08105a92 1787vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 1788{
1789 FILE fakebuf;
1790
1791 fakebuf._ptr = dest;
1792 fakebuf._cnt = 32767;
35c8bce7
LW		 1793#ifndef _IOSTRG
1794#define _IOSTRG 0
1795#endif
a687059c
LW		 1796 fakebuf._flag = _IOWRT|_IOSTRG;
1797 _doprnt(pat, args, &fakebuf); /* what a kludge */
1798 (void)putc('\0', &fakebuf);
85e6fe83 1799#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1800 return(dest);
1801#else
1802 return 0; /* perl doesn't use return value */
1803#endif
1804}
1805
fe14fcc3 1806#endif /* HAS_VPRINTF */
a687059c
LW		 1807
1808#ifdef MYSWAP
ffed7fef 1809#if BYTEORDER != 0x4321
a687059c 1810short
864dbfa3 1811Perl_my_swap(pTHX_ short s)
a687059c
LW		 1812{
1813#if (BYTEORDER & 1) == 0
1814 short result;
1815
1816 result = ((s & 255) << 8) + ((s >> 8) & 255);
1817 return result;
1818#else
1819 return s;
1820#endif
1821}
1822
1823long
864dbfa3 1824Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1825{
1826 union {
1827 long result;
ffed7fef 1828 char c[sizeof(long)];
a687059c
LW		 1829 } u;
1830
ffed7fef 1831#if BYTEORDER == 0x1234
a687059c
LW		 1832 u.c[0] = (l >> 24) & 255;
1833 u.c[1] = (l >> 16) & 255;
1834 u.c[2] = (l >> 8) & 255;
1835 u.c[3] = l & 255;
1836 return u.result;
1837#else
ffed7fef 1838#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1839 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1840#else
79072805
LW		 1841 register I32 o;
1842 register I32 s;
a687059c 1843
ffed7fef
LW		 1844 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1845 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1846 }
1847 return u.result;
1848#endif
1849#endif
1850}
1851
1852long
864dbfa3 1853Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1854{
1855 union {
1856 long l;
ffed7fef 1857 char c[sizeof(long)];
a687059c
LW		 1858 } u;
1859
ffed7fef 1860#if BYTEORDER == 0x1234
a687059c
LW		 1861 u.c[0] = (l >> 24) & 255;
1862 u.c[1] = (l >> 16) & 255;
1863 u.c[2] = (l >> 8) & 255;
1864 u.c[3] = l & 255;
1865 return u.l;
1866#else
ffed7fef 1867#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1868 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1869#else
79072805
LW		 1870 register I32 o;
1871 register I32 s;
a687059c
LW		 1872
1873 u.l = l;
1874 l = 0;
ffed7fef
LW		 1875 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1876 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1877 }
1878 return l;
1879#endif
1880#endif
1881}
1882
ffed7fef 1883#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1884#endif /* MYSWAP */
1885
1886/*
1887 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1888 * If these functions are defined,
1889 * the BYTEORDER is neither 0x1234 nor 0x4321.
1890 * However, this is not assumed.
1891 * -DWS
1892 */
1893
1109a392 1894#define HTOLE(name,type) \
988174c1 1895 type \
ba106d47 1896 name (register type n) \
988174c1
LW		 1897 { \
1898 union { \
1899 type value; \
1900 char c[sizeof(type)]; \
1901 } u; \
bb7a0f54
MHM		 1902 register U32 i; \
1903 register U32 s = 0; \
1109a392 1904 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW		 1905 u.c[i] = (n >> s) & 0xFF; \
1906 } \
1907 return u.value; \
1908 }
1909
1109a392 1910#define LETOH(name,type) \
988174c1 1911 type \
ba106d47 1912 name (register type n) \
988174c1
LW		 1913 { \
1914 union { \
1915 type value; \
1916 char c[sizeof(type)]; \
1917 } u; \
bb7a0f54
MHM		 1918 register U32 i; \
1919 register U32 s = 0; \
988174c1
LW		 1920 u.value = n; \
1921 n = 0; \
1109a392
MHM		 1922 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1923 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW		 1924 } \
1925 return n; \
1926 }
1927
1109a392
MHM		 1928/*
1929 * Big-endian byte order functions.
1930 */
1931
1932#define HTOBE(name,type) \
1933 type \
1934 name (register type n) \
1935 { \
1936 union { \
1937 type value; \
1938 char c[sizeof(type)]; \
1939 } u; \
bb7a0f54
MHM		 1940 register U32 i; \
1941 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 1942 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1943 u.c[i] = (n >> s) & 0xFF; \
1944 } \
1945 return u.value; \
1946 }
1947
1948#define BETOH(name,type) \
1949 type \
1950 name (register type n) \
1951 { \
1952 union { \
1953 type value; \
1954 char c[sizeof(type)]; \
1955 } u; \
bb7a0f54
MHM		 1956 register U32 i; \
1957 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 1958 u.value = n; \
1959 n = 0; \
1960 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1961 n |= ((type)(u.c[i] & 0xFF)) << s; \
1962 } \
1963 return n; \
1964 }
1965
1966/*
1967 * If we just can't do it...
1968 */
1969
1970#define NOT_AVAIL(name,type) \
1971 type \
1972 name (register type n) \
1973 { \
1974 Perl_croak_nocontext(#name "() not available"); \
1975 return n; /* not reached */ \
1976 }
1977
1978
988174c1 1979#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 1980HTOLE(htovs,short)
988174c1
LW		 1981#endif
1982#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 1983HTOLE(htovl,long)
988174c1
LW		 1984#endif
1985#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 1986LETOH(vtohs,short)
988174c1
LW		 1987#endif
1988#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM		 1989LETOH(vtohl,long)
1990#endif
1991
1992#ifdef PERL_NEED_MY_HTOLE16
1993# if U16SIZE == 2
1994HTOLE(Perl_my_htole16,U16)
1995# else
1996NOT_AVAIL(Perl_my_htole16,U16)
1997# endif
1998#endif
1999#ifdef PERL_NEED_MY_LETOH16
2000# if U16SIZE == 2
2001LETOH(Perl_my_letoh16,U16)
2002# else
2003NOT_AVAIL(Perl_my_letoh16,U16)
2004# endif
2005#endif
2006#ifdef PERL_NEED_MY_HTOBE16
2007# if U16SIZE == 2
2008HTOBE(Perl_my_htobe16,U16)
2009# else
2010NOT_AVAIL(Perl_my_htobe16,U16)
2011# endif
2012#endif
2013#ifdef PERL_NEED_MY_BETOH16
2014# if U16SIZE == 2
2015BETOH(Perl_my_betoh16,U16)
2016# else
2017NOT_AVAIL(Perl_my_betoh16,U16)
2018# endif
2019#endif
2020
2021#ifdef PERL_NEED_MY_HTOLE32
2022# if U32SIZE == 4
2023HTOLE(Perl_my_htole32,U32)
2024# else
2025NOT_AVAIL(Perl_my_htole32,U32)
2026# endif
2027#endif
2028#ifdef PERL_NEED_MY_LETOH32
2029# if U32SIZE == 4
2030LETOH(Perl_my_letoh32,U32)
2031# else
2032NOT_AVAIL(Perl_my_letoh32,U32)
2033# endif
2034#endif
2035#ifdef PERL_NEED_MY_HTOBE32
2036# if U32SIZE == 4
2037HTOBE(Perl_my_htobe32,U32)
2038# else
2039NOT_AVAIL(Perl_my_htobe32,U32)
2040# endif
2041#endif
2042#ifdef PERL_NEED_MY_BETOH32
2043# if U32SIZE == 4
2044BETOH(Perl_my_betoh32,U32)
2045# else
2046NOT_AVAIL(Perl_my_betoh32,U32)
2047# endif
2048#endif
2049
2050#ifdef PERL_NEED_MY_HTOLE64
2051# if U64SIZE == 8
2052HTOLE(Perl_my_htole64,U64)
2053# else
2054NOT_AVAIL(Perl_my_htole64,U64)
2055# endif
2056#endif
2057#ifdef PERL_NEED_MY_LETOH64
2058# if U64SIZE == 8
2059LETOH(Perl_my_letoh64,U64)
2060# else
2061NOT_AVAIL(Perl_my_letoh64,U64)
2062# endif
2063#endif
2064#ifdef PERL_NEED_MY_HTOBE64
2065# if U64SIZE == 8
2066HTOBE(Perl_my_htobe64,U64)
2067# else
2068NOT_AVAIL(Perl_my_htobe64,U64)
2069# endif
2070#endif
2071#ifdef PERL_NEED_MY_BETOH64
2072# if U64SIZE == 8
2073BETOH(Perl_my_betoh64,U64)
2074# else
2075NOT_AVAIL(Perl_my_betoh64,U64)
2076# endif
988174c1 2077#endif
a687059c 2078
1109a392
MHM		 2079#ifdef PERL_NEED_MY_HTOLES
2080HTOLE(Perl_my_htoles,short)
2081#endif
2082#ifdef PERL_NEED_MY_LETOHS
2083LETOH(Perl_my_letohs,short)
2084#endif
2085#ifdef PERL_NEED_MY_HTOBES
2086HTOBE(Perl_my_htobes,short)
2087#endif
2088#ifdef PERL_NEED_MY_BETOHS
2089BETOH(Perl_my_betohs,short)
2090#endif
2091
2092#ifdef PERL_NEED_MY_HTOLEI
2093HTOLE(Perl_my_htolei,int)
2094#endif
2095#ifdef PERL_NEED_MY_LETOHI
2096LETOH(Perl_my_letohi,int)
2097#endif
2098#ifdef PERL_NEED_MY_HTOBEI
2099HTOBE(Perl_my_htobei,int)
2100#endif
2101#ifdef PERL_NEED_MY_BETOHI
2102BETOH(Perl_my_betohi,int)
2103#endif
2104
2105#ifdef PERL_NEED_MY_HTOLEL
2106HTOLE(Perl_my_htolel,long)
2107#endif
2108#ifdef PERL_NEED_MY_LETOHL
2109LETOH(Perl_my_letohl,long)
2110#endif
2111#ifdef PERL_NEED_MY_HTOBEL
2112HTOBE(Perl_my_htobel,long)
2113#endif
2114#ifdef PERL_NEED_MY_BETOHL
2115BETOH(Perl_my_betohl,long)
2116#endif
2117
2118void
2119Perl_my_swabn(void *ptr, int n)
2120{
2121 register char *s = (char *)ptr;
2122 register char *e = s + (n-1);
2123 register char tc;
2124
2125 for (n /= 2; n > 0; s++, e--, n--) {
2126 tc = *s;
2127 *s = *e;
2128 *e = tc;
2129 }
2130}
2131
4a7d1889
NIS		 2132PerlIO *
2133Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2134{
2986a63f 2135#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
97aff369 2136 dVAR;
1f852d0d
NIS		 2137 int p[2];
2138 register I32 This, that;
2139 register Pid_t pid;
2140 SV *sv;
2141 I32 did_pipes = 0;
2142 int pp[2];
2143
2144 PERL_FLUSHALL_FOR_CHILD;
2145 This = (*mode == 'w');
2146 that = !This;
2147 if (PL_tainting) {
2148 taint_env();
2149 taint_proper("Insecure %s%s", "EXEC");
2150 }
2151 if (PerlProc_pipe(p) < 0)
4608196e 2152 return NULL;
1f852d0d
NIS		 2153 /* Try for another pipe pair for error return */
2154 if (PerlProc_pipe(pp) >= 0)
2155 did_pipes = 1;
52e18b1f 2156 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 2157 if (errno != EAGAIN) {
2158 PerlLIO_close(p[This]);
4e6dfe71 2159 PerlLIO_close(p[that]);
1f852d0d
NIS		 2160 if (did_pipes) {
2161 PerlLIO_close(pp[0]);
2162 PerlLIO_close(pp[1]);
2163 }
4608196e 2164 return NULL;
1f852d0d
NIS		 2165 }
2166 sleep(5);
2167 }
2168 if (pid == 0) {
2169 /* Child */
1f852d0d
NIS		 2170#undef THIS
2171#undef THAT
2172#define THIS that
2173#define THAT This
1f852d0d
NIS		 2174 /* Close parent's end of error status pipe (if any) */
2175 if (did_pipes) {
2176 PerlLIO_close(pp[0]);
2177#if defined(HAS_FCNTL) && defined(F_SETFD)
2178 /* Close error pipe automatically if exec works */
2179 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2180#endif
2181 }
2182 /* Now dup our end of _the_ pipe to right position */
2183 if (p[THIS] != (*mode == 'r')) {
2184 PerlLIO_dup2(p[THIS], *mode == 'r');
2185 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 2186 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2187 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2188 }
4e6dfe71
GS		 2189 else
2190 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2191#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2192 /* No automatic close - do it by hand */
b7953727
JH		 2193# ifndef NOFILE
2194# define NOFILE 20
2195# endif
a080fe3d
NIS		 2196 {
2197 int fd;
2198
2199 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2200 if (fd != pp[1])
a080fe3d
NIS		 2201 PerlLIO_close(fd);
2202 }
1f852d0d
NIS		 2203 }
2204#endif
a0714e2c 2205 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS		 2206 PerlProc__exit(1);
2207#undef THIS
2208#undef THAT
2209 }
2210 /* Parent */
52e18b1f 2211 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2212 if (did_pipes)
2213 PerlLIO_close(pp[1]);
2214 /* Keep the lower of the two fd numbers */
2215 if (p[that] < p[This]) {
2216 PerlLIO_dup2(p[This], p[that]);
2217 PerlLIO_close(p[This]);
2218 p[This] = p[that];
2219 }
4e6dfe71
GS		 2220 else
2221 PerlLIO_close(p[that]); /* close child's end of pipe */
2222
1f852d0d
NIS		 2223 LOCK_FDPID_MUTEX;
2224 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2225 UNLOCK_FDPID_MUTEX;
862a34c6 2226 SvUPGRADE(sv,SVt_IV);
45977657 2227 SvIV_set(sv, pid);
1f852d0d
NIS		 2228 PL_forkprocess = pid;
2229 /* If we managed to get status pipe check for exec fail */
2230 if (did_pipes && pid > 0) {
2231 int errkid;
bb7a0f54
MHM		 2232 unsigned n = 0;
2233 SSize_t n1;
1f852d0d
NIS		 2234
2235 while (n < sizeof(int)) {
2236 n1 = PerlLIO_read(pp[0],
2237 (void*)(((char*)&errkid)+n),
2238 (sizeof(int)) - n);
2239 if (n1 <= 0)
2240 break;
2241 n += n1;
2242 }
2243 PerlLIO_close(pp[0]);
2244 did_pipes = 0;
2245 if (n) { /* Error */
2246 int pid2, status;
8c51524e 2247 PerlLIO_close(p[This]);
1f852d0d
NIS		 2248 if (n != sizeof(int))
2249 Perl_croak(aTHX_ "panic: kid popen errno read");
2250 do {
2251 pid2 = wait4pid(pid, &status, 0);
2252 } while (pid2 == -1 && errno == EINTR);
2253 errno = errkid; /* Propagate errno from kid */
4608196e 2254 return NULL;
1f852d0d
NIS		 2255 }
2256 }
2257 if (did_pipes)
2258 PerlLIO_close(pp[0]);
2259 return PerlIO_fdopen(p[This], mode);
2260#else
4a7d1889
NIS		 2261 Perl_croak(aTHX_ "List form of piped open not implemented");
2262 return (PerlIO *) NULL;
1f852d0d 2263#endif
4a7d1889
NIS		 2264}
2265
5f05dabc 2266 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2267#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2268PerlIO *
3dd43144 2269Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2270{
97aff369 2271 dVAR;
a687059c 2272 int p[2];
8ac85365 2273 register I32 This, that;
d8a83dd3 2274 register Pid_t pid;
79072805 2275 SV *sv;
bfce84ec 2276 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2277 I32 did_pipes = 0;
2278 int pp[2];
a687059c 2279
45bc9206 2280 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2281#ifdef OS2
2282 if (doexec) {
23da6c43 2283 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2284 }
a1d180c4 2285#endif
8ac85365
NIS		 2286 This = (*mode == 'w');
2287 that = !This;
3280af22 2288 if (doexec && PL_tainting) {
bbce6d69 2289 taint_env();
2290 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2291 }
c2267164 2292 if (PerlProc_pipe(p) < 0)
4608196e 2293 return NULL;
e446cec8
IZ		 2294 if (doexec && PerlProc_pipe(pp) >= 0)
2295 did_pipes = 1;
52e18b1f 2296 while ((pid = PerlProc_fork()) < 0) {
a687059c 2297 if (errno != EAGAIN) {
6ad3d225 2298 PerlLIO_close(p[This]);
b5ac89c3 2299 PerlLIO_close(p[that]);
e446cec8
IZ		 2300 if (did_pipes) {
2301 PerlLIO_close(pp[0]);
2302 PerlLIO_close(pp[1]);
2303 }
a687059c 2304 if (!doexec)
cea2e8a9 2305 Perl_croak(aTHX_ "Can't fork");
4608196e 2306 return NULL;
a687059c
LW		 2307 }
2308 sleep(5);
2309 }
2310 if (pid == 0) {
79072805
LW		 2311 GV* tmpgv;
2312
30ac6d9b
GS		 2313#undef THIS
2314#undef THAT
a687059c 2315#define THIS that
8ac85365 2316#define THAT This
e446cec8
IZ		 2317 if (did_pipes) {
2318 PerlLIO_close(pp[0]);
2319#if defined(HAS_FCNTL) && defined(F_SETFD)
2320 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2321#endif
2322 }
a687059c 2323 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2324 PerlLIO_dup2(p[THIS], *mode == 'r');
2325 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2326 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2327 PerlLIO_close(p[THAT]);
a687059c 2328 }
b5ac89c3
NIS		 2329 else
2330 PerlLIO_close(p[THAT]);
4435c477 2331#ifndef OS2
a687059c 2332 if (doexec) {
a0d0e21e 2333#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2334#ifndef NOFILE
2335#define NOFILE 20
2336#endif
a080fe3d 2337 {
3aed30dc 2338 int fd;
a080fe3d
NIS		 2339
2340 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2341 if (fd != pp[1])
3aed30dc 2342 PerlLIO_close(fd);
a080fe3d 2343 }
ae986130 2344#endif
a080fe3d
NIS		 2345 /* may or may not use the shell */
2346 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2347 PerlProc__exit(1);
a687059c 2348 }
4435c477 2349#endif /* defined OS2 */
fafc274c 2350 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2351 SvREADONLY_off(GvSV(tmpgv));
7766f137 2352 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2353 SvREADONLY_on(GvSV(tmpgv));
2354 }
2355#ifdef THREADS_HAVE_PIDS
2356 PL_ppid = (IV)getppid();
2357#endif
3280af22 2358 PL_forkprocess = 0;
ca0c25f6 2359#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2360 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2361#endif
4608196e 2362 return NULL;
a687059c
LW		 2363#undef THIS
2364#undef THAT
2365 }
b5ac89c3 2366 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2367 if (did_pipes)
2368 PerlLIO_close(pp[1]);
8ac85365 2369 if (p[that] < p[This]) {
6ad3d225
GS		 2370 PerlLIO_dup2(p[This], p[that]);
2371 PerlLIO_close(p[This]);
8ac85365 2372 p[This] = p[that];
62b28dd9 2373 }
b5ac89c3
NIS		 2374 else
2375 PerlLIO_close(p[that]);
2376
4755096e 2377 LOCK_FDPID_MUTEX;
3280af22 2378 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2379 UNLOCK_FDPID_MUTEX;
862a34c6 2380 SvUPGRADE(sv,SVt_IV);
45977657 2381 SvIV_set(sv, pid);
3280af22 2382 PL_forkprocess = pid;
e446cec8
IZ		 2383 if (did_pipes && pid > 0) {
2384 int errkid;
bb7a0f54
MHM		 2385 unsigned n = 0;
2386 SSize_t n1;
e446cec8
IZ		 2387
2388 while (n < sizeof(int)) {
2389 n1 = PerlLIO_read(pp[0],
2390 (void*)(((char*)&errkid)+n),
2391 (sizeof(int)) - n);
2392 if (n1 <= 0)
2393 break;
2394 n += n1;
2395 }
2f96c702
IZ		 2396 PerlLIO_close(pp[0]);
2397 did_pipes = 0;
e446cec8 2398 if (n) { /* Error */
faa466a7 2399 int pid2, status;
8c51524e 2400 PerlLIO_close(p[This]);
e446cec8 2401 if (n != sizeof(int))
cea2e8a9 2402 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2403 do {
2404 pid2 = wait4pid(pid, &status, 0);
2405 } while (pid2 == -1 && errno == EINTR);
e446cec8 2406 errno = errkid; /* Propagate errno from kid */
4608196e 2407 return NULL;
e446cec8
IZ		 2408 }
2409 }
2410 if (did_pipes)
2411 PerlLIO_close(pp[0]);
8ac85365 2412 return PerlIO_fdopen(p[This], mode);
a687059c 2413}
7c0587c8 2414#else
85ca448a 2415#if defined(atarist) || defined(EPOC)
7c0587c8 2416FILE *popen();
760ac839 2417PerlIO *
864dbfa3 2418Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2419{
45bc9206 2420 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2421 /* Call system's popen() to get a FILE *, then import it.
2422 used 0 for 2nd parameter to PerlIO_importFILE;
2423 apparently not used
2424 */
2425 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2426}
2b96b0a5
JH		 2427#else
2428#if defined(DJGPP)
2429FILE *djgpp_popen();
2430PerlIO *
2431Perl_my_popen(pTHX_ char *cmd, char *mode)
2432{
2433 PERL_FLUSHALL_FOR_CHILD;
2434 /* Call system's popen() to get a FILE *, then import it.
2435 used 0 for 2nd parameter to PerlIO_importFILE;
2436 apparently not used
2437 */
2438 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2439}
2440#endif
7c0587c8
LW		 2441#endif
2442
2443#endif /* !DOSISH */
a687059c 2444
52e18b1f
GS		 2445/* this is called in parent before the fork() */
2446void
2447Perl_atfork_lock(void)
2448{
27da23d5 2449 dVAR;
3db8f154 2450#if defined(USE_ITHREADS)
52e18b1f
GS		 2451 /* locks must be held in locking order (if any) */
2452# ifdef MYMALLOC
2453 MUTEX_LOCK(&PL_malloc_mutex);
2454# endif
2455 OP_REFCNT_LOCK;
2456#endif
2457}
2458
2459/* this is called in both parent and child after the fork() */
2460void
2461Perl_atfork_unlock(void)
2462{
27da23d5 2463 dVAR;
3db8f154 2464#if defined(USE_ITHREADS)
52e18b1f
GS		 2465 /* locks must be released in same order as in atfork_lock() */
2466# ifdef MYMALLOC
2467 MUTEX_UNLOCK(&PL_malloc_mutex);
2468# endif
2469 OP_REFCNT_UNLOCK;
2470#endif
2471}
2472
2473Pid_t
2474Perl_my_fork(void)
2475{
2476#if defined(HAS_FORK)
2477 Pid_t pid;
3db8f154 2478#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2479 atfork_lock();
2480 pid = fork();
2481 atfork_unlock();
2482#else
2483 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2484 * handlers elsewhere in the code */
2485 pid = fork();
2486#endif
2487 return pid;
2488#else
2489 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2490 Perl_croak_nocontext("fork() not available");
b961a566 2491 return 0;
52e18b1f
GS		 2492#endif /* HAS_FORK */
2493}
2494
748a9306 2495#ifdef DUMP_FDS
35ff7856 2496void
864dbfa3 2497Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2498{
2499 int fd;
c623ac67 2500 Stat_t tmpstatbuf;
ae986130 2501
bf49b057 2502 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2503 for (fd = 0; fd < 32; fd++) {
6ad3d225 2504 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2505 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2506 }
bf49b057 2507 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2508 return;
ae986130 2509}
35ff7856 2510#endif /* DUMP_FDS */
ae986130 2511
fe14fcc3 2512#ifndef HAS_DUP2
fec02dd3 2513int
ba106d47 2514dup2(int oldfd, int newfd)
a687059c 2515{
a0d0e21e 2516#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2517 if (oldfd == newfd)
2518 return oldfd;
6ad3d225 2519 PerlLIO_close(newfd);
fec02dd3 2520 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2521#else
fc36a67e 2522#define DUP2_MAX_FDS 256
2523 int fdtmp[DUP2_MAX_FDS];
79072805 2524 I32 fdx = 0;
ae986130
LW		 2525 int fd;
2526
fe14fcc3 2527 if (oldfd == newfd)
fec02dd3 2528 return oldfd;
6ad3d225 2529 PerlLIO_close(newfd);
fc36a67e 2530 /* good enough for low fd's... */
6ad3d225 2531 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2532 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2533 PerlLIO_close(fd);
fc36a67e 2534 fd = -1;
2535 break;
2536 }
ae986130 2537 fdtmp[fdx++] = fd;
fc36a67e 2538 }
ae986130 2539 while (fdx > 0)
6ad3d225 2540 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2541 return fd;
62b28dd9 2542#endif
a687059c
LW		 2543}
2544#endif
2545
64ca3a65 2546#ifndef PERL_MICRO
ff68c719 2547#ifdef HAS_SIGACTION
2548
abea2c45
HS		 2549#ifdef MACOS_TRADITIONAL
2550/* We don't want restart behavior on MacOS */
2551#undef SA_RESTART
2552#endif
2553
ff68c719 2554Sighandler_t
864dbfa3 2555Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2556{
27da23d5 2557 dVAR;
ff68c719 2558 struct sigaction act, oact;
2559
a10b1e10
JH		 2560#ifdef USE_ITHREADS
2561 /* only "parent" interpreter can diddle signals */
2562 if (PL_curinterp != aTHX)
8aad04aa 2563 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2564#endif
2565
8aad04aa 2566 act.sa_handler = (void(*)(int))handler;
ff68c719 2567 sigemptyset(&act.sa_mask);
2568 act.sa_flags = 0;
2569#ifdef SA_RESTART
4ffa73a3
JH		 2570 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2571 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2572#endif
358837b8 2573#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2574 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2575 act.sa_flags |= SA_NOCLDWAIT;
2576#endif
ff68c719 2577 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2578 return (Sighandler_t) SIG_ERR;
ff68c719 2579 else
8aad04aa 2580 return (Sighandler_t) oact.sa_handler;
ff68c719 2581}
2582
2583Sighandler_t
864dbfa3 2584Perl_rsignal_state(pTHX_ int signo)
ff68c719 2585{
2586 struct sigaction oact;
96a5add6 2587 PERL_UNUSED_CONTEXT;
ff68c719 2588
2589 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2590 return (Sighandler_t) SIG_ERR;
ff68c719 2591 else
8aad04aa 2592 return (Sighandler_t) oact.sa_handler;
ff68c719 2593}
2594
2595int
864dbfa3 2596Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2597{
27da23d5 2598 dVAR;
ff68c719 2599 struct sigaction act;
2600
a10b1e10
JH		 2601#ifdef USE_ITHREADS
2602 /* only "parent" interpreter can diddle signals */
2603 if (PL_curinterp != aTHX)
2604 return -1;
2605#endif
2606
8aad04aa 2607 act.sa_handler = (void(*)(int))handler;
ff68c719 2608 sigemptyset(&act.sa_mask);
2609 act.sa_flags = 0;
2610#ifdef SA_RESTART
4ffa73a3
JH		 2611 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2612 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2613#endif
36b5d377 2614#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2615 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2616 act.sa_flags |= SA_NOCLDWAIT;
2617#endif
ff68c719 2618 return sigaction(signo, &act, save);
2619}
2620
2621int
864dbfa3 2622Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2623{
27da23d5 2624 dVAR;
a10b1e10
JH		 2625#ifdef USE_ITHREADS
2626 /* only "parent" interpreter can diddle signals */
2627 if (PL_curinterp != aTHX)
2628 return -1;
2629#endif
2630
ff68c719 2631 return sigaction(signo, save, (struct sigaction *)NULL);
2632}
2633
2634#else /* !HAS_SIGACTION */
2635
2636Sighandler_t
864dbfa3 2637Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2638{
39f1703b 2639#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2640 /* only "parent" interpreter can diddle signals */
2641 if (PL_curinterp != aTHX)
8aad04aa 2642 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2643#endif
2644
6ad3d225 2645 return PerlProc_signal(signo, handler);
ff68c719 2646}
2647
fabdb6c0 2648static Signal_t
4e35701f 2649sig_trap(int signo)
ff68c719 2650{
27da23d5
JH		 2651 dVAR;
2652 PL_sig_trapped++;
ff68c719 2653}
2654
2655Sighandler_t
864dbfa3 2656Perl_rsignal_state(pTHX_ int signo)
ff68c719 2657{
27da23d5 2658 dVAR;
ff68c719 2659 Sighandler_t oldsig;
2660
39f1703b 2661#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2662 /* only "parent" interpreter can diddle signals */
2663 if (PL_curinterp != aTHX)
8aad04aa 2664 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2665#endif
2666
27da23d5 2667 PL_sig_trapped = 0;
6ad3d225
GS		 2668 oldsig = PerlProc_signal(signo, sig_trap);
2669 PerlProc_signal(signo, oldsig);
27da23d5 2670 if (PL_sig_trapped)
3aed30dc 2671 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2672 return oldsig;
2673}
2674
2675int
864dbfa3 2676Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2677{
39f1703b 2678#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2679 /* only "parent" interpreter can diddle signals */
2680 if (PL_curinterp != aTHX)
2681 return -1;
2682#endif
6ad3d225 2683 *save = PerlProc_signal(signo, handler);
8aad04aa 2684 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2685}
2686
2687int
864dbfa3 2688Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2689{
39f1703b 2690#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2691 /* only "parent" interpreter can diddle signals */
2692 if (PL_curinterp != aTHX)
2693 return -1;
2694#endif
8aad04aa 2695 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2696}
2697
2698#endif /* !HAS_SIGACTION */
64ca3a65 2699#endif /* !PERL_MICRO */
ff68c719 2700
5f05dabc 2701 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2702#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2703I32
864dbfa3 2704Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2705{
97aff369 2706 dVAR;
ff68c719 2707 Sigsave_t hstat, istat, qstat;
a687059c 2708 int status;
a0d0e21e 2709 SV **svp;
d8a83dd3
JH		 2710 Pid_t pid;
2711 Pid_t pid2;
03136e13 2712 bool close_failed;
b7953727 2713 int saved_errno = 0;
22fae026
TM		 2714#ifdef WIN32
2715 int saved_win32_errno;
2716#endif
a687059c 2717
4755096e 2718 LOCK_FDPID_MUTEX;
3280af22 2719 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2720 UNLOCK_FDPID_MUTEX;
25d92023 2721 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2722 SvREFCNT_dec(*svp);
3280af22 2723 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2724#ifdef OS2
2725 if (pid == -1) { /* Opened by popen. */
2726 return my_syspclose(ptr);
2727 }
a1d180c4 2728#endif
03136e13
CS		 2729 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2730 saved_errno = errno;
22fae026
TM		 2731#ifdef WIN32
2732 saved_win32_errno = GetLastError();
2733#endif
03136e13 2734 }
7c0587c8 2735#ifdef UTS
6ad3d225 2736 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2737#endif
64ca3a65 2738#ifndef PERL_MICRO
8aad04aa
JH		 2739 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2740 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2741 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 2742#endif
748a9306 2743 do {
1d3434b8
GS		 2744 pid2 = wait4pid(pid, &status, 0);
2745 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2746#ifndef PERL_MICRO
ff68c719 2747 rsignal_restore(SIGHUP, &hstat);
2748 rsignal_restore(SIGINT, &istat);
2749 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2750#endif
03136e13 2751 if (close_failed) {
ce6e1103 2752 SETERRNO(saved_errno, 0);
03136e13
CS		 2753 return -1;
2754 }
1d3434b8 2755 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2756}
4633a7c4
LW		 2757#endif /* !DOSISH */
2758
2986a63f 2759#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2760I32
d8a83dd3 2761Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2762{
97aff369 2763 dVAR;
27da23d5 2764 I32 result = 0;
b7953727
JH		 2765 if (!pid)
2766 return -1;
ca0c25f6 2767#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2768 {
3aed30dc 2769 if (pid > 0) {
12072db5
NC		 2770 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2771 pid, rather than a string form. */
c4420975 2772 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 2773 if (svp && *svp != &PL_sv_undef) {
2774 *statusp = SvIVX(*svp);
12072db5
NC		 2775 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2776 G_DISCARD);
3aed30dc
HS		 2777 return pid;
2778 }
2779 }
2780 else {
2781 HE *entry;
2782
2783 hv_iterinit(PL_pidstatus);
2784 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2785 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2786 I32 len;
0bcc34c2 2787 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2788
12072db5
NC		 2789 assert (len == sizeof(Pid_t));
2790 memcpy((char *)&pid, spid, len);
3aed30dc 2791 *statusp = SvIVX(sv);
7b9a3241
NC		 2792 /* The hash iterator is currently on this entry, so simply
2793 calling hv_delete would trigger the lazy delete, which on
2794 aggregate does more work, beacuse next call to hv_iterinit()
2795 would spot the flag, and have to call the delete routine,
2796 while in the meantime any new entries can't re-use that
2797 memory. */
2798 hv_iterinit(PL_pidstatus);
7ea75b61 2799 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 2800 return pid;
2801 }
20188a90
LW		 2802 }
2803 }
68a29c53 2804#endif
79072805 2805#ifdef HAS_WAITPID
367f3c24
IZ		 2806# ifdef HAS_WAITPID_RUNTIME
2807 if (!HAS_WAITPID_RUNTIME)
2808 goto hard_way;
2809# endif
cddd4526 2810 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2811 goto finish;
367f3c24
IZ		 2812#endif
2813#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2814 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2815 goto finish;
367f3c24 2816#endif
ca0c25f6 2817#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2818#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2819 hard_way:
27da23d5 2820#endif
a0d0e21e 2821 {
a0d0e21e 2822 if (flags)
cea2e8a9 2823 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2824 else {
76e3520e 2825 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2826 pidgone(result,*statusp);
2827 if (result < 0)
2828 *statusp = -1;
2829 }
a687059c
LW		 2830 }
2831#endif
27da23d5 2832#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2833 finish:
27da23d5 2834#endif
cddd4526
NIS		 2835 if (result < 0 && errno == EINTR) {
2836 PERL_ASYNC_CHECK();
2837 }
2838 return result;
a687059c 2839}
2986a63f 2840#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2841
ca0c25f6 2842#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2843void
d8a83dd3 2844Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2845{
79072805 2846 register SV *sv;
a687059c 2847
12072db5 2848 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2849 SvUPGRADE(sv,SVt_IV);
45977657 2850 SvIV_set(sv, status);
20188a90 2851 return;
a687059c 2852}
ca0c25f6 2853#endif
a687059c 2854
85ca448a 2855#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2856int pclose();
ddcf38b7
IZ		 2857#ifdef HAS_FORK
2858int /* Cannot prototype with I32
2859 in os2ish.h. */
ba106d47 2860my_syspclose(PerlIO *ptr)
ddcf38b7 2861#else
79072805 2862I32
864dbfa3 2863Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2864#endif
a687059c 2865{
760ac839 2866 /* Needs work for PerlIO ! */
c4420975 2867 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 2868 const I32 result = pclose(f);
2b96b0a5
JH		 2869 PerlIO_releaseFILE(ptr,f);
2870 return result;
2871}
2872#endif
2873
933fea7f 2874#if defined(DJGPP)
2b96b0a5
JH		 2875int djgpp_pclose();
2876I32
2877Perl_my_pclose(pTHX_ PerlIO *ptr)
2878{
2879 /* Needs work for PerlIO ! */
c4420975 2880 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 2881 I32 result = djgpp_pclose(f);
933fea7f 2882 result = (result << 8) & 0xff00;
760ac839
LW		 2883 PerlIO_releaseFILE(ptr,f);
2884 return result;
a687059c 2885}
7c0587c8 2886#endif
9f68db38
LW		 2887
2888void
864dbfa3 2889Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2890{
79072805 2891 register I32 todo;
c4420975 2892 register const char * const frombase = from;
96a5add6 2893 PERL_UNUSED_CONTEXT;
9f68db38
LW		 2894
2895 if (len == 1) {
08105a92 2896 register const char c = *from;
9f68db38 2897 while (count-- > 0)
5926133d 2898 *to++ = c;
9f68db38
LW		 2899 return;
2900 }
2901 while (count-- > 0) {
2902 for (todo = len; todo > 0; todo--) {
2903 *to++ = *from++;
2904 }
2905 from = frombase;
2906 }
2907}
0f85fab0 2908
fe14fcc3 2909#ifndef HAS_RENAME
79072805 2910I32
4373e329 2911Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 2912{
93a17b20
LW		 2913 char *fa = strrchr(a,'/');
2914 char *fb = strrchr(b,'/');
c623ac67
GS		 2915 Stat_t tmpstatbuf1;
2916 Stat_t tmpstatbuf2;
c4420975 2917 SV * const tmpsv = sv_newmortal();
62b28dd9
LW		 2918
2919 if (fa)
2920 fa++;
2921 else
2922 fa = a;
2923 if (fb)
2924 fb++;
2925 else
2926 fb = b;
2927 if (strNE(a,b))
2928 return FALSE;
2929 if (fa == a)
616d8c9c 2930 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2931 else
46fc3d4c 2932 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 2933 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2934 return FALSE;
2935 if (fb == b)
616d8c9c 2936 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2937 else
46fc3d4c 2938 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 2939 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2940 return FALSE;
2941 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2942 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2943}
fe14fcc3
LW		 2944#endif /* !HAS_RENAME */
2945
491527d0 2946char*
7f315aed
NC		 2947Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2948 const char *const *const search_ext, I32 flags)
491527d0 2949{
97aff369 2950 dVAR;
bd61b366
SS		 2951 const char *xfound = NULL;
2952 char *xfailed = NULL;
0f31cffe 2953 char tmpbuf[MAXPATHLEN];
491527d0 2954 register char *s;
5f74f29c 2955 I32 len = 0;
491527d0
GS		 2956 int retval;
2957#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2958# define SEARCH_EXTS ".bat", ".cmd", NULL
2959# define MAX_EXT_LEN 4
2960#endif
2961#ifdef OS2
2962# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2963# define MAX_EXT_LEN 4
2964#endif
2965#ifdef VMS
2966# define SEARCH_EXTS ".pl", ".com", NULL
2967# define MAX_EXT_LEN 4
2968#endif
2969 /* additional extensions to try in each dir if scriptname not found */
2970#ifdef SEARCH_EXTS
0bcc34c2 2971 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 2972 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 2973 int extidx = 0, i = 0;
bd61b366 2974 const char *curext = NULL;
491527d0 2975#else
53c1dcc0 2976 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 2977# define MAX_EXT_LEN 0
2978#endif
2979
2980 /*
2981 * If dosearch is true and if scriptname does not contain path
2982 * delimiters, search the PATH for scriptname.
2983 *
2984 * If SEARCH_EXTS is also defined, will look for each
2985 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2986 * while searching the PATH.
2987 *
2988 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2989 * proceeds as follows:
2990 * If DOSISH or VMSISH:
2991 * + look for ./scriptname{,.foo,.bar}
2992 * + search the PATH for scriptname{,.foo,.bar}
2993 *
2994 * If !DOSISH:
2995 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2996 * this will not look in '.' if it's not in the PATH)
2997 */
84486fc6 2998 tmpbuf[0] = '\0';
491527d0
GS		 2999
3000#ifdef VMS
3001# ifdef ALWAYS_DEFTYPES
3002 len = strlen(scriptname);
3003 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3004 int idx = 0, deftypes = 1;
491527d0
GS		 3005 bool seen_dot = 1;
3006
bd61b366 3007 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3008# else
3009 if (dosearch) {
c4420975 3010 int idx = 0, deftypes = 1;
491527d0
GS		 3011 bool seen_dot = 1;
3012
bd61b366 3013 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3014# endif
3015 /* The first time through, just add SEARCH_EXTS to whatever we
3016 * already have, so we can check for default file types. */
3017 while (deftypes ||
84486fc6 3018 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3019 {
3020 if (deftypes) {
3021 deftypes = 0;
84486fc6 3022 *tmpbuf = '\0';
491527d0 3023 }
84486fc6
GS		 3024 if ((strlen(tmpbuf) + strlen(scriptname)
3025 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3026 continue; /* don't search dir with too-long name */
6fca0082 3027 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS		 3028#else /* !VMS */
3029
3030#ifdef DOSISH
3031 if (strEQ(scriptname, "-"))
3032 dosearch = 0;
3033 if (dosearch) { /* Look in '.' first. */
fe2774ed 3034 const char *cur = scriptname;
491527d0
GS		 3035#ifdef SEARCH_EXTS
3036 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3037 while (ext[i])
3038 if (strEQ(ext[i++],curext)) {
3039 extidx = -1; /* already has an ext */
3040 break;
3041 }
3042 do {
3043#endif
3044 DEBUG_p(PerlIO_printf(Perl_debug_log,
3045 "Looking for %s\n",cur));
017f25f1
IZ		 3046 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3047 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3048 dosearch = 0;
3049 scriptname = cur;
3050#ifdef SEARCH_EXTS
3051 break;
3052#endif
3053 }
3054#ifdef SEARCH_EXTS
3055 if (cur == scriptname) {
3056 len = strlen(scriptname);
84486fc6 3057 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3058 break;
9e4425f7
SH		 3059 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3060 cur = tmpbuf;
491527d0
GS		 3061 }
3062 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3063 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS		 3064#endif
3065 }
3066#endif
3067
cd39f2b6
JH		 3068#ifdef MACOS_TRADITIONAL
3069 if (dosearch && !strchr(scriptname, ':') &&
3070 (s = PerlEnv_getenv("Commands")))
3071#else
491527d0
GS		 3072 if (dosearch && !strchr(scriptname, '/')
3073#ifdef DOSISH
3074 && !strchr(scriptname, '\\')
3075#endif
cd39f2b6
JH		 3076 && (s = PerlEnv_getenv("PATH")))
3077#endif
3078 {
491527d0 3079 bool seen_dot = 0;
92f0c265 3080
3280af22
NIS		 3081 PL_bufend = s + strlen(s);
3082 while (s < PL_bufend) {
cd39f2b6
JH		 3083#ifdef MACOS_TRADITIONAL
3084 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3085 ',',
3086 &len);
3087#else
491527d0
GS		 3088#if defined(atarist) || defined(DOSISH)
3089 for (len = 0; *s
3090# ifdef atarist
3091 && *s != ','
3092# endif
3093 && *s != ';'; len++, s++) {
84486fc6
GS		 3094 if (len < sizeof tmpbuf)
3095 tmpbuf[len] = *s;
491527d0 3096 }
84486fc6
GS		 3097 if (len < sizeof tmpbuf)
3098 tmpbuf[len] = '\0';
491527d0 3099#else /* ! (atarist || DOSISH) */
3280af22 3100 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 3101 ':',
3102 &len);
3103#endif /* ! (atarist || DOSISH) */
cd39f2b6 3104#endif /* MACOS_TRADITIONAL */
3280af22 3105 if (s < PL_bufend)
491527d0 3106 s++;
84486fc6 3107 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 3108 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 3109#ifdef MACOS_TRADITIONAL
3110 if (len && tmpbuf[len - 1] != ':')
3111 tmpbuf[len++] = ':';
3112#else
491527d0 3113 if (len
490a0e98 3114# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 3115 && tmpbuf[len - 1] != '/'
3116 && tmpbuf[len - 1] != '\\'
490a0e98 3117# endif
491527d0 3118 )
84486fc6
GS		 3119 tmpbuf[len++] = '/';
3120 if (len == 2 && tmpbuf[0] == '.')
491527d0 3121 seen_dot = 1;
cd39f2b6 3122#endif
28f0d0ec 3123 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS		 3124#endif /* !VMS */
3125
3126#ifdef SEARCH_EXTS
84486fc6 3127 len = strlen(tmpbuf);
491527d0
GS		 3128 if (extidx > 0) /* reset after previous loop */
3129 extidx = 0;
3130 do {
3131#endif
84486fc6 3132 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3133 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3134 if (S_ISDIR(PL_statbuf.st_mode)) {
3135 retval = -1;
3136 }
491527d0
GS		 3137#ifdef SEARCH_EXTS
3138 } while ( retval < 0 /* not there */
3139 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3140 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS		 3141 );
3142#endif
3143 if (retval < 0)
3144 continue;
3280af22
NIS		 3145 if (S_ISREG(PL_statbuf.st_mode)
3146 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 3147#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 3148 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3149#endif
3150 )
3151 {
3aed30dc 3152 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3153 break;
3154 }
3155 if (!xfailed)
84486fc6 3156 xfailed = savepv(tmpbuf);
491527d0
GS		 3157 }
3158#ifndef DOSISH
017f25f1 3159 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3160 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3161 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3162#endif
3163 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3164 if (!xfound) {
3165 if (flags & 1) { /* do or die? */
3aed30dc 3166 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3167 (xfailed ? "execute" : "find"),
3168 (xfailed ? xfailed : scriptname),
3169 (xfailed ? "" : " on PATH"),
3170 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3171 }
bd61b366 3172 scriptname = NULL;
9ccb31f9 3173 }
43c5f42d 3174 Safefree(xfailed);
491527d0
GS		 3175 scriptname = xfound;
3176 }
bd61b366 3177 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3178}
3179
ba869deb
GS		 3180#ifndef PERL_GET_CONTEXT_DEFINED
3181
3182void *
3183Perl_get_context(void)
3184{
27da23d5 3185 dVAR;
3db8f154 3186#if defined(USE_ITHREADS)
ba869deb
GS		 3187# ifdef OLD_PTHREADS_API
3188 pthread_addr_t t;
3189 if (pthread_getspecific(PL_thr_key, &t))
3190 Perl_croak_nocontext("panic: pthread_getspecific");
3191 return (void*)t;
3192# else
bce813aa 3193# ifdef I_MACH_CTHREADS
8b8b35ab 3194 return (void*)cthread_data(cthread_self());
bce813aa 3195# else
8b8b35ab
JH		 3196 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3197# endif
c44d3fdb 3198# endif
ba869deb
GS		 3199#else
3200 return (void*)NULL;
3201#endif
3202}
3203
3204void
3205Perl_set_context(void *t)
3206{
8772537c 3207 dVAR;
3db8f154 3208#if defined(USE_ITHREADS)
c44d3fdb
GS		 3209# ifdef I_MACH_CTHREADS
3210 cthread_set_data(cthread_self(), t);
3211# else
ba869deb
GS		 3212 if (pthread_setspecific(PL_thr_key, t))
3213 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3214# endif
b464bac0 3215#else
8772537c 3216 PERL_UNUSED_ARG(t);
ba869deb
GS		 3217#endif
3218}
3219
3220#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3221
27da23d5 3222#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3223struct perl_vars *
864dbfa3 3224Perl_GetVars(pTHX)
22239a37 3225{
533c011a 3226 return &PL_Vars;
22239a37 3227}
31fb1209
NIS		 3228#endif
3229
1cb0ed9b 3230char **
864dbfa3 3231Perl_get_op_names(pTHX)
31fb1209 3232{
96a5add6
AL		 3233 PERL_UNUSED_CONTEXT;
3234 return (char **)PL_op_name;
31fb1209
NIS		 3235}
3236
1cb0ed9b 3237char **
864dbfa3 3238Perl_get_op_descs(pTHX)
31fb1209 3239{
96a5add6
AL		 3240 PERL_UNUSED_CONTEXT;
3241 return (char **)PL_op_desc;
31fb1209 3242}
9e6b2b00 3243
e1ec3a88 3244const char *
864dbfa3 3245Perl_get_no_modify(pTHX)
9e6b2b00 3246{
96a5add6
AL		 3247 PERL_UNUSED_CONTEXT;
3248 return PL_no_modify;
9e6b2b00
GS		 3249}
3250
3251U32 *
864dbfa3 3252Perl_get_opargs(pTHX)
9e6b2b00 3253{
96a5add6
AL		 3254 PERL_UNUSED_CONTEXT;
3255 return (U32 *)PL_opargs;
9e6b2b00 3256}
51aa15f3 3257
0cb96387
GS		 3258PPADDR_t*
3259Perl_get_ppaddr(pTHX)
3260{
96a5add6
AL		 3261 dVAR;
3262 PERL_UNUSED_CONTEXT;
3263 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3264}
3265
a6c40364
GS		 3266#ifndef HAS_GETENV_LEN
3267char *
bf4acbe4 3268Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3269{
8772537c 3270 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3271 PERL_UNUSED_CONTEXT;
a6c40364
GS		 3272 if (env_trans)
3273 *len = strlen(env_trans);
3274 return env_trans;
f675dbe5
CB		 3275}
3276#endif
3277
dc9e4912
GS		 3278
3279MGVTBL*
864dbfa3 3280Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3281{
7452cf6a 3282 const MGVTBL* result;
96a5add6 3283 PERL_UNUSED_CONTEXT;
dc9e4912
GS		 3284
3285 switch(vtbl_id) {
3286 case want_vtbl_sv:
3287 result = &PL_vtbl_sv;
3288 break;
3289 case want_vtbl_env:
3290 result = &PL_vtbl_env;
3291 break;
3292 case want_vtbl_envelem:
3293 result = &PL_vtbl_envelem;
3294 break;
3295 case want_vtbl_sig:
3296 result = &PL_vtbl_sig;
3297 break;
3298 case want_vtbl_sigelem:
3299 result = &PL_vtbl_sigelem;
3300 break;
3301 case want_vtbl_pack:
3302 result = &PL_vtbl_pack;
3303 break;
3304 case want_vtbl_packelem:
3305 result = &PL_vtbl_packelem;
3306 break;
3307 case want_vtbl_dbline:
3308 result = &PL_vtbl_dbline;
3309 break;
3310 case want_vtbl_isa:
3311 result = &PL_vtbl_isa;
3312 break;
3313 case want_vtbl_isaelem:
3314 result = &PL_vtbl_isaelem;
3315 break;
3316 case want_vtbl_arylen:
3317 result = &PL_vtbl_arylen;
3318 break;
dc9e4912
GS		 3319 case want_vtbl_mglob:
3320 result = &PL_vtbl_mglob;
3321 break;
3322 case want_vtbl_nkeys:
3323 result = &PL_vtbl_nkeys;
3324 break;
3325 case want_vtbl_taint:
3326 result = &PL_vtbl_taint;
3327 break;
3328 case want_vtbl_substr:
3329 result = &PL_vtbl_substr;
3330 break;
3331 case want_vtbl_vec:
3332 result = &PL_vtbl_vec;
3333 break;
3334 case want_vtbl_pos:
3335 result = &PL_vtbl_pos;
3336 break;
3337 case want_vtbl_bm:
3338 result = &PL_vtbl_bm;
3339 break;
3340 case want_vtbl_fm:
3341 result = &PL_vtbl_fm;
3342 break;
3343 case want_vtbl_uvar:
3344 result = &PL_vtbl_uvar;
3345 break;
dc9e4912
GS		 3346 case want_vtbl_defelem:
3347 result = &PL_vtbl_defelem;
3348 break;
3349 case want_vtbl_regexp:
3350 result = &PL_vtbl_regexp;
3351 break;
3352 case want_vtbl_regdata:
3353 result = &PL_vtbl_regdata;
3354 break;
3355 case want_vtbl_regdatum:
3356 result = &PL_vtbl_regdatum;
3357 break;
3c90161d 3358#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3359 case want_vtbl_collxfrm:
3360 result = &PL_vtbl_collxfrm;
3361 break;
3c90161d 3362#endif
dc9e4912
GS		 3363 case want_vtbl_amagic:
3364 result = &PL_vtbl_amagic;
3365 break;
3366 case want_vtbl_amagicelem:
3367 result = &PL_vtbl_amagicelem;
3368 break;
810b8aa5
GS		 3369 case want_vtbl_backref:
3370 result = &PL_vtbl_backref;
3371 break;
7e8c5dac
HS		 3372 case want_vtbl_utf8:
3373 result = &PL_vtbl_utf8;
3374 break;
7452cf6a 3375 default:
4608196e 3376 result = NULL;
7452cf6a 3377 break;
dc9e4912 3378 }
27da23d5 3379 return (MGVTBL*)result;
dc9e4912
GS		 3380}
3381
767df6a1 3382I32
864dbfa3 3383Perl_my_fflush_all(pTHX)
767df6a1 3384{
f800e14d 3385#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3386 return PerlIO_flush(NULL);
767df6a1 3387#else
8fbdfb7c 3388# if defined(HAS__FWALK)
f13a2bc0 3389 extern int fflush(FILE *);
74cac757
JH		 3390 /* undocumented, unprototyped, but very useful BSDism */
3391 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3392 _fwalk(&fflush);
74cac757 3393 return 0;
8fa7f367 3394# else
8fbdfb7c 3395# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3396 long open_max = -1;
8fbdfb7c 3397# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3398 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3399# else
8fa7f367 3400# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3401 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3402# else
3403# ifdef FOPEN_MAX
74cac757 3404 open_max = FOPEN_MAX;
8fa7f367
JH		 3405# else
3406# ifdef OPEN_MAX
74cac757 3407 open_max = OPEN_MAX;
8fa7f367
JH		 3408# else
3409# ifdef _NFILE
d2201af2 3410 open_max = _NFILE;
8fa7f367
JH		 3411# endif
3412# endif
74cac757 3413# endif
767df6a1
JH		 3414# endif
3415# endif
767df6a1
JH		 3416 if (open_max > 0) {
3417 long i;
3418 for (i = 0; i < open_max; i++)
d2201af2
AD		 3419 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3420 STDIO_STREAM_ARRAY[i]._file < open_max &&
3421 STDIO_STREAM_ARRAY[i]._flag)
3422 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3423 return 0;
3424 }
8fbdfb7c 3425# endif
93189314 3426 SETERRNO(EBADF,RMS_IFI);
767df6a1 3427 return EOF;
74cac757 3428# endif
767df6a1
JH		 3429#endif
3430}
097ee67d 3431
69282e91 3432void
e1ec3a88 3433Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
bc37a18f 3434{
b64e5050 3435 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
66fc2fa5 3436
4c80c0b2 3437 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3438 if (ckWARN(WARN_IO)) {
10edeb5d
JH		 3439 const char * const direction =
3440 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3aed30dc
HS		 3441 if (name && *name)
3442 Perl_warner(aTHX_ packWARN(WARN_IO),
3443 "Filehandle %s opened only for %sput",
fd322ea4 3444 name, direction);
3aed30dc
HS		 3445 else
3446 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3447 "Filehandle opened only for %sput", direction);
3aed30dc 3448 }
2dd78f96
JH		 3449 }
3450 else {
e1ec3a88 3451 const char *vile;
3aed30dc
HS		 3452 I32 warn_type;
3453
3454 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3455 vile = "closed";
3456 warn_type = WARN_CLOSED;
3457 }
3458 else {
3459 vile = "unopened";
3460 warn_type = WARN_UNOPENED;
3461 }
3462
3463 if (ckWARN(warn_type)) {
10edeb5d
JH		 3464 const char * const pars =
3465 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
f0a09b71 3466 const char * const func =
10edeb5d
JH		 3467 (const char *)
3468 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3469 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3470 op < 0 ? "" : /* handle phoney cases */
3471 PL_op_desc[op]);
3472 const char * const type =
3473 (const char *)
3474 (OP_IS_SOCKET(op) ||
3475 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3476 "socket" : "filehandle");
3aed30dc
HS		 3477 if (name && *name) {
3478 Perl_warner(aTHX_ packWARN(warn_type),
3479 "%s%s on %s %s %s", func, pars, vile, type, name);
3480 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3481 Perl_warner(
3482 aTHX_ packWARN(warn_type),
3483 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3484 func, pars, name
3485 );
3486 }
3487 else {
3488 Perl_warner(aTHX_ packWARN(warn_type),
3489 "%s%s on %s %s", func, pars, vile, type);
3490 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3491 Perl_warner(
3492 aTHX_ packWARN(warn_type),
3493 "\t(Are you trying to call %s%s on dirhandle?)\n",
3494 func, pars
3495 );
3496 }
3497 }
bc37a18f 3498 }
69282e91 3499}
a926ef6b
JH		 3500
3501#ifdef EBCDIC
cbebf344
JH		 3502/* in ASCII order, not that it matters */
3503static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3504
a926ef6b
JH		 3505int
3506Perl_ebcdic_control(pTHX_ int ch)
3507{
3aed30dc 3508 if (ch > 'a') {
e1ec3a88 3509 const char *ctlp;
3aed30dc
HS		 3510
3511 if (islower(ch))
3512 ch = toupper(ch);
3513
3514 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3515 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3516 }
3aed30dc
HS		 3517
3518 if (ctlp == controllablechars)
3519 return('\177'); /* DEL */
3520 else
3521 return((unsigned char)(ctlp - controllablechars - 1));
3522 } else { /* Want uncontrol */
3523 if (ch == '\177' || ch == -1)
3524 return('?');
3525 else if (ch == '\157')
3526 return('\177');
3527 else if (ch == '\174')
3528 return('\000');
3529 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3530 return('\036');
3531 else if (ch == '\155')
3532 return('\037');
3533 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3534 return(controllablechars[ch+1]);
3535 else
3536 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3537 }
a926ef6b
JH		 3538}
3539#endif
e72cf795 3540
f6adc668 3541/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3542 * system to give us a reasonable struct to copy. This fix means that
3543 * strftime uses the tm_zone and tm_gmtoff values returned by
3544 * localtime(time()). That should give the desired result most of the
3545 * time. But probably not always!
3546 *
f6adc668
JH		 3547 * This does not address tzname aspects of NETaa14816.
3548 *
e72cf795 3549 */
f6adc668 3550
e72cf795
JH		 3551#ifdef HAS_GNULIBC
3552# ifndef STRUCT_TM_HASZONE
3553# define STRUCT_TM_HASZONE
3554# endif
3555#endif
3556
f6adc668
JH		 3557#ifdef STRUCT_TM_HASZONE /* Backward compat */
3558# ifndef HAS_TM_TM_ZONE
3559# define HAS_TM_TM_ZONE
3560# endif
3561#endif
3562
e72cf795 3563void
f1208910 3564Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3565{
f6adc668 3566#ifdef HAS_TM_TM_ZONE
e72cf795 3567 Time_t now;
1b6737cc 3568 const struct tm* my_tm;
e72cf795 3569 (void)time(&now);
82c57498 3570 my_tm = localtime(&now);
ca46b8ee
SP		 3571 if (my_tm)
3572 Copy(my_tm, ptm, 1, struct tm);
1b6737cc
AL		 3573#else
3574 PERL_UNUSED_ARG(ptm);
e72cf795
JH		 3575#endif
3576}
3577
3578/*
3579 * mini_mktime - normalise struct tm values without the localtime()
3580 * semantics (and overhead) of mktime().
3581 */
3582void
f1208910 3583Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3584{
3585 int yearday;
3586 int secs;
3587 int month, mday, year, jday;
3588 int odd_cent, odd_year;
96a5add6 3589 PERL_UNUSED_CONTEXT;
e72cf795
JH		 3590
3591#define DAYS_PER_YEAR 365
3592#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3593#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3594#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3595#define SECS_PER_HOUR (60*60)
3596#define SECS_PER_DAY (24*SECS_PER_HOUR)
3597/* parentheses deliberately absent on these two, otherwise they don't work */
3598#define MONTH_TO_DAYS 153/5
3599#define DAYS_TO_MONTH 5/153
3600/* offset to bias by March (month 4) 1st between month/mday & year finding */
3601#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3602/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3603#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3604
3605/*
3606 * Year/day algorithm notes:
3607 *
3608 * With a suitable offset for numeric value of the month, one can find
3609 * an offset into the year by considering months to have 30.6 (153/5) days,
3610 * using integer arithmetic (i.e., with truncation). To avoid too much
3611 * messing about with leap days, we consider January and February to be
3612 * the 13th and 14th month of the previous year. After that transformation,
3613 * we need the month index we use to be high by 1 from 'normal human' usage,
3614 * so the month index values we use run from 4 through 15.
3615 *
3616 * Given that, and the rules for the Gregorian calendar (leap years are those
3617 * divisible by 4 unless also divisible by 100, when they must be divisible
3618 * by 400 instead), we can simply calculate the number of days since some
3619 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3620 * the days we derive from our month index, and adding in the day of the
3621 * month. The value used here is not adjusted for the actual origin which
3622 * it normally would use (1 January A.D. 1), since we're not exposing it.
3623 * We're only building the value so we can turn around and get the
3624 * normalised values for the year, month, day-of-month, and day-of-year.
3625 *
3626 * For going backward, we need to bias the value we're using so that we find
3627 * the right year value. (Basically, we don't want the contribution of
3628 * March 1st to the number to apply while deriving the year). Having done
3629 * that, we 'count up' the contribution to the year number by accounting for
3630 * full quadracenturies (400-year periods) with their extra leap days, plus
3631 * the contribution from full centuries (to avoid counting in the lost leap
3632 * days), plus the contribution from full quad-years (to count in the normal
3633 * leap days), plus the leftover contribution from any non-leap years.
3634 * At this point, if we were working with an actual leap day, we'll have 0
3635 * days left over. This is also true for March 1st, however. So, we have
3636 * to special-case that result, and (earlier) keep track of the 'odd'
3637 * century and year contributions. If we got 4 extra centuries in a qcent,
3638 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3639 * Otherwise, we add back in the earlier bias we removed (the 123 from
3640 * figuring in March 1st), find the month index (integer division by 30.6),
3641 * and the remainder is the day-of-month. We then have to convert back to
3642 * 'real' months (including fixing January and February from being 14/15 in
3643 * the previous year to being in the proper year). After that, to get
3644 * tm_yday, we work with the normalised year and get a new yearday value for
3645 * January 1st, which we subtract from the yearday value we had earlier,
3646 * representing the date we've re-built. This is done from January 1
3647 * because tm_yday is 0-origin.
3648 *
3649 * Since POSIX time routines are only guaranteed to work for times since the
3650 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3651 * applies Gregorian calendar rules even to dates before the 16th century
3652 * doesn't bother me. Besides, you'd need cultural context for a given
3653 * date to know whether it was Julian or Gregorian calendar, and that's
3654 * outside the scope for this routine. Since we convert back based on the
3655 * same rules we used to build the yearday, you'll only get strange results
3656 * for input which needed normalising, or for the 'odd' century years which
3657 * were leap years in the Julian calander but not in the Gregorian one.
3658 * I can live with that.
3659 *
3660 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3661 * that's still outside the scope for POSIX time manipulation, so I don't
3662 * care.
3663 */
3664
3665 year = 1900 + ptm->tm_year;
3666 month = ptm->tm_mon;
3667 mday = ptm->tm_mday;
3668 /* allow given yday with no month & mday to dominate the result */
3669 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3670 month = 0;
3671 mday = 0;
3672 jday = 1 + ptm->tm_yday;
3673 }
3674 else {
3675 jday = 0;
3676 }
3677 if (month >= 2)
3678 month+=2;
3679 else
3680 month+=14, year--;
3681 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3682 yearday += month*MONTH_TO_DAYS + mday + jday;
3683 /*
3684 * Note that we don't know when leap-seconds were or will be,
3685 * so we have to trust the user if we get something which looks
3686 * like a sensible leap-second. Wild values for seconds will
3687 * be rationalised, however.
3688 */
3689 if ((unsigned) ptm->tm_sec <= 60) {
3690 secs = 0;
3691 }
3692 else {
3693 secs = ptm->tm_sec;
3694 ptm->tm_sec = 0;
3695 }
3696 secs += 60 * ptm->tm_min;
3697 secs += SECS_PER_HOUR * ptm->tm_hour;
3698 if (secs < 0) {
3699 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3700 /* got negative remainder, but need positive time */
3701 /* back off an extra day to compensate */
3702 yearday += (secs/SECS_PER_DAY)-1;
3703 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3704 }
3705 else {
3706 yearday += (secs/SECS_PER_DAY);
3707 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3708 }
3709 }
3710 else if (secs >= SECS_PER_DAY) {
3711 yearday += (secs/SECS_PER_DAY);
3712 secs %= SECS_PER_DAY;
3713 }
3714 ptm->tm_hour = secs/SECS_PER_HOUR;
3715 secs %= SECS_PER_HOUR;
3716 ptm->tm_min = secs/60;
3717 secs %= 60;
3718 ptm->tm_sec += secs;
3719 /* done with time of day effects */
3720 /*
3721 * The algorithm for yearday has (so far) left it high by 428.
3722 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3723 * bias it by 123 while trying to figure out what year it
3724 * really represents. Even with this tweak, the reverse
3725 * translation fails for years before A.D. 0001.
3726 * It would still fail for Feb 29, but we catch that one below.
3727 */
3728 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3729 yearday -= YEAR_ADJUST;
3730 year = (yearday / DAYS_PER_QCENT) * 400;
3731 yearday %= DAYS_PER_QCENT;
3732 odd_cent = yearday / DAYS_PER_CENT;
3733 year += odd_cent * 100;
3734 yearday %= DAYS_PER_CENT;
3735 year += (yearday / DAYS_PER_QYEAR) * 4;
3736 yearday %= DAYS_PER_QYEAR;
3737 odd_year = yearday / DAYS_PER_YEAR;
3738 year += odd_year;
3739 yearday %= DAYS_PER_YEAR;
3740 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3741 month = 1;
3742 yearday = 29;
3743 }
3744 else {
3745 yearday += YEAR_ADJUST; /* recover March 1st crock */
3746 month = yearday*DAYS_TO_MONTH;
3747 yearday -= month*MONTH_TO_DAYS;
3748 /* recover other leap-year adjustment */
3749 if (month > 13) {
3750 month-=14;
3751 year++;
3752 }
3753 else {
3754 month-=2;
3755 }
3756 }
3757 ptm->tm_year = year - 1900;
3758 if (yearday) {
3759 ptm->tm_mday = yearday;
3760 ptm->tm_mon = month;
3761 }
3762 else {
3763 ptm->tm_mday = 31;
3764 ptm->tm_mon = month - 1;
3765 }
3766 /* re-build yearday based on Jan 1 to get tm_yday */
3767 year--;
3768 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3769 yearday += 14*MONTH_TO_DAYS + 1;
3770 ptm->tm_yday = jday - yearday;
3771 /* fix tm_wday if not overridden by caller */
3772 if ((unsigned)ptm->tm_wday > 6)
3773 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3774}
b3c85772
JH		 3775
3776char *
e1ec3a88 3777Perl_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		 3778{
3779#ifdef HAS_STRFTIME
3780 char *buf;
3781 int buflen;
3782 struct tm mytm;
3783 int len;
3784
3785 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3786 mytm.tm_sec = sec;
3787 mytm.tm_min = min;
3788 mytm.tm_hour = hour;
3789 mytm.tm_mday = mday;
3790 mytm.tm_mon = mon;
3791 mytm.tm_year = year;
3792 mytm.tm_wday = wday;
3793 mytm.tm_yday = yday;
3794 mytm.tm_isdst = isdst;
3795 mini_mktime(&mytm);
c473feec
SR		 3796 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3797#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3798 STMT_START {
3799 struct tm mytm2;
3800 mytm2 = mytm;
3801 mktime(&mytm2);
3802#ifdef HAS_TM_TM_GMTOFF
3803 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3804#endif
3805#ifdef HAS_TM_TM_ZONE
3806 mytm.tm_zone = mytm2.tm_zone;
3807#endif
3808 } STMT_END;
3809#endif
b3c85772 3810 buflen = 64;
a02a5408 3811 Newx(buf, buflen, char);
b3c85772
JH		 3812 len = strftime(buf, buflen, fmt, &mytm);
3813 /*
877f6a72 3814 ** The following is needed to handle to the situation where
b3c85772
JH		 3815 ** tmpbuf overflows. Basically we want to allocate a buffer
3816 ** and try repeatedly. The reason why it is so complicated
3817 ** is that getting a return value of 0 from strftime can indicate
3818 ** one of the following:
3819 ** 1. buffer overflowed,
3820 ** 2. illegal conversion specifier, or
3821 ** 3. the format string specifies nothing to be returned(not
3822 ** an error). This could be because format is an empty string
3823 ** or it specifies %p that yields an empty string in some locale.
3824 ** If there is a better way to make it portable, go ahead by
3825 ** all means.
3826 */
3827 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3828 return buf;
3829 else {
3830 /* Possibly buf overflowed - try again with a bigger buf */
e1ec3a88
AL		 3831 const int fmtlen = strlen(fmt);
3832 const int bufsize = fmtlen + buflen;
877f6a72 3833
a02a5408 3834 Newx(buf, bufsize, char);
b3c85772
JH		 3835 while (buf) {
3836 buflen = strftime(buf, bufsize, fmt, &mytm);
3837 if (buflen > 0 && buflen < bufsize)
3838 break;
3839 /* heuristic to prevent out-of-memory errors */
3840 if (bufsize > 100*fmtlen) {
3841 Safefree(buf);
3842 buf = NULL;
3843 break;
3844 }
e1ec3a88 3845 Renew(buf, bufsize*2, char);
b3c85772
JH		 3846 }
3847 return buf;
3848 }
3849#else
3850 Perl_croak(aTHX_ "panic: no strftime");
27da23d5 3851 return NULL;
b3c85772
JH		 3852#endif
3853}
3854
877f6a72
NIS		 3855
3856#define SV_CWD_RETURN_UNDEF \
3857sv_setsv(sv, &PL_sv_undef); \
3858return FALSE
3859
3860#define SV_CWD_ISDOT(dp) \
3861 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3862 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3863
3864/*
ccfc67b7
JH		 3865=head1 Miscellaneous Functions
3866
89423764 3867=for apidoc getcwd_sv
877f6a72
NIS		 3868
3869Fill the sv with current working directory
3870
3871=cut
3872*/
3873
3874/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3875 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3876 * getcwd(3) if available
3877 * Comments from the orignal:
3878 * This is a faster version of getcwd. It's also more dangerous
3879 * because you might chdir out of a directory that you can't chdir
3880 * back into. */
3881
877f6a72 3882int
89423764 3883Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3884{
3885#ifndef PERL_MICRO
97aff369 3886 dVAR;
ea715489
JH		 3887#ifndef INCOMPLETE_TAINTS
3888 SvTAINTED_on(sv);
3889#endif
3890
8f95b30d
JH		 3891#ifdef HAS_GETCWD
3892 {
60e110a8
DM		 3893 char buf[MAXPATHLEN];
3894
3aed30dc 3895 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3896 * size from the heap if they are given a NULL buffer pointer.
3897 * The problem is that this behaviour is not portable. */
3aed30dc 3898 if (getcwd(buf, sizeof(buf) - 1)) {
42d9b98d 3899 sv_setpv(sv, buf);
3aed30dc
HS		 3900 return TRUE;
3901 }
3902 else {
3903 sv_setsv(sv, &PL_sv_undef);
3904 return FALSE;
3905 }
8f95b30d
JH		 3906 }
3907
3908#else
3909
c623ac67 3910 Stat_t statbuf;
877f6a72 3911 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4373e329 3912 int pathlen=0;
877f6a72 3913 Direntry_t *dp;
877f6a72 3914
862a34c6 3915 SvUPGRADE(sv, SVt_PV);
877f6a72 3916
877f6a72 3917 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3918 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3919 }
3920
3921 orig_cdev = statbuf.st_dev;
3922 orig_cino = statbuf.st_ino;
3923 cdev = orig_cdev;
3924 cino = orig_cino;
3925
3926 for (;;) {
4373e329 3927 DIR *dir;
3aed30dc
HS		 3928 odev = cdev;
3929 oino = cino;
3930
3931 if (PerlDir_chdir("..") < 0) {
3932 SV_CWD_RETURN_UNDEF;
3933 }
3934 if (PerlLIO_stat(".", &statbuf) < 0) {
3935 SV_CWD_RETURN_UNDEF;
3936 }
3937
3938 cdev = statbuf.st_dev;
3939 cino = statbuf.st_ino;
3940
3941 if (odev == cdev && oino == cino) {
3942 break;
3943 }
3944 if (!(dir = PerlDir_open("."))) {
3945 SV_CWD_RETURN_UNDEF;
3946 }
3947
3948 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3949#ifdef DIRNAMLEN
4373e329 3950 const int namelen = dp->d_namlen;
877f6a72 3951#else
4373e329 3952 const int namelen = strlen(dp->d_name);
877f6a72 3953#endif
3aed30dc
HS		 3954 /* skip . and .. */
3955 if (SV_CWD_ISDOT(dp)) {
3956 continue;
3957 }
3958
3959 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3960 SV_CWD_RETURN_UNDEF;
3961 }
3962
3963 tdev = statbuf.st_dev;
3964 tino = statbuf.st_ino;
3965 if (tino == oino && tdev == odev) {
3966 break;
3967 }
cb5953d6
JH		 3968 }
3969
3aed30dc
HS		 3970 if (!dp) {
3971 SV_CWD_RETURN_UNDEF;
3972 }
3973
3974 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3975 SV_CWD_RETURN_UNDEF;
3976 }
877f6a72 3977
3aed30dc
HS		 3978 SvGROW(sv, pathlen + namelen + 1);
3979
3980 if (pathlen) {
3981 /* shift down */
95a20fc0 3982 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3aed30dc 3983 }
877f6a72 3984
3aed30dc
HS		 3985 /* prepend current directory to the front */
3986 *SvPVX(sv) = '/';
3987 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3988 pathlen += (namelen + 1);
877f6a72
NIS		 3989
3990#ifdef VOID_CLOSEDIR
3aed30dc 3991 PerlDir_close(dir);
877f6a72 3992#else
3aed30dc
HS		 3993 if (PerlDir_close(dir) < 0) {
3994 SV_CWD_RETURN_UNDEF;
3995 }
877f6a72
NIS		 3996#endif
3997 }
3998
60e110a8 3999 if (pathlen) {
3aed30dc
HS		 4000 SvCUR_set(sv, pathlen);
4001 *SvEND(sv) = '\0';
4002 SvPOK_only(sv);
877f6a72 4003
95a20fc0 4004 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3aed30dc
HS		 4005 SV_CWD_RETURN_UNDEF;
4006 }
877f6a72
NIS		 4007 }
4008 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 4009 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4010 }
4011
4012 cdev = statbuf.st_dev;
4013 cino = statbuf.st_ino;
4014
4015 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 4016 Perl_croak(aTHX_ "Unstable directory path, "
4017 "current directory changed unexpectedly");
877f6a72 4018 }
877f6a72
NIS		 4019
4020 return TRUE;
793b8d8e
JH		 4021#endif
4022
877f6a72
NIS		 4023#else
4024 return FALSE;
4025#endif
4026}
4027
f4758303 4028/*
b0f01acb
JP		 4029=for apidoc scan_version
4030
4031Returns a pointer to the next character after the parsed
4032version string, as well as upgrading the passed in SV to
4033an RV.
4034
4035Function must be called with an already existing SV like
4036
137d6fc0
JP		 4037 sv = newSV(0);
4038 s = scan_version(s,SV *sv, bool qv);
b0f01acb
JP		 4039
4040Performs some preprocessing to the string to ensure that
4041it has the correct characteristics of a version. Flags the
4042object if it contains an underscore (which denotes this
137d6fc0
JP		 4043is a alpha version). The boolean qv denotes that the version
4044should be interpreted as if it had multiple decimals, even if
4045it doesn't.
b0f01acb
JP		 4046
4047=cut
4048*/
4049
9137345a 4050const char *
e1ec3a88 4051Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
b0f01acb 4052{
e0218a61 4053 const char *start;
9137345a
JP		 4054 const char *pos;
4055 const char *last;
4056 int saw_period = 0;
cb5772bb 4057 int alpha = 0;
9137345a 4058 int width = 3;
7452cf6a
AL		 4059 AV * const av = newAV();
4060 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
9137345a 4061 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
cb5772bb 4062
3a242bf8
NC		 4063#ifndef NODEFAULT_SHAREKEYS
4064 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4065#endif
9137345a 4066
e0218a61
JP		 4067 while (isSPACE(*s)) /* leading whitespace is OK */
4068 s++;
4069
9137345a
JP		 4070 if (*s == 'v') {
4071 s++; /* get past 'v' */
4072 qv = 1; /* force quoted version processing */
4073 }
4074
e0218a61 4075 start = last = pos = s;
9137345a
JP		 4076
4077 /* pre-scan the input string to check for decimals/underbars */
ad63d80f
JP		 4078 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4079 {
4080 if ( *pos == '.' )
4081 {
cb5772bb 4082 if ( alpha )
5f89c282 4083 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 4084 saw_period++ ;
9137345a 4085 last = pos;
46314c13 4086 }
ad63d80f
JP		 4087 else if ( *pos == '_' )
4088 {
cb5772bb 4089 if ( alpha )
5f89c282 4090 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
cb5772bb 4091 alpha = 1;
9137345a 4092 width = pos - last - 1; /* natural width of sub-version */
ad63d80f
JP		 4093 }
4094 pos++;
4095 }
ad63d80f 4096
34ba6322
SP		 4097 if ( alpha && !saw_period )
4098 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4099
e0218a61 4100 if ( saw_period > 1 )
137d6fc0 4101 qv = 1; /* force quoted version processing */
9137345a
JP		 4102
4103 pos = s;
4104
4105 if ( qv )
cb5772bb
RGS		 4106 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4107 if ( alpha )
4108 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
9137345a
JP		 4109 if ( !qv && width < 3 )
4110 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4111
ad63d80f 4112 while (isDIGIT(*pos))
46314c13 4113 pos++;
ad63d80f
JP		 4114 if (!isALPHA(*pos)) {
4115 I32 rev;
4116
ad63d80f
JP		 4117 for (;;) {
4118 rev = 0;
4119 {
129318bd 4120 /* this is atoi() that delimits on underscores */
9137345a 4121 const char *end = pos;
129318bd
JP		 4122 I32 mult = 1;
4123 I32 orev;
9137345a 4124
129318bd
JP		 4125 /* the following if() will only be true after the decimal
4126 * point of a version originally created with a bare
4127 * floating point number, i.e. not quoted in any way
4128 */
e0218a61 4129 if ( !qv && s > start && saw_period == 1 ) {
c76df65e 4130 mult *= 100;
129318bd
JP		 4131 while ( s < end ) {
4132 orev = rev;
4133 rev += (*s - '0') * mult;
4134 mult /= 10;
32fdb065 4135 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 4136 Perl_croak(aTHX_ "Integer overflow in version");
4137 s++;
9137345a
JP		 4138 if ( *s == '_' )
4139 s++;
129318bd
JP		 4140 }
4141 }
4142 else {
4143 while (--end >= s) {
4144 orev = rev;
4145 rev += (*end - '0') * mult;
4146 mult *= 10;
32fdb065 4147 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 4148 Perl_croak(aTHX_ "Integer overflow in version");
4149 }
4150 }
4151 }
9137345a 4152
129318bd 4153 /* Append revision */
9137345a 4154 av_push(av, newSViv(rev));
c8a14fb6 4155 if ( *pos == '.' )
9137345a
JP		 4156 s = ++pos;
4157 else if ( *pos == '_' && isDIGIT(pos[1]) )
ad63d80f
JP		 4158 s = ++pos;
4159 else if ( isDIGIT(*pos) )
4160 s = pos;
b0f01acb 4161 else {
ad63d80f
JP		 4162 s = pos;
4163 break;
4164 }
9137345a
JP		 4165 if ( qv ) {
4166 while ( isDIGIT(*pos) )
4167 pos++;
4168 }
4169 else {
4170 int digits = 0;
4171 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4172 if ( *pos != '_' )
4173 digits++;
4174 pos++;
4175 }
b0f01acb
JP		 4176 }
4177 }
4178 }
9137345a
JP		 4179 if ( qv ) { /* quoted versions always get at least three terms*/
4180 I32 len = av_len(av);
4edfc503
NC		 4181 /* This for loop appears to trigger a compiler bug on OS X, as it
4182 loops infinitely. Yes, len is negative. No, it makes no sense.
4183 Compiler in question is:
4184 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4185 for ( len = 2 - len; len > 0; len-- )
4186 av_push((AV *)sv, newSViv(0));
4187 */
4188 len = 2 - len;
4189 while (len-- > 0)
9137345a 4190 av_push(av, newSViv(0));
b9381830 4191 }
9137345a
JP		 4192
4193 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4194 av_push(av, newSViv(0));
4195
92dcf8ce
JP		 4196 /* fix RT#19517 - special case 'undef' as string */
4197 if ( *s == 'u' && strEQ(s,"undef") ) {
4198 s += 5;
4199 }
4200
9137345a 4201 /* And finally, store the AV in the hash */
cb5772bb 4202 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
9137345a 4203 return s;
b0f01acb
JP		 4204}
4205
4206/*
4207=for apidoc new_version
4208
4209Returns a new version object based on the passed in SV:
4210
4211 SV *sv = new_version(SV *ver);
4212
4213Does not alter the passed in ver SV. See "upg_version" if you
4214want to upgrade the SV.
4215
4216=cut
4217*/
4218
4219SV *
4220Perl_new_version(pTHX_ SV *ver)
4221{
97aff369 4222 dVAR;
2d03de9c 4223 SV * const rv = newSV(0);
d7aa5382
JP		 4224 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4225 {
4226 I32 key;
53c1dcc0 4227 AV * const av = newAV();
9137345a
JP		 4228 AV *sav;
4229 /* This will get reblessed later if a derived class*/
e0218a61 4230 SV * const hv = newSVrv(rv, "version");
9137345a 4231 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3a242bf8
NC		 4232#ifndef NODEFAULT_SHAREKEYS
4233 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4234#endif
9137345a
JP		 4235
4236 if ( SvROK(ver) )
4237 ver = SvRV(ver);
4238
4239 /* Begin copying all of the elements */
4240 if ( hv_exists((HV *)ver, "qv", 2) )
4241 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4242
4243 if ( hv_exists((HV *)ver, "alpha", 5) )
4244 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4245
4246 if ( hv_exists((HV*)ver, "width", 5 ) )
d7aa5382 4247 {
017a3ce5 4248 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
9137345a 4249 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
d7aa5382 4250 }
9137345a 4251
017a3ce5 4252 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
9137345a
JP		 4253 /* This will get reblessed later if a derived class*/
4254 for ( key = 0; key <= av_len(sav); key++ )
4255 {
4256 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4257 av_push(av, newSViv(rev));
4258 }
4259
cb5772bb 4260 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
d7aa5382
JP		 4261 return rv;
4262 }
ad63d80f 4263#ifdef SvVOK
4f2da183 4264 {
3c21775b 4265 const MAGIC* const mg = SvVSTRING_mg(ver);
4f2da183
NC		 4266 if ( mg ) { /* already a v-string */
4267 const STRLEN len = mg->mg_len;
4268 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4269 sv_setpvn(rv,version,len);
4270 Safefree(version);
4271 }
4272 else {
ad63d80f 4273#endif
4f2da183 4274 sv_setsv(rv,ver); /* make a duplicate */
137d6fc0 4275#ifdef SvVOK
4f2da183 4276 }
26ec6fc3 4277 }
137d6fc0 4278#endif
2593c6c6 4279 return upg_version(rv);
b0f01acb
JP		 4280}
4281
4282/*
4283=for apidoc upg_version
4284
4285In-place upgrade of the supplied SV to a version object.
4286
4287 SV *sv = upg_version(SV *sv);
4288
4289Returns a pointer to the upgraded SV.
4290
4291=cut
4292*/
4293
4294SV *
ad63d80f 4295Perl_upg_version(pTHX_ SV *ver)
b0f01acb 4296{
cd57dc11 4297 const char *version, *s;
137d6fc0 4298 bool qv = 0;
4f2da183
NC		 4299#ifdef SvVOK
4300 const MAGIC *mg;
4301#endif
137d6fc0
JP		 4302
4303 if ( SvNOK(ver) ) /* may get too much accuracy */
4304 {
4305 char tbuf[64];
b5b5a8f0
RGS		 4306#ifdef USE_LOCALE_NUMERIC
4307 char *loc = setlocale(LC_NUMERIC, "C");
4308#endif
63e3af20 4309 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
b5b5a8f0
RGS		 4310#ifdef USE_LOCALE_NUMERIC
4311 setlocale(LC_NUMERIC, loc);
4312#endif
c8a14fb6 4313 while (tbuf[len-1] == '0' && len > 0) len--;
86c11942 4314 version = savepvn(tbuf, len);
137d6fc0 4315 }
ad63d80f 4316#ifdef SvVOK
666cce26 4317 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
ad63d80f 4318 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0 4319 qv = 1;
b0f01acb 4320 }
ad63d80f 4321#endif
137d6fc0
JP		 4322 else /* must be a string or something like a string */
4323 {
9137345a 4324 version = savepv(SvPV_nolen(ver));
137d6fc0 4325 }
92dcf8ce 4326
cd57dc11 4327 s = scan_version(version, ver, qv);
808ee47e 4328 if ( *s != '\0' )
92dcf8ce 4329 if(ckWARN(WARN_MISC))
808ee47e 4330 Perl_warner(aTHX_ packWARN(WARN_MISC),
92dcf8ce
JP		 4331 "Version string '%s' contains invalid data; "
4332 "ignoring: '%s'", version, s);
137d6fc0 4333 Safefree(version);
ad63d80f 4334 return ver;
b0f01acb
JP		 4335}
4336
e0218a61
JP		 4337/*
4338=for apidoc vverify
4339
4340Validates that the SV contains a valid version object.
4341
4342 bool vverify(SV *vobj);
4343
4344Note that it only confirms the bare minimum structure (so as not to get
4345confused by derived classes which may contain additional hash entries):
4346
4347=over 4
4348
cb5772bb 4349=item * The SV contains a [reference to a] hash
e0218a61
JP		 4350
4351=item * The hash contains a "version" key
4352
cb5772bb 4353=item * The "version" key has [a reference to] an AV as its value
e0218a61
JP		 4354
4355=back
4356
4357=cut
4358*/
4359
4360bool
4361Perl_vverify(pTHX_ SV *vs)
4362{
4363 SV *sv;
4364 if ( SvROK(vs) )
4365 vs = SvRV(vs);
4366
4367 /* see if the appropriate elements exist */
4368 if ( SvTYPE(vs) == SVt_PVHV
4369 && hv_exists((HV*)vs, "version", 7)
017a3ce5 4370 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
e0218a61
JP		 4371 && SvTYPE(sv) == SVt_PVAV )
4372 return TRUE;
4373 else
4374 return FALSE;
4375}
b0f01acb
JP		 4376
4377/*
4378=for apidoc vnumify
4379
ad63d80f
JP		 4380Accepts a version object and returns the normalized floating
4381point representation. Call like:
b0f01acb 4382
ad63d80f 4383 sv = vnumify(rv);
b0f01acb 4384
ad63d80f
JP		 4385NOTE: you can pass either the object directly or the SV
4386contained within the RV.
b0f01acb
JP		 4387
4388=cut
4389*/
4390
4391SV *
ad63d80f 4392Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4393{
ad63d80f 4394 I32 i, len, digit;
9137345a
JP		 4395 int width;
4396 bool alpha = FALSE;
53c1dcc0 4397 SV * const sv = newSV(0);
9137345a 4398 AV *av;
ad63d80f
JP		 4399 if ( SvROK(vs) )
4400 vs = SvRV(vs);
9137345a 4401
e0218a61
JP		 4402 if ( !vverify(vs) )
4403 Perl_croak(aTHX_ "Invalid version object");
4404
9137345a
JP		 4405 /* see if various flags exist */
4406 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4407 alpha = TRUE;
4408 if ( hv_exists((HV*)vs, "width", 5 ) )
017a3ce5 4409 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
9137345a
JP		 4410 else
4411 width = 3;
4412
4413
4414 /* attempt to retrieve the version array */
017a3ce5 4415 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
396482e1 4416 sv_catpvs(sv,"0");
9137345a
JP		 4417 return sv;
4418 }
4419
4420 len = av_len(av);
46314c13
JP		 4421 if ( len == -1 )
4422 {
396482e1 4423 sv_catpvs(sv,"0");
46314c13
JP		 4424 return sv;
4425 }
9137345a
JP		 4426
4427 digit = SvIV(*av_fetch(av, 0, 0));
261fcdab 4428 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
13f8f398 4429 for ( i = 1 ; i < len ; i++ )
b0f01acb 4430 {
9137345a
JP		 4431 digit = SvIV(*av_fetch(av, i, 0));
4432 if ( width < 3 ) {
43eaf59d 4433 const int denom = (width == 2 ? 10 : 100);
53c1dcc0 4434 const div_t term = div((int)PERL_ABS(digit),denom);
261fcdab 4435 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
9137345a
JP		 4436 }
4437 else {
261fcdab 4438 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
9137345a 4439 }
b0f01acb 4440 }
13f8f398
JP		 4441
4442 if ( len > 0 )
4443 {
9137345a
JP		 4444 digit = SvIV(*av_fetch(av, len, 0));
4445 if ( alpha && width == 3 ) /* alpha version */
396482e1 4446 sv_catpvs(sv,"_");
261fcdab 4447 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
13f8f398 4448 }
e0218a61 4449 else /* len == 0 */
13f8f398 4450 {
396482e1 4451 sv_catpvs(sv, "000");
13f8f398 4452 }
b0f01acb
JP		 4453 return sv;
4454}
4455
4456/*
b9381830 4457=for apidoc vnormal
b0f01acb 4458
ad63d80f
JP		 4459Accepts a version object and returns the normalized string
4460representation. Call like:
b0f01acb 4461
b9381830 4462 sv = vnormal(rv);
b0f01acb 4463
ad63d80f
JP		 4464NOTE: you can pass either the object directly or the SV
4465contained within the RV.
b0f01acb
JP		 4466
4467=cut
4468*/
4469
4470SV *
b9381830 4471Perl_vnormal(pTHX_ SV *vs)
b0f01acb 4472{
ad63d80f 4473 I32 i, len, digit;
9137345a 4474 bool alpha = FALSE;
2d03de9c 4475 SV * const sv = newSV(0);
9137345a 4476 AV *av;
ad63d80f
JP		 4477 if ( SvROK(vs) )
4478 vs = SvRV(vs);
9137345a 4479
e0218a61
JP		 4480 if ( !vverify(vs) )
4481 Perl_croak(aTHX_ "Invalid version object");
4482
9137345a
JP		 4483 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4484 alpha = TRUE;
017a3ce5 4485 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
9137345a
JP		 4486
4487 len = av_len(av);
e0218a61
JP		 4488 if ( len == -1 )
4489 {
396482e1 4490 sv_catpvs(sv,"");
46314c13
JP		 4491 return sv;
4492 }
9137345a 4493 digit = SvIV(*av_fetch(av, 0, 0));
261fcdab 4494 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
cb5772bb 4495 for ( i = 1 ; i < len ; i++ ) {
9137345a 4496 digit = SvIV(*av_fetch(av, i, 0));
261fcdab 4497 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
9137345a
JP		 4498 }
4499
e0218a61
JP		 4500 if ( len > 0 )
4501 {
9137345a
JP		 4502 /* handle last digit specially */
4503 digit = SvIV(*av_fetch(av, len, 0));
4504 if ( alpha )
261fcdab 4505 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
ad63d80f 4506 else
261fcdab 4507 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
b0f01acb 4508 }
9137345a 4509
137d6fc0
JP		 4510 if ( len <= 2 ) { /* short version, must be at least three */
4511 for ( len = 2 - len; len != 0; len-- )
396482e1 4512 sv_catpvs(sv,".0");
137d6fc0 4513 }
b0f01acb 4514 return sv;
9137345a 4515}
b0f01acb 4516
ad63d80f 4517/*
b9381830
JP		 4518=for apidoc vstringify
4519
4520In order to maintain maximum compatibility with earlier versions
4521of Perl, this function will return either the floating point
4522notation or the multiple dotted notation, depending on whether
4523the original version contained 1 or more dots, respectively
4524
4525=cut
4526*/
4527
4528SV *
4529Perl_vstringify(pTHX_ SV *vs)
4530{
b9381830
JP		 4531 if ( SvROK(vs) )
4532 vs = SvRV(vs);
e0218a61
JP		 4533
4534 if ( !vverify(vs) )
4535 Perl_croak(aTHX_ "Invalid version object");
4536
9137345a 4537 if ( hv_exists((HV *)vs, "qv", 2) )
cb5772bb 4538 return vnormal(vs);
9137345a 4539 else
cb5772bb 4540 return vnumify(vs);
b9381830
JP		 4541}
4542
4543/*
ad63d80f
JP		 4544=for apidoc vcmp
4545
4546Version object aware cmp. Both operands must already have been
4547converted into version objects.
4548
4549=cut
4550*/
4551
4552int
9137345a 4553Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
ad63d80f
JP		 4554{
4555 I32 i,l,m,r,retval;
9137345a
JP		 4556 bool lalpha = FALSE;
4557 bool ralpha = FALSE;
4558 I32 left = 0;
4559 I32 right = 0;
4560 AV *lav, *rav;
4561 if ( SvROK(lhv) )
4562 lhv = SvRV(lhv);
4563 if ( SvROK(rhv) )
4564 rhv = SvRV(rhv);
4565
e0218a61
JP		 4566 if ( !vverify(lhv) )
4567 Perl_croak(aTHX_ "Invalid version object");
4568
4569 if ( !vverify(rhv) )
4570 Perl_croak(aTHX_ "Invalid version object");
4571
9137345a 4572 /* get the left hand term */
017a3ce5 4573 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
9137345a
JP		 4574 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4575 lalpha = TRUE;
4576
4577 /* and the right hand term */
017a3ce5 4578 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
9137345a
JP		 4579 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4580 ralpha = TRUE;
4581
4582 l = av_len(lav);
4583 r = av_len(rav);
ad63d80f
JP		 4584 m = l < r ? l : r;
4585 retval = 0;
4586 i = 0;
4587 while ( i <= m && retval == 0 )
4588 {
9137345a
JP		 4589 left = SvIV(*av_fetch(lav,i,0));
4590 right = SvIV(*av_fetch(rav,i,0));
4591 if ( left < right )
ad63d80f 4592 retval = -1;
9137345a 4593 if ( left > right )
ad63d80f
JP		 4594 retval = +1;
4595 i++;
4596 }
4597
9137345a
JP		 4598 /* tiebreaker for alpha with identical terms */
4599 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4600 {
4601 if ( lalpha && !ralpha )
4602 {
4603 retval = -1;
4604 }
4605 else if ( ralpha && !lalpha)
4606 {
4607 retval = +1;
4608 }
4609 }
4610
137d6fc0 4611 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
129318bd 4612 {
137d6fc0 4613 if ( l < r )
129318bd 4614 {
137d6fc0
JP		 4615 while ( i <= r && retval == 0 )
4616 {
9137345a 4617 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
137d6fc0
JP		 4618 retval = -1; /* not a match after all */
4619 i++;
4620 }
4621 }
4622 else
4623 {
4624 while ( i <= l && retval == 0 )
4625 {
9137345a 4626 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
137d6fc0
JP		 4627 retval = +1; /* not a match after all */
4628 i++;
4629 }
129318bd
JP		 4630 }
4631 }
ad63d80f
JP		 4632 return retval;
4633}
4634
c95c94b1 4635#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4636# define EMULATE_SOCKETPAIR_UDP
4637#endif
4638
4639#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4640static int
4641S_socketpair_udp (int fd[2]) {
e10bb1e9 4642 dTHX;
02fc2eee
NC		 4643 /* Fake a datagram socketpair using UDP to localhost. */
4644 int sockets[2] = {-1, -1};
4645 struct sockaddr_in addresses[2];
4646 int i;
3aed30dc 4647 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4648 unsigned short port;
02fc2eee
NC		 4649 int got;
4650
3aed30dc 4651 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4652 i = 1;
4653 do {
3aed30dc
HS		 4654 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4655 if (sockets[i] == -1)
4656 goto tidy_up_and_fail;
4657
4658 addresses[i].sin_family = AF_INET;
4659 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4660 addresses[i].sin_port = 0; /* kernel choses port. */
4661 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4662 sizeof(struct sockaddr_in)) == -1)
4663 goto tidy_up_and_fail;
02fc2eee
NC		 4664 } while (i--);
4665
4666 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4667 for each connect the other socket to it. */
4668 i = 1;
4669 do {
3aed30dc
HS		 4670 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4671 &size) == -1)
4672 goto tidy_up_and_fail;
4673 if (size != sizeof(struct sockaddr_in))
4674 goto abort_tidy_up_and_fail;
4675 /* !1 is 0, !0 is 1 */
4676 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4677 sizeof(struct sockaddr_in)) == -1)
4678 goto tidy_up_and_fail;
02fc2eee
NC		 4679 } while (i--);
4680
4681 /* Now we have 2 sockets connected to each other. I don't trust some other
4682 process not to have already sent a packet to us (by random) so send
4683 a packet from each to the other. */
4684 i = 1;
4685 do {
3aed30dc
HS		 4686 /* I'm going to send my own port number. As a short.
4687 (Who knows if someone somewhere has sin_port as a bitfield and needs
4688 this routine. (I'm assuming crays have socketpair)) */
4689 port = addresses[i].sin_port;
4690 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4691 if (got != sizeof(port)) {
4692 if (got == -1)
4693 goto tidy_up_and_fail;
4694 goto abort_tidy_up_and_fail;
4695 }
02fc2eee
NC		 4696 } while (i--);
4697
4698 /* Packets sent. I don't trust them to have arrived though.
4699 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4700 connect to localhost will use a second kernel thread. In 2.6 the
4701 first thread running the connect() returns before the second completes,
4702 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4703 returns 0. Poor programs have tripped up. One poor program's authors'
4704 had a 50-1 reverse stock split. Not sure how connected these were.)
4705 So I don't trust someone not to have an unpredictable UDP stack.
4706 */
4707
4708 {
3aed30dc
HS		 4709 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4710 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4711 fd_set rset;
4712
4713 FD_ZERO(&rset);
ea407a0c
NC		 4714 FD_SET((unsigned int)sockets[0], &rset);
4715 FD_SET((unsigned int)sockets[1], &rset);
3aed30dc
HS		 4716
4717 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4718 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4719 || !FD_ISSET(sockets[1], &rset)) {
4720 /* I hope this is portable and appropriate. */
4721 if (got == -1)
4722 goto tidy_up_and_fail;
4723 goto abort_tidy_up_and_fail;
4724 }
02fc2eee 4725 }
f4758303 4726
02fc2eee
NC		 4727 /* And the paranoia department even now doesn't trust it to have arrive
4728 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4729 {
3aed30dc
HS		 4730 struct sockaddr_in readfrom;
4731 unsigned short buffer[2];
02fc2eee 4732
3aed30dc
HS		 4733 i = 1;
4734 do {
02fc2eee 4735#ifdef MSG_DONTWAIT
3aed30dc
HS		 4736 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4737 sizeof(buffer), MSG_DONTWAIT,
4738 (struct sockaddr *) &readfrom, &size);
02fc2eee 4739#else
3aed30dc
HS		 4740 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4741 sizeof(buffer), 0,
4742 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4743#endif
02fc2eee 4744
3aed30dc
HS		 4745 if (got == -1)
4746 goto tidy_up_and_fail;
4747 if (got != sizeof(port)
4748 || size != sizeof(struct sockaddr_in)
4749 /* Check other socket sent us its port. */
4750 || buffer[0] != (unsigned short) addresses[!i].sin_port
4751 /* Check kernel says we got the datagram from that socket */
4752 || readfrom.sin_family != addresses[!i].sin_family
4753 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4754 || readfrom.sin_port != addresses[!i].sin_port)
4755 goto abort_tidy_up_and_fail;
4756 } while (i--);
02fc2eee
NC		 4757 }
4758 /* My caller (my_socketpair) has validated that this is non-NULL */
4759 fd[0] = sockets[0];
4760 fd[1] = sockets[1];
4761 /* I hereby declare this connection open. May God bless all who cross
4762 her. */
4763 return 0;
4764
4765 abort_tidy_up_and_fail:
4766 errno = ECONNABORTED;
4767 tidy_up_and_fail:
4768 {
4373e329 4769 const int save_errno = errno;
3aed30dc
HS		 4770 if (sockets[0] != -1)
4771 PerlLIO_close(sockets[0]);
4772 if (sockets[1] != -1)
4773 PerlLIO_close(sockets[1]);
4774 errno = save_errno;
4775 return -1;
02fc2eee
NC		 4776 }
4777}
85ca448a 4778#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4779
b5ac89c3 4780#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4781int
4782Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4783 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4784 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4785 dTHX;
02fc2eee
NC		 4786 int listener = -1;
4787 int connector = -1;
4788 int acceptor = -1;
4789 struct sockaddr_in listen_addr;
4790 struct sockaddr_in connect_addr;
4791 Sock_size_t size;
4792
50458334
JH		 4793 if (protocol
4794#ifdef AF_UNIX
4795 || family != AF_UNIX
4796#endif
3aed30dc
HS		 4797 ) {
4798 errno = EAFNOSUPPORT;
4799 return -1;
02fc2eee 4800 }
2948e0bd 4801 if (!fd) {
3aed30dc
HS		 4802 errno = EINVAL;
4803 return -1;
2948e0bd 4804 }
02fc2eee 4805
2bc69dc4 4806#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4807 if (type == SOCK_DGRAM)
3aed30dc 4808 return S_socketpair_udp(fd);
2bc69dc4 4809#endif
02fc2eee 4810
3aed30dc 4811 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4812 if (listener == -1)
3aed30dc
HS		 4813 return -1;
4814 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4815 listen_addr.sin_family = AF_INET;
3aed30dc 4816 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4817 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4818 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4819 sizeof(listen_addr)) == -1)
4820 goto tidy_up_and_fail;
e10bb1e9 4821 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4822 goto tidy_up_and_fail;
02fc2eee 4823
3aed30dc 4824 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4825 if (connector == -1)
3aed30dc 4826 goto tidy_up_and_fail;
02fc2eee 4827 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4828 size = sizeof(connect_addr);
4829 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4830 &size) == -1)
4831 goto tidy_up_and_fail;
4832 if (size != sizeof(connect_addr))
4833 goto abort_tidy_up_and_fail;
e10bb1e9 4834 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4835 sizeof(connect_addr)) == -1)
4836 goto tidy_up_and_fail;
02fc2eee 4837
3aed30dc
HS		 4838 size = sizeof(listen_addr);
4839 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4840 &size);
02fc2eee 4841 if (acceptor == -1)
3aed30dc
HS		 4842 goto tidy_up_and_fail;
4843 if (size != sizeof(listen_addr))
4844 goto abort_tidy_up_and_fail;
4845 PerlLIO_close(listener);
02fc2eee
NC		 4846 /* Now check we are talking to ourself by matching port and host on the
4847 two sockets. */
3aed30dc
HS		 4848 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4849 &size) == -1)
4850 goto tidy_up_and_fail;
4851 if (size != sizeof(connect_addr)
4852 || listen_addr.sin_family != connect_addr.sin_family
4853 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4854 || listen_addr.sin_port != connect_addr.sin_port) {
4855 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4856 }
4857 fd[0] = connector;
4858 fd[1] = acceptor;
4859 return 0;
4860
4861 abort_tidy_up_and_fail:
27da23d5
JH		 4862#ifdef ECONNABORTED
4863 errno = ECONNABORTED; /* This would be the standard thing to do. */
4864#else
4865# ifdef ECONNREFUSED
4866 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4867# else
4868 errno = ETIMEDOUT; /* Desperation time. */
4869# endif
4870#endif
02fc2eee
NC		 4871 tidy_up_and_fail:
4872 {
7452cf6a 4873 const int save_errno = errno;
3aed30dc
HS		 4874 if (listener != -1)
4875 PerlLIO_close(listener);
4876 if (connector != -1)
4877 PerlLIO_close(connector);
4878 if (acceptor != -1)
4879 PerlLIO_close(acceptor);
4880 errno = save_errno;
4881 return -1;
02fc2eee
NC		 4882 }
4883}
85ca448a 4884#else
48ea76d1
JH		 4885/* In any case have a stub so that there's code corresponding
4886 * to the my_socketpair in global.sym. */
4887int
4888Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4889#ifdef HAS_SOCKETPAIR
48ea76d1 4890 return socketpair(family, type, protocol, fd);
daf16542
JH		 4891#else
4892 return -1;
4893#endif
48ea76d1
JH		 4894}
4895#endif
4896
68795e93
NIS		 4897/*
4898
4899=for apidoc sv_nosharing
4900
4901Dummy routine which "shares" an SV when there is no sharing module present.
d5b2b27b
NC		 4902Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4903Exists to avoid test for a NULL function pointer and because it could
4904potentially warn under some level of strict-ness.
68795e93
NIS		 4905
4906=cut
4907*/
4908
4909void
4910Perl_sv_nosharing(pTHX_ SV *sv)
4911{
96a5add6 4912 PERL_UNUSED_CONTEXT;
53c1dcc0 4913 PERL_UNUSED_ARG(sv);
68795e93
NIS		 4914}
4915
a05d7ebb 4916U32
e1ec3a88 4917Perl_parse_unicode_opts(pTHX_ const char **popt)
a05d7ebb 4918{
e1ec3a88 4919 const char *p = *popt;
a05d7ebb
JH		 4920 U32 opt = 0;
4921
4922 if (*p) {
4923 if (isDIGIT(*p)) {
4924 opt = (U32) atoi(p);
35da51f7
AL		 4925 while (isDIGIT(*p))
4926 p++;
7c91f477 4927 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 4928 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4929 }
4930 else {
4931 for (; *p; p++) {
4932 switch (*p) {
4933 case PERL_UNICODE_STDIN:
4934 opt |= PERL_UNICODE_STDIN_FLAG; break;
4935 case PERL_UNICODE_STDOUT:
4936 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4937 case PERL_UNICODE_STDERR:
4938 opt |= PERL_UNICODE_STDERR_FLAG; break;
4939 case PERL_UNICODE_STD:
4940 opt |= PERL_UNICODE_STD_FLAG; break;
4941 case PERL_UNICODE_IN:
4942 opt |= PERL_UNICODE_IN_FLAG; break;
4943 case PERL_UNICODE_OUT:
4944 opt |= PERL_UNICODE_OUT_FLAG; break;
4945 case PERL_UNICODE_INOUT:
4946 opt |= PERL_UNICODE_INOUT_FLAG; break;
4947 case PERL_UNICODE_LOCALE:
4948 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4949 case PERL_UNICODE_ARGV:
4950 opt |= PERL_UNICODE_ARGV_FLAG; break;
5a22a2bb
NC		 4951 case PERL_UNICODE_UTF8CACHEASSERT:
4952 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
a05d7ebb 4953 default:
7c91f477
JH		 4954 if (*p != '\n' && *p != '\r')
4955 Perl_croak(aTHX_
4956 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 4957 }
4958 }
4959 }
4960 }
4961 else
4962 opt = PERL_UNICODE_DEFAULT_FLAGS;
4963
4964 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 4965 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 4966 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4967
4968 *popt = p;
4969
4970 return opt;
4971}
4972
132efe8b
JH		 4973U32
4974Perl_seed(pTHX)
4975{
97aff369 4976 dVAR;
132efe8b
JH		 4977 /*
4978 * This is really just a quick hack which grabs various garbage
4979 * values. It really should be a real hash algorithm which
4980 * spreads the effect of every input bit onto every output bit,
4981 * if someone who knows about such things would bother to write it.
4982 * Might be a good idea to add that function to CORE as well.
4983 * No numbers below come from careful analysis or anything here,
4984 * except they are primes and SEED_C1 > 1E6 to get a full-width
4985 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4986 * probably be bigger too.
4987 */
4988#if RANDBITS > 16
4989# define SEED_C1 1000003
4990#define SEED_C4 73819
4991#else
4992# define SEED_C1 25747
4993#define SEED_C4 20639
4994#endif
4995#define SEED_C2 3
4996#define SEED_C3 269
4997#define SEED_C5 26107
4998
4999#ifndef PERL_NO_DEV_RANDOM
5000 int fd;
5001#endif
5002 U32 u;
5003#ifdef VMS
5004# include <starlet.h>
5005 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5006 * in 100-ns units, typically incremented ever 10 ms. */
5007 unsigned int when[2];
5008#else
5009# ifdef HAS_GETTIMEOFDAY
5010 struct timeval when;
5011# else
5012 Time_t when;
5013# endif
5014#endif
5015
5016/* This test is an escape hatch, this symbol isn't set by Configure. */
5017#ifndef PERL_NO_DEV_RANDOM
5018#ifndef PERL_RANDOM_DEVICE
5019 /* /dev/random isn't used by default because reads from it will block
5020 * if there isn't enough entropy available. You can compile with
5021 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5022 * is enough real entropy to fill the seed. */
5023# define PERL_RANDOM_DEVICE "/dev/urandom"
5024#endif
5025 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5026 if (fd != -1) {
27da23d5 5027 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
132efe8b
JH		 5028 u = 0;
5029 PerlLIO_close(fd);
5030 if (u)
5031 return u;
5032 }
5033#endif
5034
5035#ifdef VMS
5036 _ckvmssts(sys$gettim(when));
5037 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5038#else
5039# ifdef HAS_GETTIMEOFDAY
5040 PerlProc_gettimeofday(&when,NULL);
5041 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5042# else
5043 (void)time(&when);
5044 u = (U32)SEED_C1 * when;
5045# endif
5046#endif
5047 u += SEED_C3 * (U32)PerlProc_getpid();
5048 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5049#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5050 u += SEED_C5 * (U32)PTR2UV(&when);
5051#endif
5052 return u;
5053}
5054
bed60192 5055UV
a783c5f4 5056Perl_get_hash_seed(pTHX)
bed60192 5057{
97aff369 5058 dVAR;
e1ec3a88 5059 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
bed60192
JH		 5060 UV myseed = 0;
5061
5062 if (s)
35da51f7
AL		 5063 while (isSPACE(*s))
5064 s++;
bed60192
JH		 5065 if (s && isDIGIT(*s))
5066 myseed = (UV)Atoul(s);
5067 else
5068#ifdef USE_HASH_SEED_EXPLICIT
5069 if (s)
5070#endif
5071 {
5072 /* Compute a random seed */
5073 (void)seedDrand01((Rand_seed_t)seed());
bed60192
JH		 5074 myseed = (UV)(Drand01() * (NV)UV_MAX);
5075#if RANDBITS < (UVSIZE * 8)
5076 /* Since there are not enough randbits to to reach all
5077 * the bits of a UV, the low bits might need extra
5078 * help. Sum in another random number that will
5079 * fill in the low bits. */
5080 myseed +=
5081 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5082#endif /* RANDBITS < (UVSIZE * 8) */
6cfd5ea7
JH		 5083 if (myseed == 0) { /* Superparanoia. */
5084 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5085 if (myseed == 0)
5086 Perl_croak(aTHX_ "Your random numbers are not that random");
5087 }
bed60192 5088 }
008fb0c0 5089 PL_rehash_seed_set = TRUE;
bed60192
JH		 5090
5091 return myseed;
5092}
27da23d5 5093
ed221c57
AL		 5094#ifdef USE_ITHREADS
5095bool
5096Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5097{
5098 const char * const stashpv = CopSTASHPV(c);
5099 const char * const name = HvNAME_get(hv);
96a5add6 5100 PERL_UNUSED_CONTEXT;
ed221c57
AL		 5101
5102 if (stashpv == name)
5103 return TRUE;
5104 if (stashpv && name)
5105 if (strEQ(stashpv, name))
5106 return TRUE;
5107 return FALSE;
5108}
5109#endif
5110
5111
27da23d5
JH		 5112#ifdef PERL_GLOBAL_STRUCT
5113
5114struct perl_vars *
5115Perl_init_global_struct(pTHX)
5116{
5117 struct perl_vars *plvarsp = NULL;
5118#ifdef PERL_GLOBAL_STRUCT
5119# define PERL_GLOBAL_STRUCT_INIT
5120# include "opcode.h" /* the ppaddr and check */
7452cf6a
AL		 5121 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5122 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
27da23d5
JH		 5123# ifdef PERL_GLOBAL_STRUCT_PRIVATE
5124 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5125 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5126 if (!plvarsp)
5127 exit(1);
5128# else
5129 plvarsp = PL_VarsPtr;
5130# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
aadb217d
JH		 5131# undef PERLVAR
5132# undef PERLVARA
5133# undef PERLVARI
5134# undef PERLVARIC
5135# undef PERLVARISC
27da23d5
JH		 5136# define PERLVAR(var,type) /**/
5137# define PERLVARA(var,n,type) /**/
5138# define PERLVARI(var,type,init) plvarsp->var = init;
5139# define PERLVARIC(var,type,init) plvarsp->var = init;
5140# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5141# include "perlvars.h"
5142# undef PERLVAR
5143# undef PERLVARA
5144# undef PERLVARI
5145# undef PERLVARIC
5146# undef PERLVARISC
5147# ifdef PERL_GLOBAL_STRUCT
5148 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5149 if (!plvarsp->Gppaddr)
5150 exit(1);
5151 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5152 if (!plvarsp->Gcheck)
5153 exit(1);
5154 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5155 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5156# endif
5157# ifdef PERL_SET_VARS
5158 PERL_SET_VARS(plvarsp);
5159# endif
5160# undef PERL_GLOBAL_STRUCT_INIT
5161#endif
5162 return plvarsp;
5163}
5164
5165#endif /* PERL_GLOBAL_STRUCT */
5166
5167#ifdef PERL_GLOBAL_STRUCT
5168
5169void
5170Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5171{
5172#ifdef PERL_GLOBAL_STRUCT
5173# ifdef PERL_UNSET_VARS
5174 PERL_UNSET_VARS(plvarsp);
5175# endif
5176 free(plvarsp->Gppaddr);
5177 free(plvarsp->Gcheck);
5178# ifdef PERL_GLOBAL_STRUCT_PRIVATE
5179 free(plvarsp);
5180# endif
5181#endif
5182}
5183
5184#endif /* PERL_GLOBAL_STRUCT */
5185
fe4f188c
JH		 5186#ifdef PERL_MEM_LOG
5187
65ceff02
JH		 5188/*
5189 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5190 *
5191 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5192 * variable PERL_MEM_LOG will be consulted, and if the integer value
5193 * of that is true, the logging will happen. (The default is to
5194 * always log if the PERL_MEM_LOG define was in effect.)
5195 */
5196
5197/*
5198 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5199 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5200 */
e352bcff
JH		 5201#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5202
65ceff02
JH		 5203/*
5204 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5205 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5206 * in which case the environment variable PERL_MEM_LOG_FD will be
5207 * consulted for the file descriptor number to use.
5208 */
5209#ifndef PERL_MEM_LOG_FD
5210# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5211#endif
5212
fe4f188c 5213Malloc_t
46c6c7e2 5214Perl_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		 5215{
5216#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5217# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5218 char *s;
5219# endif
5220# ifdef PERL_MEM_LOG_ENV
5221 s = getenv("PERL_MEM_LOG");
5222 if (s ? atoi(s) : 0)
5223# endif
5224 {
5225 /* We can't use SVs or PerlIO for obvious reasons,
5226 * so we'll use stdio and low-level IO instead. */
5227 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5228# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02 5229 struct timeval tv;
5b692037 5230# ifdef HAS_GETTIMEOFDAY
65ceff02 5231 gettimeofday(&tv, 0);
5b692037
JH		 5232# endif
5233 /* If there are other OS specific ways of hires time than
5234 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5235 * probably that they would be used to fill in the struct
5236 * timeval. */
5237# endif
65ceff02
JH		 5238 {
5239 const STRLEN len =
d9fad198 5240 my_snprintf(buf,
d1307786 5241 sizeof(buf),
5b692037
JH		 5242# ifdef PERL_MEM_LOG_TIMESTAMP
5243 "%10d.%06d: "
5244# endif
d9fad198
JH		 5245 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5246 " %s = %"IVdf": %"UVxf"\n",
5b692037
JH		 5247# ifdef PERL_MEM_LOG_TIMESTAMP
5248 (int)tv.tv_sec, (int)tv.tv_usec,
5249# endif
d9fad198
JH		 5250 filename, linenumber, funcname, n, typesize,
5251 typename, n * typesize, PTR2UV(newalloc));
65ceff02
JH		 5252# ifdef PERL_MEM_LOG_ENV_FD
5253 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5254 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5255# else
5256 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5257#endif
5258 }
5259 }
fe4f188c
JH		 5260#endif
5261 return newalloc;
5262}
5263
5264Malloc_t
46c6c7e2 5265Perl_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		 5266{
5267#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5268# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5269 char *s;
5270# endif
5271# ifdef PERL_MEM_LOG_ENV
5272 s = PerlEnv_getenv("PERL_MEM_LOG");
5273 if (s ? atoi(s) : 0)
5274# endif
5275 {
5276 /* We can't use SVs or PerlIO for obvious reasons,
5277 * so we'll use stdio and low-level IO instead. */
5278 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5279# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02
JH		 5280 struct timeval tv;
5281 gettimeofday(&tv, 0);
5b692037 5282# endif
65ceff02
JH		 5283 {
5284 const STRLEN len =
d9fad198 5285 my_snprintf(buf,
d1307786 5286 sizeof(buf),
5b692037
JH		 5287# ifdef PERL_MEM_LOG_TIMESTAMP
5288 "%10d.%06d: "
5289# endif
d9fad198
JH		 5290 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5291 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5b692037
JH		 5292# ifdef PERL_MEM_LOG_TIMESTAMP
5293 (int)tv.tv_sec, (int)tv.tv_usec,
5294# endif
d9fad198
JH		 5295 filename, linenumber, funcname, n, typesize,
5296 typename, n * typesize, PTR2UV(oldalloc),
5297 PTR2UV(newalloc));
65ceff02
JH		 5298# ifdef PERL_MEM_LOG_ENV_FD
5299 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5300 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5301# else
5302 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5303# endif
5304 }
5305 }
fe4f188c
JH		 5306#endif
5307 return newalloc;
5308}
5309
5310Malloc_t
46c6c7e2 5311Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5312{
5313#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5314# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5315 char *s;
5316# endif
5317# ifdef PERL_MEM_LOG_ENV
5318 s = PerlEnv_getenv("PERL_MEM_LOG");
5319 if (s ? atoi(s) : 0)
5320# endif
5321 {
5322 /* We can't use SVs or PerlIO for obvious reasons,
5323 * so we'll use stdio and low-level IO instead. */
5324 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5325# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02
JH		 5326 struct timeval tv;
5327 gettimeofday(&tv, 0);
5b692037 5328# endif
65ceff02
JH		 5329 {
5330 const STRLEN len =
d9fad198 5331 my_snprintf(buf,
d1307786 5332 sizeof(buf),
5b692037
JH		 5333# ifdef PERL_MEM_LOG_TIMESTAMP
5334 "%10d.%06d: "
5335# endif
5336 "free: %s:%d:%s: %"UVxf"\n",
5337# ifdef PERL_MEM_LOG_TIMESTAMP
d9fad198 5338 (int)tv.tv_sec, (int)tv.tv_usec,
5b692037 5339# endif
d9fad198
JH		 5340 filename, linenumber, funcname,
5341 PTR2UV(oldalloc));
65ceff02
JH		 5342# ifdef PERL_MEM_LOG_ENV_FD
5343 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5344 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5345# else
5346 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5347# endif
5348 }
5349 }
fe4f188c
JH		 5350#endif
5351 return oldalloc;
5352}
5353
5354#endif /* PERL_MEM_LOG */
5355
66610fdd 5356/*
ce582cee
NC		 5357=for apidoc my_sprintf
5358
5359The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5360the length of the string written to the buffer. Only rare pre-ANSI systems
5361need the wrapper function - usually this is a direct call to C<sprintf>.
5362
5363=cut
5364*/
5365#ifndef SPRINTF_RETURNS_STRLEN
5366int
5367Perl_my_sprintf(char *buffer, const char* pat, ...)
5368{
5369 va_list args;
5370 va_start(args, pat);
5371 vsprintf(buffer, pat, args);
5372 va_end(args);
5373 return strlen(buffer);
5374}
5375#endif
5376
d9fad198
JH		 5377/*
5378=for apidoc my_snprintf
5379
5380The C library C<snprintf> functionality, if available and
5b692037 5381standards-compliant (uses C<vsnprintf>, actually). However, if the
d9fad198 5382C<vsnprintf> is not available, will unfortunately use the unsafe
5b692037
JH		 5383C<vsprintf> which can overrun the buffer (there is an overrun check,
5384but that may be too late). Consider using C<sv_vcatpvf> instead, or
5385getting C<vsnprintf>.
d9fad198
JH		 5386
5387=cut
5388*/
5389int
5390Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
d9fad198
JH		 5391{
5392 dTHX;
5393 int retval;
5394 va_list ap;
d9fad198 5395 va_start(ap, format);
5b692037 5396#ifdef HAS_VSNPRINTF
d9fad198
JH		 5397 retval = vsnprintf(buffer, len, format, ap);
5398#else
5399 retval = vsprintf(buffer, format, ap);
5400#endif
5401 va_end(ap);
1208b3dd 5402 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
625dac9d 5403 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5b692037 5404 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
d9fad198
JH		 5405 return retval;
5406}
5407
5408/*
5409=for apidoc my_vsnprintf
5410
5b692037
JH		 5411The C library C<vsnprintf> if available and standards-compliant.
5412However, if if the C<vsnprintf> is not available, will unfortunately
5413use the unsafe C<vsprintf> which can overrun the buffer (there is an
5414overrun check, but that may be too late). Consider using
5415C<sv_vcatpvf> instead, or getting C<vsnprintf>.
d9fad198
JH		 5416
5417=cut
5418*/
5419int
5420Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
d9fad198
JH		 5421{
5422 dTHX;
5423 int retval;
d9fad198
JH		 5424#ifdef NEED_VA_COPY
5425 va_list apc;
239fec62 5426 Perl_va_copy(ap, apc);
5b692037 5427# ifdef HAS_VSNPRINTF
d9fad198
JH		 5428 retval = vsnprintf(buffer, len, format, apc);
5429# else
5430 retval = vsprintf(buffer, format, apc);
5431# endif
5432#else
5b692037 5433# ifdef HAS_VSNPRINTF
d9fad198
JH		 5434 retval = vsnprintf(buffer, len, format, ap);
5435# else
5436 retval = vsprintf(buffer, format, ap);
5437# endif
5b692037 5438#endif /* #ifdef NEED_VA_COPY */
1208b3dd 5439 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
625dac9d 5440 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5b692037 5441 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
d9fad198
JH		 5442 return retval;
5443}
5444
b0269e46
AB		 5445void
5446Perl_my_clearenv(pTHX)
5447{
5448 dVAR;
5449#if ! defined(PERL_MICRO)
5450# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5451 PerlEnv_clearenv();
5452# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5453# if defined(USE_ENVIRON_ARRAY)
5454# if defined(USE_ITHREADS)
5455 /* only the parent thread can clobber the process environment */
5456 if (PL_curinterp == aTHX)
5457# endif /* USE_ITHREADS */
5458 {
5459# if ! defined(PERL_USE_SAFE_PUTENV)
5460 if ( !PL_use_safe_putenv) {
5461 I32 i;
5462 if (environ == PL_origenviron)
5463 environ = (char**)safesysmalloc(sizeof(char*));
5464 else
5465 for (i = 0; environ[i]; i++)
5466 (void)safesysfree(environ[i]);
5467 }
5468 environ[0] = NULL;
5469# else /* PERL_USE_SAFE_PUTENV */
5470# if defined(HAS_CLEARENV)
5471 (void)clearenv();
5472# elif defined(HAS_UNSETENV)
5473 int bsiz = 80; /* Most envvar names will be shorter than this. */
d1307786
JH		 5474 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5475 char *buf = (char*)safesysmalloc(bufsiz);
b0269e46
AB		 5476 while (*environ != NULL) {
5477 char *e = strchr(*environ, '=');
b57a0404 5478 int l = e ? e - *environ : (int)strlen(*environ);
b0269e46
AB		 5479 if (bsiz < l + 1) {
5480 (void)safesysfree(buf);
1bdfa2de 5481 bsiz = l + 1; /* + 1 for the \0. */
d1307786 5482 buf = (char*)safesysmalloc(bufsiz);
b0269e46 5483 }
1bdfa2de 5484 my_strlcpy(buf, *environ, l + 1);
b0269e46
AB		 5485 (void)unsetenv(buf);
5486 }
5487 (void)safesysfree(buf);
5488# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5489 /* Just null environ and accept the leakage. */
5490 *environ = NULL;
5491# endif /* HAS_CLEARENV || HAS_UNSETENV */
5492# endif /* ! PERL_USE_SAFE_PUTENV */
5493 }
5494# endif /* USE_ENVIRON_ARRAY */
5495# endif /* PERL_IMPLICIT_SYS || WIN32 */
5496#endif /* PERL_MICRO */
5497}
5498
f16dd614
DM		 5499#ifdef PERL_IMPLICIT_CONTEXT
5500
5501/* implements the MY_CXT_INIT macro. The first time a module is loaded,
5502the global PL_my_cxt_index is incremented, and that value is assigned to
5503that module's static my_cxt_index (who's address is passed as an arg).
5504Then, for each interpreter this function is called for, it makes sure a
5505void* slot is available to hang the static data off, by allocating or
5506extending the interpreter's PL_my_cxt_list array */
5507
5508void *
5509Perl_my_cxt_init(pTHX_ int *index, size_t size)
5510{
97aff369 5511 dVAR;
f16dd614
DM		 5512 void *p;
5513 if (*index == -1) {
5514 /* this module hasn't been allocated an index yet */
5515 MUTEX_LOCK(&PL_my_ctx_mutex);
5516 *index = PL_my_cxt_index++;
5517 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5518 }
5519
5520 /* make sure the array is big enough */
4c901e72
DM		 5521 if (PL_my_cxt_size <= *index) {
5522 if (PL_my_cxt_size) {
5523 while (PL_my_cxt_size <= *index)
f16dd614
DM		 5524 PL_my_cxt_size *= 2;
5525 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5526 }
5527 else {
5528 PL_my_cxt_size = 16;
5529 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5530 }
5531 }
5532 /* newSV() allocates one more than needed */
5533 p = (void*)SvPVX(newSV(size-1));
5534 PL_my_cxt_list[*index] = p;
5535 Zero(p, size, char);
5536 return p;
5537}
5538#endif
5539
a6cc4119
SP		 5540#ifndef HAS_STRLCAT
5541Size_t
5542Perl_my_strlcat(char *dst, const char *src, Size_t size)
5543{
5544 Size_t used, length, copy;
5545
5546 used = strlen(dst);
5547 length = strlen(src);
5548 if (size > 0 && used < size - 1) {
5549 copy = (length >= size - used) ? size - used - 1 : length;
5550 memcpy(dst + used, src, copy);
5551 dst[used + copy] = '\0';
5552 }
5553 return used + length;
5554}
5555#endif
5556
5557#ifndef HAS_STRLCPY
5558Size_t
5559Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5560{
5561 Size_t length, copy;
5562
5563 length = strlen(src);
5564 if (size > 0) {
5565 copy = (length >= size) ? size - 1 : length;
5566 memcpy(dst, src, copy);
5567 dst[copy] = '\0';
5568 }
5569 return length;
5570}
5571#endif
5572
ce582cee 5573/*
66610fdd
RGS		 5574 * Local variables:
5575 * c-indentation-style: bsd
5576 * c-basic-offset: 4
5577 * indent-tabs-mode: t
5578 * End:
5579 *
37442d52
RGS		 5580 * ex: set ts=8 sts=4 sw=4 noet:
5581 */
Unnamed repository; edit this file 'description' to name the repository.