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