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
add 1.875c to the list of supported bisons
[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) &&
7c1e0849 1011 SvCUR(PL_rs) == 1 && *SvPVX(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)) {
63315e18 1364 SV *msv = vmess(pat, args);
d13b0d77 1365 STRLEN msglen;
e1ec3a88 1366 const char *message = SvPV(msv, msglen);
63315e18 1367 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
864dbfa3 2713Perl_same_dirent(pTHX_ char *a, 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);
c6ed36e1 2735 if (PerlLIO_stat(SvPVX(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);
c6ed36e1 2741 if (PerlLIO_stat(SvPVX(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
HS		 3684 if (getcwd(buf, sizeof(buf) - 1)) {
3685 STRLEN len = strlen(buf);
3686 sv_setpvn(sv, buf, len);
3687 return TRUE;
3688 }
3689 else {
3690 sv_setsv(sv, &PL_sv_undef);
3691 return FALSE;
3692 }
8f95b30d
JH		 3693 }
3694
3695#else
3696
c623ac67 3697 Stat_t statbuf;
877f6a72
NIS		 3698 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3699 int namelen, pathlen=0;
3700 DIR *dir;
3701 Direntry_t *dp;
877f6a72
NIS		 3702
3703 (void)SvUPGRADE(sv, SVt_PV);
3704
877f6a72 3705 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3706 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3707 }
3708
3709 orig_cdev = statbuf.st_dev;
3710 orig_cino = statbuf.st_ino;
3711 cdev = orig_cdev;
3712 cino = orig_cino;
3713
3714 for (;;) {
3aed30dc
HS		 3715 odev = cdev;
3716 oino = cino;
3717
3718 if (PerlDir_chdir("..") < 0) {
3719 SV_CWD_RETURN_UNDEF;
3720 }
3721 if (PerlLIO_stat(".", &statbuf) < 0) {
3722 SV_CWD_RETURN_UNDEF;
3723 }
3724
3725 cdev = statbuf.st_dev;
3726 cino = statbuf.st_ino;
3727
3728 if (odev == cdev && oino == cino) {
3729 break;
3730 }
3731 if (!(dir = PerlDir_open("."))) {
3732 SV_CWD_RETURN_UNDEF;
3733 }
3734
3735 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3736#ifdef DIRNAMLEN
3aed30dc 3737 namelen = dp->d_namlen;
877f6a72 3738#else
3aed30dc 3739 namelen = strlen(dp->d_name);
877f6a72 3740#endif
3aed30dc
HS		 3741 /* skip . and .. */
3742 if (SV_CWD_ISDOT(dp)) {
3743 continue;
3744 }
3745
3746 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3747 SV_CWD_RETURN_UNDEF;
3748 }
3749
3750 tdev = statbuf.st_dev;
3751 tino = statbuf.st_ino;
3752 if (tino == oino && tdev == odev) {
3753 break;
3754 }
cb5953d6
JH		 3755 }
3756
3aed30dc
HS		 3757 if (!dp) {
3758 SV_CWD_RETURN_UNDEF;
3759 }
3760
3761 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3762 SV_CWD_RETURN_UNDEF;
3763 }
877f6a72 3764
3aed30dc
HS		 3765 SvGROW(sv, pathlen + namelen + 1);
3766
3767 if (pathlen) {
3768 /* shift down */
3769 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3770 }
877f6a72 3771
3aed30dc
HS		 3772 /* prepend current directory to the front */
3773 *SvPVX(sv) = '/';
3774 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3775 pathlen += (namelen + 1);
877f6a72
NIS		 3776
3777#ifdef VOID_CLOSEDIR
3aed30dc 3778 PerlDir_close(dir);
877f6a72 3779#else
3aed30dc
HS		 3780 if (PerlDir_close(dir) < 0) {
3781 SV_CWD_RETURN_UNDEF;
3782 }
877f6a72
NIS		 3783#endif
3784 }
3785
60e110a8 3786 if (pathlen) {
3aed30dc
HS		 3787 SvCUR_set(sv, pathlen);
3788 *SvEND(sv) = '\0';
3789 SvPOK_only(sv);
877f6a72 3790
2a45baea 3791 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3aed30dc
HS		 3792 SV_CWD_RETURN_UNDEF;
3793 }
877f6a72
NIS		 3794 }
3795 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 3796 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3797 }
3798
3799 cdev = statbuf.st_dev;
3800 cino = statbuf.st_ino;
3801
3802 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 3803 Perl_croak(aTHX_ "Unstable directory path, "
3804 "current directory changed unexpectedly");
877f6a72 3805 }
877f6a72
NIS		 3806
3807 return TRUE;
793b8d8e
JH		 3808#endif
3809
877f6a72
NIS		 3810#else
3811 return FALSE;
3812#endif
3813}
3814
f4758303 3815/*
b0f01acb
JP		 3816=for apidoc scan_version
3817
3818Returns a pointer to the next character after the parsed
3819version string, as well as upgrading the passed in SV to
3820an RV.
3821
3822Function must be called with an already existing SV like
3823
137d6fc0
JP		 3824 sv = newSV(0);
3825 s = scan_version(s,SV *sv, bool qv);
b0f01acb
JP		 3826
3827Performs some preprocessing to the string to ensure that
3828it has the correct characteristics of a version. Flags the
3829object if it contains an underscore (which denotes this
137d6fc0
JP		 3830is a alpha version). The boolean qv denotes that the version
3831should be interpreted as if it had multiple decimals, even if
3832it doesn't.
b0f01acb
JP		 3833
3834=cut
3835*/
3836
3837char *
e1ec3a88 3838Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
b0f01acb 3839{
e568f1a0 3840 const char *start = s;
e1ec3a88 3841 const char *pos = s;
ad63d80f
JP		 3842 I32 saw_period = 0;
3843 bool saw_under = 0;
be2ebcad 3844 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
ad63d80f 3845 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
f9be5ac8 3846 AvREAL_on((AV*)sv);
ad63d80f
JP		 3847
3848 /* pre-scan the imput string to check for decimals */
3849 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3850 {
3851 if ( *pos == '.' )
3852 {
3853 if ( saw_under )
5f89c282 3854 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 3855 saw_period++ ;
46314c13 3856 }
ad63d80f
JP		 3857 else if ( *pos == '_' )
3858 {
3859 if ( saw_under )
5f89c282 3860 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
ad63d80f
JP		 3861 saw_under = 1;
3862 }
3863 pos++;
3864 }
3865 pos = s;
3866
137d6fc0
JP		 3867 if (*pos == 'v') {
3868 pos++; /* get past 'v' */
3869 qv = 1; /* force quoted version processing */
3870 }
ad63d80f 3871 while (isDIGIT(*pos))
46314c13 3872 pos++;
ad63d80f
JP		 3873 if (!isALPHA(*pos)) {
3874 I32 rev;
3875
3876 if (*s == 'v') s++; /* get past 'v' */
3877
3878 for (;;) {
3879 rev = 0;
3880 {
129318bd 3881 /* this is atoi() that delimits on underscores */
e1ec3a88 3882 const char *end = pos;
129318bd
JP		 3883 I32 mult = 1;
3884 I32 orev;
3885 if ( s < pos && s > start && *(s-1) == '_' ) {
137d6fc0 3886 mult *= -1; /* alpha version */
129318bd
JP		 3887 }
3888 /* the following if() will only be true after the decimal
3889 * point of a version originally created with a bare
3890 * floating point number, i.e. not quoted in any way
3891 */
13f8f398 3892 if ( !qv && s > start+1 && saw_period == 1 ) {
c76df65e 3893 mult *= 100;
129318bd
JP		 3894 while ( s < end ) {
3895 orev = rev;
3896 rev += (*s - '0') * mult;
3897 mult /= 10;
32fdb065 3898 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3899 Perl_croak(aTHX_ "Integer overflow in version");
3900 s++;
3901 }
3902 }
3903 else {
3904 while (--end >= s) {
3905 orev = rev;
3906 rev += (*end - '0') * mult;
3907 mult *= 10;
32fdb065 3908 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3909 Perl_croak(aTHX_ "Integer overflow in version");
3910 }
3911 }
3912 }
3913
3914 /* Append revision */
ad63d80f
JP		 3915 av_push((AV *)sv, newSViv(rev));
3916 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3917 s = ++pos;
3918 else if ( isDIGIT(*pos) )
3919 s = pos;
b0f01acb 3920 else {
ad63d80f
JP		 3921 s = pos;
3922 break;
3923 }
3924 while ( isDIGIT(*pos) ) {
13f8f398 3925 if ( saw_period == 1 && pos-s == 3 )
ad63d80f
JP		 3926 break;
3927 pos++;
b0f01acb
JP		 3928 }
3929 }
3930 }
b9381830
JP		 3931 if ( qv ) { /* quoted versions always become full version objects */
3932 I32 len = av_len((AV *)sv);
4edfc503
NC		 3933 /* This for loop appears to trigger a compiler bug on OS X, as it
3934 loops infinitely. Yes, len is negative. No, it makes no sense.
3935 Compiler in question is:
3936 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3937 for ( len = 2 - len; len > 0; len-- )
3938 av_push((AV *)sv, newSViv(0));
3939 */
3940 len = 2 - len;
3941 while (len-- > 0)
c76df65e 3942 av_push((AV *)sv, newSViv(0));
b9381830 3943 }
73d840c0 3944 return (char *)s;
b0f01acb
JP		 3945}
3946
3947/*
3948=for apidoc new_version
3949
3950Returns a new version object based on the passed in SV:
3951
3952 SV *sv = new_version(SV *ver);
3953
3954Does not alter the passed in ver SV. See "upg_version" if you
3955want to upgrade the SV.
3956
3957=cut
3958*/
3959
3960SV *
3961Perl_new_version(pTHX_ SV *ver)
3962{
129318bd 3963 SV *rv = newSV(0);
d7aa5382
JP		 3964 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3965 {
3966 I32 key;
3967 AV *av = (AV *)SvRV(ver);
3968 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3969 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
f9be5ac8 3970 AvREAL_on((AV*)sv);
d7aa5382
JP		 3971 for ( key = 0; key <= av_len(av); key++ )
3972 {
3973 I32 rev = SvIV(*av_fetch(av, key, FALSE));
3974 av_push((AV *)sv, newSViv(rev));
3975 }
3976 return rv;
3977 }
ad63d80f 3978#ifdef SvVOK
137d6fc0
JP		 3979 if ( SvVOK(ver) ) { /* already a v-string */
3980 char *version;
b0f01acb
JP		 3981 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3982 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0
JP		 3983 sv_setpv(rv,version);
3984 Safefree(version);
b0f01acb 3985 }
137d6fc0 3986 else {
ad63d80f 3987#endif
137d6fc0
JP		 3988 sv_setsv(rv,ver); /* make a duplicate */
3989#ifdef SvVOK
26ec6fc3 3990 }
137d6fc0
JP		 3991#endif
3992 upg_version(rv);
b0f01acb
JP		 3993 return rv;
3994}
3995
3996/*
3997=for apidoc upg_version
3998
3999In-place upgrade of the supplied SV to a version object.
4000
4001 SV *sv = upg_version(SV *sv);
4002
4003Returns a pointer to the upgraded SV.
4004
4005=cut
4006*/
4007
4008SV *
ad63d80f 4009Perl_upg_version(pTHX_ SV *ver)
b0f01acb 4010{
137d6fc0
JP		 4011 char *version;
4012 bool qv = 0;
4013
4014 if ( SvNOK(ver) ) /* may get too much accuracy */
4015 {
4016 char tbuf[64];
4017 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4018 version = savepv(tbuf);
4019 }
ad63d80f 4020#ifdef SvVOK
137d6fc0 4021 else if ( SvVOK(ver) ) { /* already a v-string */
ad63d80f
JP		 4022 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4023 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0 4024 qv = 1;
b0f01acb 4025 }
ad63d80f 4026#endif
137d6fc0
JP		 4027 else /* must be a string or something like a string */
4028 {
2e0de35c 4029 version = savesvpv(ver);
137d6fc0
JP		 4030 }
4031 (void)scan_version(version, ver, qv);
4032 Safefree(version);
ad63d80f 4033 return ver;
b0f01acb
JP		 4034}
4035
4036
4037/*
4038=for apidoc vnumify
4039
ad63d80f
JP		 4040Accepts a version object and returns the normalized floating
4041point representation. Call like:
b0f01acb 4042
ad63d80f 4043 sv = vnumify(rv);
b0f01acb 4044
ad63d80f
JP		 4045NOTE: you can pass either the object directly or the SV
4046contained within the RV.
b0f01acb
JP		 4047
4048=cut
4049*/
4050
4051SV *
ad63d80f 4052Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4053{
ad63d80f 4054 I32 i, len, digit;
137d6fc0 4055 SV *sv = newSV(0);
ad63d80f
JP		 4056 if ( SvROK(vs) )
4057 vs = SvRV(vs);
4058 len = av_len((AV *)vs);
46314c13
JP		 4059 if ( len == -1 )
4060 {
4061 Perl_sv_catpv(aTHX_ sv,"0");
4062 return sv;
4063 }
ad63d80f 4064 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
c0fd1b42 4065 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
13f8f398 4066 for ( i = 1 ; i < len ; i++ )
b0f01acb 4067 {
ad63d80f 4068 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
c0fd1b42 4069 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
b0f01acb 4070 }
13f8f398
JP		 4071
4072 if ( len > 0 )
4073 {
4074 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
13f8f398
JP		 4075 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4076 {
c76df65e
RGS		 4077 if ( digit < 0 ) /* alpha version */
4078 Perl_sv_catpv(aTHX_ sv,"_");
4079 /* Don't display additional trailing zeros */
13f8f398
JP		 4080 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4081 }
4082 }
4083 else /* len == 0 */
4084 {
ad63d80f 4085 Perl_sv_catpv(aTHX_ sv,"000");
13f8f398 4086 }
b0f01acb
JP		 4087 return sv;
4088}
4089
4090/*
b9381830 4091=for apidoc vnormal
b0f01acb 4092
ad63d80f
JP		 4093Accepts a version object and returns the normalized string
4094representation. Call like:
b0f01acb 4095
b9381830 4096 sv = vnormal(rv);
b0f01acb 4097
ad63d80f
JP		 4098NOTE: you can pass either the object directly or the SV
4099contained within the RV.
b0f01acb
JP		 4100
4101=cut
4102*/
4103
4104SV *
b9381830 4105Perl_vnormal(pTHX_ SV *vs)
b0f01acb 4106{
ad63d80f 4107 I32 i, len, digit;
137d6fc0 4108 SV *sv = newSV(0);
ad63d80f
JP		 4109 if ( SvROK(vs) )
4110 vs = SvRV(vs);
4111 len = av_len((AV *)vs);
46314c13
JP		 4112 if ( len == -1 )
4113 {
4114 Perl_sv_catpv(aTHX_ sv,"");
4115 return sv;
4116 }
ad63d80f 4117 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
e3feee4e 4118 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
ad63d80f 4119 for ( i = 1 ; i <= len ; i++ )
46314c13 4120 {
ad63d80f
JP		 4121 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4122 if ( digit < 0 )
e3feee4e 4123 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
ad63d80f 4124 else
e3feee4e 4125 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
b0f01acb 4126 }
137d6fc0
JP		 4127
4128 if ( len <= 2 ) { /* short version, must be at least three */
4129 for ( len = 2 - len; len != 0; len-- )
4130 Perl_sv_catpv(aTHX_ sv,".0");
4131 }
4132
b0f01acb 4133 return sv;
129318bd 4134}
b0f01acb 4135
ad63d80f 4136/*
b9381830
JP		 4137=for apidoc vstringify
4138
4139In order to maintain maximum compatibility with earlier versions
4140of Perl, this function will return either the floating point
4141notation or the multiple dotted notation, depending on whether
4142the original version contained 1 or more dots, respectively
4143
4144=cut
4145*/
4146
4147SV *
4148Perl_vstringify(pTHX_ SV *vs)
4149{
c76df65e 4150 I32 len, digit;
b9381830
JP		 4151 if ( SvROK(vs) )
4152 vs = SvRV(vs);
4153 len = av_len((AV *)vs);
c76df65e 4154 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
b9381830 4155
c76df65e 4156 if ( len < 2 || ( len == 2 && digit < 0 ) )
b9381830
JP		 4157 return vnumify(vs);
4158 else
4159 return vnormal(vs);
4160}
4161
4162/*
ad63d80f
JP		 4163=for apidoc vcmp
4164
4165Version object aware cmp. Both operands must already have been
4166converted into version objects.
4167
4168=cut
4169*/
4170
4171int
4172Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4173{
4174 I32 i,l,m,r,retval;
4175 if ( SvROK(lsv) )
4176 lsv = SvRV(lsv);
4177 if ( SvROK(rsv) )
4178 rsv = SvRV(rsv);
4179 l = av_len((AV *)lsv);
4180 r = av_len((AV *)rsv);
4181 m = l < r ? l : r;
4182 retval = 0;
4183 i = 0;
4184 while ( i <= m && retval == 0 )
4185 {
4186 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4187 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
137d6fc0
JP		 4188 bool lalpha = left < 0 ? 1 : 0;
4189 bool ralpha = right < 0 ? 1 : 0;
4190 left = abs(left);
4191 right = abs(right);
4192 if ( left < right || (left == right && lalpha && !ralpha) )
ad63d80f 4193 retval = -1;
137d6fc0 4194 if ( left > right || (left == right && ralpha && !lalpha) )
ad63d80f
JP		 4195 retval = +1;
4196 i++;
4197 }
4198
137d6fc0 4199 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
129318bd 4200 {
137d6fc0 4201 if ( l < r )
129318bd 4202 {
137d6fc0
JP		 4203 while ( i <= r && retval == 0 )
4204 {
4205 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4206 retval = -1; /* not a match after all */
4207 i++;
4208 }
4209 }
4210 else
4211 {
4212 while ( i <= l && retval == 0 )
4213 {
4214 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4215 retval = +1; /* not a match after all */
4216 i++;
4217 }
129318bd
JP		 4218 }
4219 }
ad63d80f
JP		 4220 return retval;
4221}
4222
c95c94b1 4223#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4224# define EMULATE_SOCKETPAIR_UDP
4225#endif
4226
4227#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4228static int
4229S_socketpair_udp (int fd[2]) {
e10bb1e9 4230 dTHX;
02fc2eee
NC		 4231 /* Fake a datagram socketpair using UDP to localhost. */
4232 int sockets[2] = {-1, -1};
4233 struct sockaddr_in addresses[2];
4234 int i;
3aed30dc 4235 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4236 unsigned short port;
02fc2eee
NC		 4237 int got;
4238
3aed30dc 4239 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4240 i = 1;
4241 do {
3aed30dc
HS		 4242 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4243 if (sockets[i] == -1)
4244 goto tidy_up_and_fail;
4245
4246 addresses[i].sin_family = AF_INET;
4247 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4248 addresses[i].sin_port = 0; /* kernel choses port. */
4249 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4250 sizeof(struct sockaddr_in)) == -1)
4251 goto tidy_up_and_fail;
02fc2eee
NC		 4252 } while (i--);
4253
4254 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4255 for each connect the other socket to it. */
4256 i = 1;
4257 do {
3aed30dc
HS		 4258 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4259 &size) == -1)
4260 goto tidy_up_and_fail;
4261 if (size != sizeof(struct sockaddr_in))
4262 goto abort_tidy_up_and_fail;
4263 /* !1 is 0, !0 is 1 */
4264 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4265 sizeof(struct sockaddr_in)) == -1)
4266 goto tidy_up_and_fail;
02fc2eee
NC		 4267 } while (i--);
4268
4269 /* Now we have 2 sockets connected to each other. I don't trust some other
4270 process not to have already sent a packet to us (by random) so send
4271 a packet from each to the other. */
4272 i = 1;
4273 do {
3aed30dc
HS		 4274 /* I'm going to send my own port number. As a short.
4275 (Who knows if someone somewhere has sin_port as a bitfield and needs
4276 this routine. (I'm assuming crays have socketpair)) */
4277 port = addresses[i].sin_port;
4278 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4279 if (got != sizeof(port)) {
4280 if (got == -1)
4281 goto tidy_up_and_fail;
4282 goto abort_tidy_up_and_fail;
4283 }
02fc2eee
NC		 4284 } while (i--);
4285
4286 /* Packets sent. I don't trust them to have arrived though.
4287 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4288 connect to localhost will use a second kernel thread. In 2.6 the
4289 first thread running the connect() returns before the second completes,
4290 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4291 returns 0. Poor programs have tripped up. One poor program's authors'
4292 had a 50-1 reverse stock split. Not sure how connected these were.)
4293 So I don't trust someone not to have an unpredictable UDP stack.
4294 */
4295
4296 {
3aed30dc
HS		 4297 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4298 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4299 fd_set rset;
4300
4301 FD_ZERO(&rset);
4302 FD_SET(sockets[0], &rset);
4303 FD_SET(sockets[1], &rset);
4304
4305 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4306 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4307 || !FD_ISSET(sockets[1], &rset)) {
4308 /* I hope this is portable and appropriate. */
4309 if (got == -1)
4310 goto tidy_up_and_fail;
4311 goto abort_tidy_up_and_fail;
4312 }
02fc2eee 4313 }
f4758303 4314
02fc2eee
NC		 4315 /* And the paranoia department even now doesn't trust it to have arrive
4316 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4317 {
3aed30dc
HS		 4318 struct sockaddr_in readfrom;
4319 unsigned short buffer[2];
02fc2eee 4320
3aed30dc
HS		 4321 i = 1;
4322 do {
02fc2eee 4323#ifdef MSG_DONTWAIT
3aed30dc
HS		 4324 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4325 sizeof(buffer), MSG_DONTWAIT,
4326 (struct sockaddr *) &readfrom, &size);
02fc2eee 4327#else
3aed30dc
HS		 4328 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4329 sizeof(buffer), 0,
4330 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4331#endif
02fc2eee 4332
3aed30dc
HS		 4333 if (got == -1)
4334 goto tidy_up_and_fail;
4335 if (got != sizeof(port)
4336 || size != sizeof(struct sockaddr_in)
4337 /* Check other socket sent us its port. */
4338 || buffer[0] != (unsigned short) addresses[!i].sin_port
4339 /* Check kernel says we got the datagram from that socket */
4340 || readfrom.sin_family != addresses[!i].sin_family
4341 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4342 || readfrom.sin_port != addresses[!i].sin_port)
4343 goto abort_tidy_up_and_fail;
4344 } while (i--);
02fc2eee
NC		 4345 }
4346 /* My caller (my_socketpair) has validated that this is non-NULL */
4347 fd[0] = sockets[0];
4348 fd[1] = sockets[1];
4349 /* I hereby declare this connection open. May God bless all who cross
4350 her. */
4351 return 0;
4352
4353 abort_tidy_up_and_fail:
4354 errno = ECONNABORTED;
4355 tidy_up_and_fail:
4356 {
3aed30dc
HS		 4357 int save_errno = errno;
4358 if (sockets[0] != -1)
4359 PerlLIO_close(sockets[0]);
4360 if (sockets[1] != -1)
4361 PerlLIO_close(sockets[1]);
4362 errno = save_errno;
4363 return -1;
02fc2eee
NC		 4364 }
4365}
85ca448a 4366#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4367
b5ac89c3 4368#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4369int
4370Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4371 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4372 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4373 dTHX;
02fc2eee
NC		 4374 int listener = -1;
4375 int connector = -1;
4376 int acceptor = -1;
4377 struct sockaddr_in listen_addr;
4378 struct sockaddr_in connect_addr;
4379 Sock_size_t size;
4380
50458334
JH		 4381 if (protocol
4382#ifdef AF_UNIX
4383 || family != AF_UNIX
4384#endif
3aed30dc
HS		 4385 ) {
4386 errno = EAFNOSUPPORT;
4387 return -1;
02fc2eee 4388 }
2948e0bd 4389 if (!fd) {
3aed30dc
HS		 4390 errno = EINVAL;
4391 return -1;
2948e0bd 4392 }
02fc2eee 4393
2bc69dc4 4394#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4395 if (type == SOCK_DGRAM)
3aed30dc 4396 return S_socketpair_udp(fd);
2bc69dc4 4397#endif
02fc2eee 4398
3aed30dc 4399 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4400 if (listener == -1)
3aed30dc
HS		 4401 return -1;
4402 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4403 listen_addr.sin_family = AF_INET;
3aed30dc 4404 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4405 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4406 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4407 sizeof(listen_addr)) == -1)
4408 goto tidy_up_and_fail;
e10bb1e9 4409 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4410 goto tidy_up_and_fail;
02fc2eee 4411
3aed30dc 4412 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4413 if (connector == -1)
3aed30dc 4414 goto tidy_up_and_fail;
02fc2eee 4415 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4416 size = sizeof(connect_addr);
4417 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4418 &size) == -1)
4419 goto tidy_up_and_fail;
4420 if (size != sizeof(connect_addr))
4421 goto abort_tidy_up_and_fail;
e10bb1e9 4422 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4423 sizeof(connect_addr)) == -1)
4424 goto tidy_up_and_fail;
02fc2eee 4425
3aed30dc
HS		 4426 size = sizeof(listen_addr);
4427 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4428 &size);
02fc2eee 4429 if (acceptor == -1)
3aed30dc
HS		 4430 goto tidy_up_and_fail;
4431 if (size != sizeof(listen_addr))
4432 goto abort_tidy_up_and_fail;
4433 PerlLIO_close(listener);
02fc2eee
NC		 4434 /* Now check we are talking to ourself by matching port and host on the
4435 two sockets. */
3aed30dc
HS		 4436 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4437 &size) == -1)
4438 goto tidy_up_and_fail;
4439 if (size != sizeof(connect_addr)
4440 || listen_addr.sin_family != connect_addr.sin_family
4441 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4442 || listen_addr.sin_port != connect_addr.sin_port) {
4443 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4444 }
4445 fd[0] = connector;
4446 fd[1] = acceptor;
4447 return 0;
4448
4449 abort_tidy_up_and_fail:
27da23d5
JH		 4450#ifdef ECONNABORTED
4451 errno = ECONNABORTED; /* This would be the standard thing to do. */
4452#else
4453# ifdef ECONNREFUSED
4454 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4455# else
4456 errno = ETIMEDOUT; /* Desperation time. */
4457# endif
4458#endif
02fc2eee
NC		 4459 tidy_up_and_fail:
4460 {
3aed30dc
HS		 4461 int save_errno = errno;
4462 if (listener != -1)
4463 PerlLIO_close(listener);
4464 if (connector != -1)
4465 PerlLIO_close(connector);
4466 if (acceptor != -1)
4467 PerlLIO_close(acceptor);
4468 errno = save_errno;
4469 return -1;
02fc2eee
NC		 4470 }
4471}
85ca448a 4472#else
48ea76d1
JH		 4473/* In any case have a stub so that there's code corresponding
4474 * to the my_socketpair in global.sym. */
4475int
4476Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4477#ifdef HAS_SOCKETPAIR
48ea76d1 4478 return socketpair(family, type, protocol, fd);
daf16542
JH		 4479#else
4480 return -1;
4481#endif
48ea76d1
JH		 4482}
4483#endif
4484
68795e93
NIS		 4485/*
4486
4487=for apidoc sv_nosharing
4488
4489Dummy routine which "shares" an SV when there is no sharing module present.
4490Exists to avoid test for a NULL function pointer and because it could potentially warn under
4491some level of strict-ness.
4492
4493=cut
4494*/
4495
4496void
4497Perl_sv_nosharing(pTHX_ SV *sv)
4498{
73d840c0 4499 (void)sv;
68795e93
NIS		 4500}
4501
4502/*
4503=for apidoc sv_nolocking
4504
4505Dummy routine which "locks" an SV when there is no locking module present.
4506Exists to avoid test for a NULL function pointer and because it could potentially warn under
4507some level of strict-ness.
4508
4509=cut
4510*/
4511
4512void
4513Perl_sv_nolocking(pTHX_ SV *sv)
4514{
73d840c0 4515 (void)sv;
68795e93
NIS		 4516}
4517
4518
4519/*
4520=for apidoc sv_nounlocking
4521
4522Dummy routine which "unlocks" an SV when there is no locking module present.
4523Exists to avoid test for a NULL function pointer and because it could potentially warn under
4524some level of strict-ness.
4525
4526=cut
4527*/
4528
4529void
4530Perl_sv_nounlocking(pTHX_ SV *sv)
4531{
73d840c0 4532 (void)sv;
68795e93
NIS		 4533}
4534
a05d7ebb 4535U32
e1ec3a88 4536Perl_parse_unicode_opts(pTHX_ const char **popt)
a05d7ebb 4537{
e1ec3a88 4538 const char *p = *popt;
a05d7ebb
JH		 4539 U32 opt = 0;
4540
4541 if (*p) {
4542 if (isDIGIT(*p)) {
4543 opt = (U32) atoi(p);
4544 while (isDIGIT(*p)) p++;
7c91f477 4545 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 4546 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4547 }
4548 else {
4549 for (; *p; p++) {
4550 switch (*p) {
4551 case PERL_UNICODE_STDIN:
4552 opt |= PERL_UNICODE_STDIN_FLAG; break;
4553 case PERL_UNICODE_STDOUT:
4554 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4555 case PERL_UNICODE_STDERR:
4556 opt |= PERL_UNICODE_STDERR_FLAG; break;
4557 case PERL_UNICODE_STD:
4558 opt |= PERL_UNICODE_STD_FLAG; break;
4559 case PERL_UNICODE_IN:
4560 opt |= PERL_UNICODE_IN_FLAG; break;
4561 case PERL_UNICODE_OUT:
4562 opt |= PERL_UNICODE_OUT_FLAG; break;
4563 case PERL_UNICODE_INOUT:
4564 opt |= PERL_UNICODE_INOUT_FLAG; break;
4565 case PERL_UNICODE_LOCALE:
4566 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4567 case PERL_UNICODE_ARGV:
4568 opt |= PERL_UNICODE_ARGV_FLAG; break;
4569 default:
7c91f477
JH		 4570 if (*p != '\n' && *p != '\r')
4571 Perl_croak(aTHX_
4572 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 4573 }
4574 }
4575 }
4576 }
4577 else
4578 opt = PERL_UNICODE_DEFAULT_FLAGS;
4579
4580 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 4581 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 4582 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4583
4584 *popt = p;
4585
4586 return opt;
4587}
4588
132efe8b
JH		 4589U32
4590Perl_seed(pTHX)
4591{
4592 /*
4593 * This is really just a quick hack which grabs various garbage
4594 * values. It really should be a real hash algorithm which
4595 * spreads the effect of every input bit onto every output bit,
4596 * if someone who knows about such things would bother to write it.
4597 * Might be a good idea to add that function to CORE as well.
4598 * No numbers below come from careful analysis or anything here,
4599 * except they are primes and SEED_C1 > 1E6 to get a full-width
4600 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4601 * probably be bigger too.
4602 */
4603#if RANDBITS > 16
4604# define SEED_C1 1000003
4605#define SEED_C4 73819
4606#else
4607# define SEED_C1 25747
4608#define SEED_C4 20639
4609#endif
4610#define SEED_C2 3
4611#define SEED_C3 269
4612#define SEED_C5 26107
4613
4614#ifndef PERL_NO_DEV_RANDOM
4615 int fd;
4616#endif
4617 U32 u;
4618#ifdef VMS
4619# include <starlet.h>
4620 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4621 * in 100-ns units, typically incremented ever 10 ms. */
4622 unsigned int when[2];
4623#else
4624# ifdef HAS_GETTIMEOFDAY
4625 struct timeval when;
4626# else
4627 Time_t when;
4628# endif
4629#endif
4630
4631/* This test is an escape hatch, this symbol isn't set by Configure. */
4632#ifndef PERL_NO_DEV_RANDOM
4633#ifndef PERL_RANDOM_DEVICE
4634 /* /dev/random isn't used by default because reads from it will block
4635 * if there isn't enough entropy available. You can compile with
4636 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4637 * is enough real entropy to fill the seed. */
4638# define PERL_RANDOM_DEVICE "/dev/urandom"
4639#endif
4640 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4641 if (fd != -1) {
27da23d5 4642 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
132efe8b
JH		 4643 u = 0;
4644 PerlLIO_close(fd);
4645 if (u)
4646 return u;
4647 }
4648#endif
4649
4650#ifdef VMS
4651 _ckvmssts(sys$gettim(when));
4652 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4653#else
4654# ifdef HAS_GETTIMEOFDAY
4655 PerlProc_gettimeofday(&when,NULL);
4656 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4657# else
4658 (void)time(&when);
4659 u = (U32)SEED_C1 * when;
4660# endif
4661#endif
4662 u += SEED_C3 * (U32)PerlProc_getpid();
4663 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4664#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4665 u += SEED_C5 * (U32)PTR2UV(&when);
4666#endif
4667 return u;
4668}
4669
bed60192 4670UV
a783c5f4 4671Perl_get_hash_seed(pTHX)
bed60192 4672{
e1ec3a88 4673 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
bed60192
JH		 4674 UV myseed = 0;
4675
4676 if (s)
4677 while (isSPACE(*s)) s++;
4678 if (s && isDIGIT(*s))
4679 myseed = (UV)Atoul(s);
4680 else
4681#ifdef USE_HASH_SEED_EXPLICIT
4682 if (s)
4683#endif
4684 {
4685 /* Compute a random seed */
4686 (void)seedDrand01((Rand_seed_t)seed());
bed60192
JH		 4687 myseed = (UV)(Drand01() * (NV)UV_MAX);
4688#if RANDBITS < (UVSIZE * 8)
4689 /* Since there are not enough randbits to to reach all
4690 * the bits of a UV, the low bits might need extra
4691 * help. Sum in another random number that will
4692 * fill in the low bits. */
4693 myseed +=
4694 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4695#endif /* RANDBITS < (UVSIZE * 8) */
6cfd5ea7
JH		 4696 if (myseed == 0) { /* Superparanoia. */
4697 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4698 if (myseed == 0)
4699 Perl_croak(aTHX_ "Your random numbers are not that random");
4700 }
bed60192 4701 }
008fb0c0 4702 PL_rehash_seed_set = TRUE;
bed60192
JH		 4703
4704 return myseed;
4705}
27da23d5
JH		 4706
4707#ifdef PERL_GLOBAL_STRUCT
4708
4709struct perl_vars *
4710Perl_init_global_struct(pTHX)
4711{
4712 struct perl_vars *plvarsp = NULL;
4713#ifdef PERL_GLOBAL_STRUCT
4714# define PERL_GLOBAL_STRUCT_INIT
4715# include "opcode.h" /* the ppaddr and check */
4716 IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4717 IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
4718# ifdef PERL_GLOBAL_STRUCT_PRIVATE
4719 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4720 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4721 if (!plvarsp)
4722 exit(1);
4723# else
4724 plvarsp = PL_VarsPtr;
4725# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
aadb217d
JH		 4726# undef PERLVAR
4727# undef PERLVARA
4728# undef PERLVARI
4729# undef PERLVARIC
4730# undef PERLVARISC
27da23d5
JH		 4731# define PERLVAR(var,type) /**/
4732# define PERLVARA(var,n,type) /**/
4733# define PERLVARI(var,type,init) plvarsp->var = init;
4734# define PERLVARIC(var,type,init) plvarsp->var = init;
4735# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4736# include "perlvars.h"
4737# undef PERLVAR
4738# undef PERLVARA
4739# undef PERLVARI
4740# undef PERLVARIC
4741# undef PERLVARISC
4742# ifdef PERL_GLOBAL_STRUCT
4743 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4744 if (!plvarsp->Gppaddr)
4745 exit(1);
4746 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
4747 if (!plvarsp->Gcheck)
4748 exit(1);
4749 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4750 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
4751# endif
4752# ifdef PERL_SET_VARS
4753 PERL_SET_VARS(plvarsp);
4754# endif
4755# undef PERL_GLOBAL_STRUCT_INIT
4756#endif
4757 return plvarsp;
4758}
4759
4760#endif /* PERL_GLOBAL_STRUCT */
4761
4762#ifdef PERL_GLOBAL_STRUCT
4763
4764void
4765Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4766{
4767#ifdef PERL_GLOBAL_STRUCT
4768# ifdef PERL_UNSET_VARS
4769 PERL_UNSET_VARS(plvarsp);
4770# endif
4771 free(plvarsp->Gppaddr);
4772 free(plvarsp->Gcheck);
4773# ifdef PERL_GLOBAL_STRUCT_PRIVATE
4774 free(plvarsp);
4775# endif
4776#endif
4777}
4778
4779#endif /* PERL_GLOBAL_STRUCT */
4780
Unnamed repository; edit this file 'description' to name the repository.