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