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