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