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
Re: [ID 20010212.006] Core dump with /((?:hard|soft)cover)?/
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
a687059c 4 *
d48672a2
LW		 5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
8d063cd8 7 *
8d063cd8 8 */
a0d0e21e
LW		 9
10/*
11 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
12 * not content." --Gandalf
13 */
8d063cd8 14
8d063cd8 15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_UTIL_C
8d063cd8 17#include "perl.h"
62b28dd9 18
64ca3a65 19#ifndef PERL_MICRO
e1dfb34b 20#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
a687059c 21#include <signal.h>
62b28dd9 22#endif
a687059c 23
36477c24 24#ifndef SIG_ERR
25# define SIG_ERR ((Sighandler_t) -1)
26#endif
64ca3a65 27#endif
36477c24 28
a687059c
LW		 29#ifdef I_VFORK
30# include <vfork.h>
31#endif
32
94b6baf5
AD		 33/* Put this after #includes because fork and vfork prototypes may
34 conflict.
35*/
36#ifndef HAS_VFORK
37# define vfork fork
38#endif
39
ff68c719 40#ifdef I_SYS_WAIT
41# include <sys/wait.h>
42#endif
43
097ee67d
JH		 44#ifdef I_LOCALE
45# include <locale.h>
46#endif
47
8d063cd8 48#define FLUSH
8d063cd8 49
a0d0e21e 50#ifdef LEAKTEST
a0d0e21e 51
8c52afec
IZ		 52long xcount[MAXXCOUNT];
53long lastxcount[MAXXCOUNT];
54long xycount[MAXXCOUNT][MAXYCOUNT];
55long lastxycount[MAXXCOUNT][MAXYCOUNT];
56
a0d0e21e 57#endif
a863c7d1 58
16cebae2
GS		 59#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
60# define FD_CLOEXEC 1 /* NeXT needs this */
61#endif
62
f2517201 63/* paranoid version of system's malloc() */
8d063cd8 64
a687059c
LW		 65/* NOTE: Do not call the next three routines directly. Use the macros
66 * in handy.h, so that we can easily redefine everything to do tracking of
67 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 68 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW		 69 */
70
bd4080b3 71Malloc_t
4f63d024 72Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 73{
54aff467 74 dTHX;
bd4080b3 75 Malloc_t ptr;
55497cff 76#ifdef HAS_64K_LIMIT
62b28dd9 77 if (size > 0xffff) {
bf49b057 78 PerlIO_printf(Perl_error_log,
16cebae2 79 "Allocation too large: %lx\n", size) FLUSH;
54aff467 80 my_exit(1);
62b28dd9 81 }
55497cff 82#endif /* HAS_64K_LIMIT */
34de22dd
LW		 83#ifdef DEBUGGING
84 if ((long)size < 0)
4f63d024 85 Perl_croak_nocontext("panic: malloc");
34de22dd 86#endif
12ae5dfc 87 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 88 PERL_ALLOC_CHECK(ptr);
97835f67 89 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
8d063cd8
LW		 90 if (ptr != Nullch)
91 return ptr;
3280af22 92 else if (PL_nomemok)
7c0587c8 93 return Nullch;
8d063cd8 94 else {
bf49b057 95 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
54aff467 96 my_exit(1);
4e35701f 97 return Nullch;
8d063cd8
LW		 98 }
99 /*NOTREACHED*/
100}
101
f2517201 102/* paranoid version of system's realloc() */
8d063cd8 103
bd4080b3 104Malloc_t
4f63d024 105Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 106{
54aff467 107 dTHX;
bd4080b3 108 Malloc_t ptr;
9a34ef1d 109#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
6ad3d225 110 Malloc_t PerlMem_realloc();
ecfc5424 111#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 112
a1d180c4 113#ifdef HAS_64K_LIMIT
5f05dabc 114 if (size > 0xffff) {
bf49b057 115 PerlIO_printf(Perl_error_log,
5f05dabc 116 "Reallocation too large: %lx\n", size) FLUSH;
54aff467 117 my_exit(1);
5f05dabc 118 }
55497cff 119#endif /* HAS_64K_LIMIT */
7614df0c 120 if (!size) {
f2517201 121 safesysfree(where);
7614df0c
JD		 122 return NULL;
123 }
124
378cc40b 125 if (!where)
f2517201 126 return safesysmalloc(size);
34de22dd
LW		 127#ifdef DEBUGGING
128 if ((long)size < 0)
4f63d024 129 Perl_croak_nocontext("panic: realloc");
34de22dd 130#endif
12ae5dfc 131 ptr = (Malloc_t)PerlMem_realloc(where,size);
da927450 132 PERL_ALLOC_CHECK(ptr);
a1d180c4 133
97835f67
JH		 134 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
135 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
79072805 136
8d063cd8
LW		 137 if (ptr != Nullch)
138 return ptr;
3280af22 139 else if (PL_nomemok)
7c0587c8 140 return Nullch;
8d063cd8 141 else {
bf49b057 142 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
54aff467 143 my_exit(1);
4e35701f 144 return Nullch;
8d063cd8
LW		 145 }
146 /*NOTREACHED*/
147}
148
f2517201 149/* safe version of system's free() */
8d063cd8 150
54310121 151Free_t
4f63d024 152Perl_safesysfree(Malloc_t where)
8d063cd8 153{
155aba94 154#ifdef PERL_IMPLICIT_SYS
54aff467 155 dTHX;
155aba94 156#endif
97835f67 157 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 158 if (where) {
de3bb511 159 /*SUPPRESS 701*/
6ad3d225 160 PerlMem_free(where);
378cc40b 161 }
8d063cd8
LW		 162}
163
f2517201 164/* safe version of system's calloc() */
1050c9ca 165
bd4080b3 166Malloc_t
4f63d024 167Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 168{
54aff467 169 dTHX;
bd4080b3 170 Malloc_t ptr;
1050c9ca 171
55497cff 172#ifdef HAS_64K_LIMIT
5f05dabc 173 if (size * count > 0xffff) {
bf49b057 174 PerlIO_printf(Perl_error_log,
5f05dabc 175 "Allocation too large: %lx\n", size * count) FLUSH;
54aff467 176 my_exit(1);
5f05dabc 177 }
55497cff 178#endif /* HAS_64K_LIMIT */
1050c9ca 179#ifdef DEBUGGING
180 if ((long)size < 0 || (long)count < 0)
4f63d024 181 Perl_croak_nocontext("panic: calloc");
1050c9ca 182#endif
0b7c1c42 183 size *= count;
12ae5dfc 184 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 185 PERL_ALLOC_CHECK(ptr);
97835f67 186 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 187 if (ptr != Nullch) {
188 memset((void*)ptr, 0, size);
189 return ptr;
190 }
3280af22 191 else if (PL_nomemok)
1050c9ca 192 return Nullch;
193 else {
bf49b057 194 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
54aff467 195 my_exit(1);
4e35701f 196 return Nullch;
1050c9ca 197 }
198 /*NOTREACHED*/
199}
200
a687059c
LW		 201#ifdef LEAKTEST
202
8c52afec
IZ		 203struct mem_test_strut {
204 union {
205 long type;
206 char c[2];
207 } u;
208 long size;
209};
210
211# define ALIGN sizeof(struct mem_test_strut)
212
213# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
214# define typeof_chunk(ch) \
215 (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
216# define set_typeof_chunk(ch,t) \
217 (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
218#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
219 ? MAXYCOUNT - 1 \
220 : ( (size) > 40 \
221 ? ((size) - 1)/8 + 5 \
222 : ((size) - 1)/4))
8d063cd8 223
bd4080b3 224Malloc_t
4f63d024 225Perl_safexmalloc(I32 x, MEM_SIZE size)
8d063cd8 226{
8c52afec 227 register char* where = (char*)safemalloc(size + ALIGN);
8d063cd8 228
8c52afec
IZ		 229 xcount[x] += size;
230 xycount[x][SIZE_TO_Y(size)]++;
231 set_typeof_chunk(where, x);
232 sizeof_chunk(where) = size;
233 return (Malloc_t)(where + ALIGN);
8d063cd8 234}
8d063cd8 235
bd4080b3 236Malloc_t
4f63d024 237Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
a687059c 238{
8c52afec
IZ		 239 char *where = (char*)wh;
240
241 if (!wh)
242 return safexmalloc(0,size);
a1d180c4 243
8c52afec
IZ		 244 {
245 MEM_SIZE old = sizeof_chunk(where - ALIGN);
246 int t = typeof_chunk(where - ALIGN);
247 register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
a1d180c4 248
8c52afec
IZ		 249 xycount[t][SIZE_TO_Y(old)]--;
250 xycount[t][SIZE_TO_Y(size)]++;
251 xcount[t] += size - old;
252 sizeof_chunk(new) = size;
253 return (Malloc_t)(new + ALIGN);
254 }
a687059c
LW		 255}
256
257void
4f63d024 258Perl_safexfree(Malloc_t wh)
a687059c 259{
79072805 260 I32 x;
8c52afec
IZ		 261 char *where = (char*)wh;
262 MEM_SIZE size;
a1d180c4 263
a687059c
LW		 264 if (!where)
265 return;
266 where -= ALIGN;
8c52afec 267 size = sizeof_chunk(where);
a687059c 268 x = where[0] + 100 * where[1];
8c52afec
IZ		 269 xcount[x] -= size;
270 xycount[x][SIZE_TO_Y(size)]--;
a687059c
LW		 271 safefree(where);
272}
273
bd4080b3 274Malloc_t
4f63d024 275Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
1050c9ca 276{
8c52afec
IZ		 277 register char * where = (char*)safexmalloc(x, size * count + ALIGN);
278 xcount[x] += size;
279 xycount[x][SIZE_TO_Y(size)]++;
280 memset((void*)(where + ALIGN), 0, size * count);
281 set_typeof_chunk(where, x);
282 sizeof_chunk(where) = size;
283 return (Malloc_t)(where + ALIGN);
1050c9ca 284}
285
864dbfa3 286STATIC void
cea2e8a9 287S_xstat(pTHX_ int flag)
8d063cd8 288{
8c52afec
IZ		 289 register I32 i, j, total = 0;
290 I32 subtot[MAXYCOUNT];
8d063cd8 291
8c52afec
IZ		 292 for (j = 0; j < MAXYCOUNT; j++) {
293 subtot[j] = 0;
294 }
a1d180c4 295
bf49b057 296 PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
a687059c 297 for (i = 0; i < MAXXCOUNT; i++) {
8c52afec
IZ		 298 total += xcount[i];
299 for (j = 0; j < MAXYCOUNT; j++) {
300 subtot[j] += xycount[i][j];
301 }
302 if (flag == 0
303 ? xcount[i] /* Have something */
a1d180c4 304 : (flag == 2
8c52afec
IZ		 305 ? xcount[i] != lastxcount[i] /* Changed */
306 : xcount[i] > lastxcount[i])) { /* Growed */
a1d180c4 307 PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
8c52afec 308 flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
a687059c 309 lastxcount[i] = xcount[i];
8c52afec 310 for (j = 0; j < MAXYCOUNT; j++) {
a1d180c4 311 if ( flag == 0
8c52afec 312 ? xycount[i][j] /* Have something */
a1d180c4 313 : (flag == 2
8c52afec
IZ		 314 ? xycount[i][j] != lastxycount[i][j] /* Changed */
315 : xycount[i][j] > lastxycount[i][j])) { /* Growed */
a1d180c4
NIS		 316 PerlIO_printf(Perl_debug_log,"%3ld ",
317 flag == 2
318 ? xycount[i][j] - lastxycount[i][j]
8c52afec
IZ		 319 : xycount[i][j]);
320 lastxycount[i][j] = xycount[i][j];
321 } else {
bf49b057 322 PerlIO_printf(Perl_debug_log, " . ", xycount[i][j]);
8c52afec
IZ		 323 }
324 }
bf49b057 325 PerlIO_printf(Perl_debug_log, "\n");
8c52afec
IZ		 326 }
327 }
328 if (flag != 2) {
bf49b057 329 PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
8c52afec
IZ		 330 for (j = 0; j < MAXYCOUNT; j++) {
331 if (subtot[j]) {
bf49b057 332 PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
8c52afec 333 } else {
bf49b057 334 PerlIO_printf(Perl_debug_log, " . ");
8c52afec 335 }
8d063cd8 336 }
bf49b057 337 PerlIO_printf(Perl_debug_log, "\n");
8d063cd8 338 }
8d063cd8 339}
a687059c
LW		 340
341#endif /* LEAKTEST */
8d063cd8
LW		 342
343/* copy a string up to some (non-backslashed) delimiter, if any */
344
345char *
864dbfa3 346Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
8d063cd8 347{
fc36a67e 348 register I32 tolen;
349 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b
LW		 350 if (*from == '\\') {
351 if (from[1] == delim)
352 from++;
fc36a67e 353 else {
354 if (to < toend)
355 *to++ = *from;
356 tolen++;
357 from++;
358 }
378cc40b 359 }
bedebaa5 360 else if (*from == delim)
8d063cd8 361 break;
fc36a67e 362 if (to < toend)
363 *to++ = *from;
8d063cd8 364 }
bedebaa5
CS		 365 if (to < toend)
366 *to = '\0';
fc36a67e 367 *retlen = tolen;
8d063cd8
LW		 368 return from;
369}
370
371/* return ptr to little string in big string, NULL if not found */
378cc40b 372/* This routine was donated by Corey Satten. */
8d063cd8
LW		 373
374char *
864dbfa3 375Perl_instr(pTHX_ register const char *big, register const char *little)
378cc40b 376{
08105a92 377 register const char *s, *x;
79072805 378 register I32 first;
378cc40b 379
a687059c 380 if (!little)
08105a92 381 return (char*)big;
a687059c 382 first = *little++;
378cc40b 383 if (!first)
08105a92 384 return (char*)big;
378cc40b
LW		 385 while (*big) {
386 if (*big++ != first)
387 continue;
388 for (x=big,s=little; *s; /**/ ) {
389 if (!*x)
390 return Nullch;
391 if (*s++ != *x++) {
392 s--;
393 break;
394 }
395 }
396 if (!*s)
08105a92 397 return (char*)(big-1);
378cc40b
LW		 398 }
399 return Nullch;
400}
8d063cd8 401
a687059c
LW		 402/* same as instr but allow embedded nulls */
403
404char *
864dbfa3 405Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
8d063cd8 406{
08105a92 407 register const char *s, *x;
79072805 408 register I32 first = *little;
08105a92 409 register const char *littleend = lend;
378cc40b 410
a0d0e21e 411 if (!first && little >= littleend)
08105a92 412 return (char*)big;
de3bb511
LW		 413 if (bigend - big < littleend - little)
414 return Nullch;
a687059c
LW		 415 bigend -= littleend - little++;
416 while (big <= bigend) {
417 if (*big++ != first)
418 continue;
419 for (x=big,s=little; s < littleend; /**/ ) {
420 if (*s++ != *x++) {
421 s--;
422 break;
423 }
424 }
425 if (s >= littleend)
08105a92 426 return (char*)(big-1);
378cc40b 427 }
a687059c
LW		 428 return Nullch;
429}
430
431/* reverse of the above--find last substring */
432
433char *
864dbfa3 434Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
a687059c 435{
08105a92
GS		 436 register const char *bigbeg;
437 register const char *s, *x;
79072805 438 register I32 first = *little;
08105a92 439 register const char *littleend = lend;
a687059c 440
a0d0e21e 441 if (!first && little >= littleend)
08105a92 442 return (char*)bigend;
a687059c
LW		 443 bigbeg = big;
444 big = bigend - (littleend - little++);
445 while (big >= bigbeg) {
446 if (*big-- != first)
447 continue;
448 for (x=big+2,s=little; s < littleend; /**/ ) {
449 if (*s++ != *x++) {
450 s--;
451 break;
452 }
453 }
454 if (s >= littleend)
08105a92 455 return (char*)(big+1);
378cc40b 456 }
a687059c 457 return Nullch;
378cc40b 458}
a687059c 459
bbce6d69 460/*
461 * Set up for a new ctype locale.
462 */
55497cff 463void
ff4fed7c 464Perl_new_ctype(pTHX_ char *newctype)
ef7eada9 465{
36477c24 466#ifdef USE_LOCALE_CTYPE
467
bbce6d69 468 int i;
ef7eada9 469
bbce6d69 470 for (i = 0; i < 256; i++) {
471 if (isUPPER_LC(i))
22c35a8c 472 PL_fold_locale[i] = toLOWER_LC(i);
bbce6d69 473 else if (isLOWER_LC(i))
22c35a8c 474 PL_fold_locale[i] = toUPPER_LC(i);
bbce6d69 475 else
22c35a8c 476 PL_fold_locale[i] = i;
bbce6d69 477 }
bbce6d69 478
36477c24 479#endif /* USE_LOCALE_CTYPE */
480}
bbce6d69 481
482/*
ff4fed7c
VK		 483 * Standardize the locale name from a string returned by 'setlocale'.
484 *
485 * The standard return value of setlocale() is either
486 * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
487 * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
488 * (the space-separated values represent the various sublocales,
489 * in some unspecificed order)
490 *
491 * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
492 * which is harmful for further use of the string in setlocale().
493 *
494 */
495STATIC char *
496S_stdize_locale(pTHX_ char *locs)
497{
498 char *s;
499 bool okay = TRUE;
500
501 if ((s = strchr(locs, '='))) {
502 char *t;
503
504 okay = FALSE;
505 if ((t = strchr(s, '.'))) {
506 char *u;
507
508 if ((u = strchr(t, '\n'))) {
509
510 if (u[1] == 0) {
511 STRLEN len = u - s;
a528dad0 512 Move(s + 1, locs, len, char);
ff4fed7c
VK		 513 locs[len] = 0;
514 okay = TRUE;
515 }
516 }
517 }
518 }
519
520 if (!okay)
521 Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
522
523 return locs;
524}
525
526/*
bbce6d69 527 * Set up for a new collation locale.
528 */
529void
ff4fed7c 530Perl_new_collate(pTHX_ char *newcoll)
bbce6d69 531{
36477c24 532#ifdef USE_LOCALE_COLLATE
533
bbce6d69 534 if (! newcoll) {
3280af22 535 if (PL_collation_name) {
9b3a60d0 536 ++PL_collation_ix;
3280af22
NIS		 537 Safefree(PL_collation_name);
538 PL_collation_name = NULL;
bbce6d69 539 }
ff4fed7c
VK		 540 PL_collation_standard = TRUE;
541 PL_collxfrm_base = 0;
542 PL_collxfrm_mult = 2;
bbce6d69 543 return;
544 }
545
3280af22 546 if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
9b3a60d0
JH		 547 ++PL_collation_ix;
548 Safefree(PL_collation_name);
549 PL_collation_name = stdize_locale(savepv(newcoll));
3280af22 550 PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
bbce6d69 551
bbce6d69 552 {
553 /* 2: at most so many chars ('a', 'b'). */
554 /* 50: surely no system expands a char more. */
555#define XFRMBUFSIZE (2 * 50)
556 char xbuf[XFRMBUFSIZE];
557 Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
558 Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
559 SSize_t mult = fb - fa;
560 if (mult < 1)
cea2e8a9 561 Perl_croak(aTHX_ "strxfrm() gets absurd");
3280af22
NIS		 562 PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
563 PL_collxfrm_mult = mult;
bbce6d69 564 }
bbce6d69 565 }
bbce6d69 566
36477c24 567#endif /* USE_LOCALE_COLLATE */
568}
bbce6d69 569
097ee67d 570void
51371543 571Perl_set_numeric_radix(pTHX)
097ee67d
JH		 572{
573#ifdef USE_LOCALE_NUMERIC
574# ifdef HAS_LOCALECONV
575 struct lconv* lc;
576
577 lc = localeconv();
eff180cd
JH		 578 if (lc && lc->decimal_point) {
579 if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
580 SvREFCNT_dec(PL_numeric_radix);
581 PL_numeric_radix = 0;
582 }
583 else {
584 if (PL_numeric_radix)
585 sv_setpv(PL_numeric_radix, lc->decimal_point);
586 else
587 PL_numeric_radix = newSVpv(lc->decimal_point, 0);
588 }
589 }
097ee67d
JH		 590 else
591 PL_numeric_radix = 0;
592# endif /* HAS_LOCALECONV */
097ee67d
JH		 593#endif /* USE_LOCALE_NUMERIC */
594}
595
bbce6d69 596/*
597 * Set up for a new numeric locale.
598 */
599void
ff4fed7c 600Perl_new_numeric(pTHX_ char *newnum)
bbce6d69 601{
36477c24 602#ifdef USE_LOCALE_NUMERIC
603
bbce6d69 604 if (! newnum) {
3280af22
NIS		 605 if (PL_numeric_name) {
606 Safefree(PL_numeric_name);
607 PL_numeric_name = NULL;
bbce6d69 608 }
ff4fed7c
VK		 609 PL_numeric_standard = TRUE;
610 PL_numeric_local = TRUE;
bbce6d69 611 return;
612 }
613
3280af22 614 if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
9b3a60d0
JH		 615 Safefree(PL_numeric_name);
616 PL_numeric_name = stdize_locale(savepv(newnum));
3280af22
NIS		 617 PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
618 PL_numeric_local = TRUE;
51371543 619 set_numeric_radix();
bbce6d69 620 }
36477c24 621
622#endif /* USE_LOCALE_NUMERIC */
bbce6d69 623}
624
625void
864dbfa3 626Perl_set_numeric_standard(pTHX)
bbce6d69 627{
5f05dabc 628#ifdef USE_LOCALE_NUMERIC
629
3280af22 630 if (! PL_numeric_standard) {
bbce6d69 631 setlocale(LC_NUMERIC, "C");
3280af22
NIS		 632 PL_numeric_standard = TRUE;
633 PL_numeric_local = FALSE;
ff4fed7c 634 set_numeric_radix();
bbce6d69 635 }
5f05dabc 636
637#endif /* USE_LOCALE_NUMERIC */
bbce6d69 638}
639
640void
864dbfa3 641Perl_set_numeric_local(pTHX)
bbce6d69 642{
5f05dabc 643#ifdef USE_LOCALE_NUMERIC
644
3280af22
NIS		 645 if (! PL_numeric_local) {
646 setlocale(LC_NUMERIC, PL_numeric_name);
647 PL_numeric_standard = FALSE;
648 PL_numeric_local = TRUE;
51371543 649 set_numeric_radix();
bbce6d69 650 }
bbce6d69 651
36477c24 652#endif /* USE_LOCALE_NUMERIC */
5f05dabc 653}
36477c24 654
36477c24 655/*
656 * Initialize locale awareness.
657 */
f0c5b223 658int
864dbfa3 659Perl_init_i18nl10n(pTHX_ int printwarn)
f0c5b223
TB		 660{
661 int ok = 1;
662 /* returns
663 * 1 = set ok or not applicable,
664 * 0 = fallback to C locale,
665 * -1 = fallback to C locale failed
666 */
bbce6d69 667
36477c24 668#ifdef USE_LOCALE
bbce6d69 669
36477c24 670#ifdef USE_LOCALE_CTYPE
bbce6d69 671 char *curctype = NULL;
36477c24 672#endif /* USE_LOCALE_CTYPE */
673#ifdef USE_LOCALE_COLLATE
bbce6d69 674 char *curcoll = NULL;
36477c24 675#endif /* USE_LOCALE_COLLATE */
676#ifdef USE_LOCALE_NUMERIC
bbce6d69 677 char *curnum = NULL;
36477c24 678#endif /* USE_LOCALE_NUMERIC */
3aeabbed
JH		 679#ifdef __GLIBC__
680 char *language = PerlEnv_getenv("LANGUAGE");
681#endif
76e3520e
GS		 682 char *lc_all = PerlEnv_getenv("LC_ALL");
683 char *lang = PerlEnv_getenv("LANG");
bbce6d69 684 bool setlocale_failure = FALSE;
f0c5b223 685
02b32252
CS		 686#ifdef LOCALE_ENVIRON_REQUIRED
687
688 /*
689 * Ultrix setlocale(..., "") fails if there are no environment
690 * variables from which to get a locale name.
691 */
692
693 bool done = FALSE;
694
695#ifdef LC_ALL
696 if (lang) {
697 if (setlocale(LC_ALL, ""))
698 done = TRUE;
699 else
700 setlocale_failure = TRUE;
701 }
0644c9cb 702 if (!setlocale_failure) {
02b32252 703#ifdef USE_LOCALE_CTYPE
0644c9cb
IS		 704 if (! (curctype =
705 setlocale(LC_CTYPE,
706 (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
02b32252
CS		 707 ? "" : Nullch)))
708 setlocale_failure = TRUE;
f4182098
AB		 709 else
710 curctype = savepv(curctype);
02b32252
CS		 711#endif /* USE_LOCALE_CTYPE */
712#ifdef USE_LOCALE_COLLATE
0644c9cb
IS		 713 if (! (curcoll =
714 setlocale(LC_COLLATE,
715 (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
02b32252
CS		 716 ? "" : Nullch)))
717 setlocale_failure = TRUE;
f4182098
AB		 718 else
719 curcoll = savepv(curcoll);
02b32252
CS		 720#endif /* USE_LOCALE_COLLATE */
721#ifdef USE_LOCALE_NUMERIC
0644c9cb
IS		 722 if (! (curnum =
723 setlocale(LC_NUMERIC,
724 (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
02b32252
CS		 725 ? "" : Nullch)))
726 setlocale_failure = TRUE;
f4182098
AB		 727 else
728 curnum = savepv(curnum);
02b32252
CS		 729#endif /* USE_LOCALE_NUMERIC */
730 }
731
0644c9cb 732#endif /* LC_ALL */
02b32252 733
0644c9cb 734#endif /* !LOCALE_ENVIRON_REQUIRED */
5f05dabc 735
0644c9cb 736#ifdef LC_ALL
bbce6d69 737 if (! setlocale(LC_ALL, ""))
738 setlocale_failure = TRUE;
0644c9cb 739#endif /* LC_ALL */
bbce6d69 740
0644c9cb 741 if (!setlocale_failure) {
36477c24 742#ifdef USE_LOCALE_CTYPE
0644c9cb
IS		 743 if (! (curctype = setlocale(LC_CTYPE, "")))
744 setlocale_failure = TRUE;
f4182098
AB		 745 else
746 curctype = savepv(curctype);
36477c24 747#endif /* USE_LOCALE_CTYPE */
748#ifdef USE_LOCALE_COLLATE
0644c9cb
IS		 749 if (! (curcoll = setlocale(LC_COLLATE, "")))
750 setlocale_failure = TRUE;
f4182098
AB		 751 else
752 curcoll = savepv(curcoll);
36477c24 753#endif /* USE_LOCALE_COLLATE */
754#ifdef USE_LOCALE_NUMERIC
0644c9cb
IS		 755 if (! (curnum = setlocale(LC_NUMERIC, "")))
756 setlocale_failure = TRUE;
f4182098
AB		 757 else
758 curnum = savepv(curnum);
36477c24 759#endif /* USE_LOCALE_NUMERIC */
0644c9cb 760 }
02b32252 761
5f05dabc 762 if (setlocale_failure) {
763 char *p;
a1d180c4 764 bool locwarn = (printwarn > 1 ||
155aba94
GS		 765 (printwarn &&
766 (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
20cec16a 767
5f05dabc 768 if (locwarn) {
769#ifdef LC_ALL
a1d180c4 770
bf49b057 771 PerlIO_printf(Perl_error_log,
5f05dabc 772 "perl: warning: Setting locale failed.\n");
773
774#else /* !LC_ALL */
a1d180c4 775
bf49b057 776 PerlIO_printf(Perl_error_log,
bbce6d69 777 "perl: warning: Setting locale failed for the categories:\n\t");
36477c24 778#ifdef USE_LOCALE_CTYPE
bbce6d69 779 if (! curctype)
bf49b057 780 PerlIO_printf(Perl_error_log, "LC_CTYPE ");
36477c24 781#endif /* USE_LOCALE_CTYPE */
782#ifdef USE_LOCALE_COLLATE
bbce6d69 783 if (! curcoll)
bf49b057 784 PerlIO_printf(Perl_error_log, "LC_COLLATE ");
36477c24 785#endif /* USE_LOCALE_COLLATE */
786#ifdef USE_LOCALE_NUMERIC
bbce6d69 787 if (! curnum)
bf49b057 788 PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
36477c24 789#endif /* USE_LOCALE_NUMERIC */
bf49b057 790 PerlIO_printf(Perl_error_log, "\n");
bbce6d69 791
5f05dabc 792#endif /* LC_ALL */
793
bf49b057 794 PerlIO_printf(Perl_error_log,
bbce6d69 795 "perl: warning: Please check that your locale settings:\n");
ef7eada9 796
3aeabbed 797#ifdef __GLIBC__
bf49b057 798 PerlIO_printf(Perl_error_log,
3aeabbed
JH		 799 "\tLANGUAGE = %c%s%c,\n",
800 language ? '"' : '(',
801 language ? language : "unset",
802 language ? '"' : ')');
803#endif
804
bf49b057 805 PerlIO_printf(Perl_error_log,
bbce6d69 806 "\tLC_ALL = %c%s%c,\n",
807 lc_all ? '"' : '(',
808 lc_all ? lc_all : "unset",
809 lc_all ? '"' : ')');
5f05dabc 810
811 {
812 char **e;
813 for (e = environ; *e; e++) {
814 if (strnEQ(*e, "LC_", 3)
815 && strnNE(*e, "LC_ALL=", 7)
816 && (p = strchr(*e, '=')))
bf49b057 817 PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
fb73857a 818 (int)(p - *e), *e, p + 1);
5f05dabc 819 }
820 }
821
bf49b057 822 PerlIO_printf(Perl_error_log,
bbce6d69 823 "\tLANG = %c%s%c\n",
5f05dabc 824 lang ? '"' : '(',
bbce6d69 825 lang ? lang : "unset",
826 lang ? '"' : ')');
ef7eada9 827
bf49b057 828 PerlIO_printf(Perl_error_log,
bbce6d69 829 " are supported and installed on your system.\n");
5f05dabc 830 }
ef7eada9 831
5f05dabc 832#ifdef LC_ALL
833
834 if (setlocale(LC_ALL, "C")) {
835 if (locwarn)
bf49b057 836 PerlIO_printf(Perl_error_log,
5f05dabc 837 "perl: warning: Falling back to the standard locale (\"C\").\n");
bbce6d69 838 ok = 0;
ef7eada9 839 }
5f05dabc 840 else {
841 if (locwarn)
bf49b057 842 PerlIO_printf(Perl_error_log,
5f05dabc 843 "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
844 ok = -1;
845 }
bbce6d69 846
5f05dabc 847#else /* ! LC_ALL */
848
849 if (0
36477c24 850#ifdef USE_LOCALE_CTYPE
5f05dabc 851 || !(curctype || setlocale(LC_CTYPE, "C"))
36477c24 852#endif /* USE_LOCALE_CTYPE */
853#ifdef USE_LOCALE_COLLATE
5f05dabc 854 || !(curcoll || setlocale(LC_COLLATE, "C"))
36477c24 855#endif /* USE_LOCALE_COLLATE */
856#ifdef USE_LOCALE_NUMERIC
5f05dabc 857 || !(curnum || setlocale(LC_NUMERIC, "C"))
36477c24 858#endif /* USE_LOCALE_NUMERIC */
5f05dabc 859 )
860 {
861 if (locwarn)
bf49b057 862 PerlIO_printf(Perl_error_log,
5f05dabc 863 "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
864 ok = -1;
bbce6d69 865 }
5f05dabc 866
bbce6d69 867#endif /* ! LC_ALL */
5f05dabc 868
869#ifdef USE_LOCALE_CTYPE
f4182098 870 curctype = savepv(setlocale(LC_CTYPE, Nullch));
5f05dabc 871#endif /* USE_LOCALE_CTYPE */
872#ifdef USE_LOCALE_COLLATE
f4182098 873 curcoll = savepv(setlocale(LC_COLLATE, Nullch));
5f05dabc 874#endif /* USE_LOCALE_COLLATE */
875#ifdef USE_LOCALE_NUMERIC
f4182098 876 curnum = savepv(setlocale(LC_NUMERIC, Nullch));
5f05dabc 877#endif /* USE_LOCALE_NUMERIC */
ef7eada9 878 }
f4182098 879 else {
ef7eada9 880
36477c24 881#ifdef USE_LOCALE_CTYPE
864dbfa3 882 new_ctype(curctype);
36477c24 883#endif /* USE_LOCALE_CTYPE */
bbce6d69 884
36477c24 885#ifdef USE_LOCALE_COLLATE
864dbfa3 886 new_collate(curcoll);
36477c24 887#endif /* USE_LOCALE_COLLATE */
bbce6d69 888
36477c24 889#ifdef USE_LOCALE_NUMERIC
864dbfa3 890 new_numeric(curnum);
36477c24 891#endif /* USE_LOCALE_NUMERIC */
f4182098 892 }
ef7eada9 893
36477c24 894#endif /* USE_LOCALE */
ef7eada9 895
f4182098
AB		 896#ifdef USE_LOCALE_CTYPE
897 if (curctype != NULL)
898 Safefree(curctype);
899#endif /* USE_LOCALE_CTYPE */
900#ifdef USE_LOCALE_COLLATE
901 if (curcoll != NULL)
902 Safefree(curcoll);
903#endif /* USE_LOCALE_COLLATE */
904#ifdef USE_LOCALE_NUMERIC
905 if (curnum != NULL)
906 Safefree(curnum);
907#endif /* USE_LOCALE_NUMERIC */
f0c5b223
TB		 908 return ok;
909}
910
bbce6d69 911/* Backwards compatibility. */
912int
864dbfa3 913Perl_init_i18nl14n(pTHX_ int printwarn)
bbce6d69 914{
864dbfa3 915 return init_i18nl10n(printwarn);
bbce6d69 916}
ef7eada9 917
36477c24 918#ifdef USE_LOCALE_COLLATE
ef7eada9 919
bbce6d69 920/*
921 * mem_collxfrm() is a bit like strxfrm() but with two important
922 * differences. First, it handles embedded NULs. Second, it allocates
923 * a bit more memory than needed for the transformed data itself.
924 * The real transformed data begins at offset sizeof(collationix).
925 * Please see sv_collxfrm() to see how this is used.
926 */
927char *
864dbfa3 928Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
bbce6d69 929{
930 char *xbuf;
76e3520e 931 STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
bbce6d69 932
933 /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
934 /* the +1 is for the terminating NUL. */
935
3280af22 936 xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
76e3520e 937 New(171, xbuf, xAlloc, char);
bbce6d69 938 if (! xbuf)
939 goto bad;
940
3280af22
NIS		 941 *(U32*)xbuf = PL_collation_ix;
942 xout = sizeof(PL_collation_ix);
bbce6d69 943 for (xin = 0; xin < len; ) {
944 SSize_t xused;
945
946 for (;;) {
76e3520e 947 xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
bbce6d69 948 if (xused == -1)
949 goto bad;
76e3520e 950 if (xused < xAlloc - xout)
bbce6d69 951 break;
76e3520e
GS		 952 xAlloc = (2 * xAlloc) + 1;
953 Renew(xbuf, xAlloc, char);
bbce6d69 954 if (! xbuf)
955 goto bad;
956 }
ef7eada9 957
bbce6d69 958 xin += strlen(s + xin) + 1;
959 xout += xused;
960
961 /* Embedded NULs are understood but silently skipped
962 * because they make no sense in locale collation. */
963 }
ef7eada9 964
bbce6d69 965 xbuf[xout] = '\0';
3280af22 966 *xlen = xout - sizeof(PL_collation_ix);
bbce6d69 967 return xbuf;
968
969 bad:
970 Safefree(xbuf);
971 *xlen = 0;
972 return NULL;
ef7eada9
JH		 973}
974
36477c24 975#endif /* USE_LOCALE_COLLATE */
bbce6d69 976
cf93c79d
IZ		 977#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
978
979/* As a space optimization, we do not compile tables for strings of length
980 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
981 special-cased in fbm_instr().
982
983 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
984
954c1994
GS		 985/*
986=for apidoc fbm_compile
987
988Analyses the string in order to make fast searches on it using fbm_instr()
989-- the Boyer-Moore algorithm.
990
991=cut
992*/
993
378cc40b 994void
7506f9c3 995Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 996{
942e002e
GS		 997 register U8 *s;
998 register U8 *table;
79072805 999 register U32 i;
0b71040e 1000 STRLEN len;
79072805
LW		 1001 I32 rarest = 0;
1002 U32 frequency = 256;
1003
cf93c79d
IZ		 1004 if (flags & FBMcf_TAIL)
1005 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
942e002e 1006 s = (U8*)SvPV_force(sv, len);
07f14f54 1007 (void)SvUPGRADE(sv, SVt_PVBM);
cf93c79d
IZ		 1008 if (len == 0) /* TAIL might be on on a zero-length string. */
1009 return;
02128f11 1010 if (len > 2) {
7506f9c3 1011 U8 mlen;
cf93c79d
IZ		 1012 unsigned char *sb;
1013
7506f9c3 1014 if (len > 255)
cf93c79d 1015 mlen = 255;
7506f9c3
GS		 1016 else
1017 mlen = (U8)len;
1018 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
cf93c79d 1019 table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
7506f9c3
GS		 1020 s = table - 1 - FBM_TABLE_OFFSET; /* last char */
1021 memset((void*)table, mlen, 256);
1022 table[-1] = (U8)flags;
02128f11 1023 i = 0;
7506f9c3 1024 sb = s - mlen + 1; /* first char (maybe) */
cf93c79d
IZ		 1025 while (s >= sb) {
1026 if (table[*s] == mlen)
7506f9c3 1027 table[*s] = (U8)i;
cf93c79d
IZ		 1028 s--, i++;
1029 }
378cc40b 1030 }
bbce6d69 1031 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
79072805 1032 SvVALID_on(sv);
378cc40b 1033
463ee0b2 1034 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
bbce6d69 1035 for (i = 0; i < len; i++) {
22c35a8c 1036 if (PL_freq[s[i]] < frequency) {
bbce6d69 1037 rarest = i;
22c35a8c 1038 frequency = PL_freq[s[i]];
378cc40b
LW		 1039 }
1040 }
79072805
LW		 1041 BmRARE(sv) = s[rarest];
1042 BmPREVIOUS(sv) = rarest;
cf93c79d
IZ		 1043 BmUSEFUL(sv) = 100; /* Initial value */
1044 if (flags & FBMcf_TAIL)
1045 SvTAIL_on(sv);
7506f9c3
GS		 1046 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
1047 BmRARE(sv),BmPREVIOUS(sv)));
378cc40b
LW		 1048}
1049
cf93c79d
IZ		 1050/* If SvTAIL(littlestr), it has a fake '\n' at end. */
1051/* If SvTAIL is actually due to \Z or \z, this gives false positives
1052 if multiline */
1053
954c1994
GS		 1054/*
1055=for apidoc fbm_instr
1056
1057Returns the location of the SV in the string delimited by C<str> and
1058C<strend>. It returns C<Nullch> if the string can't be found. The C<sv>
1059does not have to be fbm_compiled, but the search will not be as fast
1060then.
1061
1062=cut
1063*/
1064
378cc40b 1065char *
864dbfa3 1066Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 1067{
a687059c 1068 register unsigned char *s;
cf93c79d
IZ		 1069 STRLEN l;
1070 register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
1071 register STRLEN littlelen = l;
1072 register I32 multiline = flags & FBMrf_MULTILINE;
1073
1074 if (bigend - big < littlelen) {
a1d180c4 1075 if ( SvTAIL(littlestr)
cf93c79d 1076 && (bigend - big == littlelen - 1)
a1d180c4 1077 && (littlelen == 1
12ae5dfc
JH		 1078 || (*big == *little &&
1079 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d
IZ		 1080 return (char*)big;
1081 return Nullch;
1082 }
378cc40b 1083
cf93c79d 1084 if (littlelen <= 2) { /* Special-cased */
cf93c79d
IZ		 1085
1086 if (littlelen == 1) {
1087 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
1088 /* Know that bigend != big. */
1089 if (bigend[-1] == '\n')
1090 return (char *)(bigend - 1);
1091 return (char *) bigend;
1092 }
1093 s = big;
1094 while (s < bigend) {
1095 if (*s == *little)
1096 return (char *)s;
1097 s++;
1098 }
1099 if (SvTAIL(littlestr))
1100 return (char *) bigend;
1101 return Nullch;
1102 }
1103 if (!littlelen)
1104 return (char*)big; /* Cannot be SvTAIL! */
1105
1106 /* littlelen is 2 */
1107 if (SvTAIL(littlestr) && !multiline) {
1108 if (bigend[-1] == '\n' && bigend[-2] == *little)
1109 return (char*)bigend - 2;
1110 if (bigend[-1] == *little)
1111 return (char*)bigend - 1;
1112 return Nullch;
1113 }
1114 {
1115 /* This should be better than FBM if c1 == c2, and almost
1116 as good otherwise: maybe better since we do less indirection.
1117 And we save a lot of memory by caching no table. */
1118 register unsigned char c1 = little[0];
1119 register unsigned char c2 = little[1];
1120
1121 s = big + 1;
1122 bigend--;
1123 if (c1 != c2) {
1124 while (s <= bigend) {
1125 if (s[0] == c2) {
1126 if (s[-1] == c1)
1127 return (char*)s - 1;
1128 s += 2;
1129 continue;
3fe6f2dc 1130 }
cf93c79d
IZ		 1131 next_chars:
1132 if (s[0] == c1) {
1133 if (s == bigend)
1134 goto check_1char_anchor;
1135 if (s[1] == c2)
1136 return (char*)s;
1137 else {
1138 s++;
1139 goto next_chars;
1140 }
1141 }
1142 else
1143 s += 2;
1144 }
1145 goto check_1char_anchor;
1146 }
1147 /* Now c1 == c2 */
1148 while (s <= bigend) {
1149 if (s[0] == c1) {
1150 if (s[-1] == c1)
1151 return (char*)s - 1;
1152 if (s == bigend)
1153 goto check_1char_anchor;
1154 if (s[1] == c1)
1155 return (char*)s;
1156 s += 3;
02128f11 1157 }
c277df42 1158 else
cf93c79d 1159 s += 2;
c277df42 1160 }
c277df42 1161 }
cf93c79d
IZ		 1162 check_1char_anchor: /* One char and anchor! */
1163 if (SvTAIL(littlestr) && (*bigend == *little))
1164 return (char *)bigend; /* bigend is already decremented. */
1165 return Nullch;
d48672a2 1166 }
cf93c79d 1167 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
bbce6d69 1168 s = bigend - littlelen;
a1d180c4 1169 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ		 1170 /* Automatically of length > 2 */
1171 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 1172 {
bbce6d69 1173 return (char*)s; /* how sweet it is */
7506f9c3
GS		 1174 }
1175 if (s[1] == *little
1176 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
1177 {
cf93c79d 1178 return (char*)s + 1; /* how sweet it is */
7506f9c3 1179 }
02128f11
IZ		 1180 return Nullch;
1181 }
cf93c79d
IZ		 1182 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
1183 char *b = ninstr((char*)big,(char*)bigend,
1184 (char*)little, (char*)little + littlelen);
1185
1186 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
1187 /* Chop \n from littlestr: */
1188 s = bigend - littlelen + 1;
7506f9c3
GS		 1189 if (*s == *little
1190 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1191 {
3fe6f2dc 1192 return (char*)s;
7506f9c3 1193 }
cf93c79d 1194 return Nullch;
a687059c 1195 }
cf93c79d 1196 return b;
a687059c 1197 }
a1d180c4 1198
cf93c79d
IZ		 1199 { /* Do actual FBM. */
1200 register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
1201 register unsigned char *oldlittle;
1202
1203 if (littlelen > bigend - big)
1204 return Nullch;
1205 --littlelen; /* Last char found by table lookup */
1206
1207 s = big + littlelen;
1208 little += littlelen; /* last char */
1209 oldlittle = little;
1210 if (s < bigend) {
1211 register I32 tmp;
1212
1213 top2:
1214 /*SUPPRESS 560*/
7506f9c3 1215 if ((tmp = table[*s])) {
62b28dd9 1216#ifdef POINTERRIGOR
cf93c79d
IZ		 1217 if (bigend - s > tmp) {
1218 s += tmp;
1219 goto top2;
1220 }
bbce6d69 1221 s += tmp;
62b28dd9 1222#else
cf93c79d 1223 if ((s += tmp) < bigend)
62b28dd9 1224 goto top2;
cf93c79d
IZ		 1225#endif
1226 goto check_end;
1227 }
1228 else { /* less expensive than calling strncmp() */
1229 register unsigned char *olds = s;
1230
1231 tmp = littlelen;
1232
1233 while (tmp--) {
1234 if (*--s == *--little)
1235 continue;
cf93c79d
IZ		 1236 s = olds + 1; /* here we pay the price for failure */
1237 little = oldlittle;
1238 if (s < bigend) /* fake up continue to outer loop */
1239 goto top2;
1240 goto check_end;
1241 }
1242 return (char *)s;
a687059c 1243 }
378cc40b 1244 }
cf93c79d
IZ		 1245 check_end:
1246 if ( s == bigend && (table[-1] & FBMcf_TAIL)
12ae5dfc
JH		 1247 && memEQ((char *)(bigend - littlelen),
1248 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d
IZ		 1249 return (char*)bigend - littlelen;
1250 return Nullch;
378cc40b 1251 }
378cc40b
LW		 1252}
1253
c277df42
IZ		 1254/* start_shift, end_shift are positive quantities which give offsets
1255 of ends of some substring of bigstr.
1256 If `last' we want the last occurence.
1257 old_posp is the way of communication between consequent calls if
a1d180c4 1258 the next call needs to find the .
c277df42 1259 The initial *old_posp should be -1.
cf93c79d
IZ		 1260
1261 Note that we take into account SvTAIL, so one can get extra
1262 optimizations if _ALL flag is set.
c277df42
IZ		 1263 */
1264
cf93c79d
IZ		 1265/* If SvTAIL is actually due to \Z or \z, this gives false positives
1266 if PL_multiline. In fact if !PL_multiline the autoritative answer
1267 is not supported yet. */
1268
378cc40b 1269char *
864dbfa3 1270Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
378cc40b 1271{
a687059c
LW		 1272 register unsigned char *s, *x;
1273 register unsigned char *big;
79072805
LW		 1274 register I32 pos;
1275 register I32 previous;
1276 register I32 first;
a687059c 1277 register unsigned char *little;
c277df42 1278 register I32 stop_pos;
a687059c 1279 register unsigned char *littleend;
c277df42 1280 I32 found = 0;
378cc40b 1281
c277df42 1282 if (*old_posp == -1
3280af22 1283 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
cf93c79d
IZ		 1284 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
1285 cant_find:
a1d180c4 1286 if ( BmRARE(littlestr) == '\n'
cf93c79d
IZ		 1287 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
1288 little = (unsigned char *)(SvPVX(littlestr));
1289 littleend = little + SvCUR(littlestr);
1290 first = *little++;
1291 goto check_tail;
1292 }
378cc40b 1293 return Nullch;
cf93c79d
IZ		 1294 }
1295
463ee0b2 1296 little = (unsigned char *)(SvPVX(littlestr));
79072805 1297 littleend = little + SvCUR(littlestr);
378cc40b 1298 first = *little++;
c277df42 1299 /* The value of pos we can start at: */
79072805 1300 previous = BmPREVIOUS(littlestr);
463ee0b2 1301 big = (unsigned char *)(SvPVX(bigstr));
c277df42
IZ		 1302 /* The value of pos we can stop at: */
1303 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
cf93c79d
IZ		 1304 if (previous + start_shift > stop_pos) {
1305 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
1306 goto check_tail;
1307 return Nullch;
1308 }
c277df42 1309 while (pos < previous + start_shift) {
3280af22 1310 if (!(pos += PL_screamnext[pos]))
cf93c79d 1311 goto cant_find;
378cc40b 1312 }
de3bb511 1313#ifdef POINTERRIGOR
bbce6d69 1314 do {
ef64f398 1315 if (pos >= stop_pos) break;
bbce6d69 1316 if (big[pos-previous] != first)
1317 continue;
1318 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
bbce6d69 1319 if (*s++ != *x++) {
1320 s--;
1321 break;
de3bb511 1322 }
bbce6d69 1323 }
c277df42
IZ		 1324 if (s == littleend) {
1325 *old_posp = pos;
1326 if (!last) return (char *)(big+pos-previous);
1327 found = 1;
1328 }
6b88bc9c 1329 } while ( pos += PL_screamnext[pos] );
c277df42 1330 return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
de3bb511
LW		 1331#else /* !POINTERRIGOR */
1332 big -= previous;
bbce6d69 1333 do {
ef64f398 1334 if (pos >= stop_pos) break;
bbce6d69 1335 if (big[pos] != first)
1336 continue;
1337 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69 1338 if (*s++ != *x++) {
1339 s--;
1340 break;
378cc40b 1341 }
bbce6d69 1342 }
c277df42
IZ		 1343 if (s == littleend) {
1344 *old_posp = pos;
1345 if (!last) return (char *)(big+pos);
1346 found = 1;
1347 }
3280af22 1348 } while ( pos += PL_screamnext[pos] );
a1d180c4 1349 if (last && found)
cf93c79d 1350 return (char *)(big+(*old_posp));
de3bb511 1351#endif /* POINTERRIGOR */
cf93c79d
IZ		 1352 check_tail:
1353 if (!SvTAIL(littlestr) || (end_shift > 0))
1354 return Nullch;
1355 /* Ignore the trailing "\n". This code is not microoptimized */
1356 big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
1357 stop_pos = littleend - little; /* Actual littlestr len */
1358 if (stop_pos == 0)
1359 return (char*)big;
1360 big -= stop_pos;
1361 if (*big == first
12ae5dfc
JH		 1362 && ((stop_pos == 1) ||
1363 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
cf93c79d
IZ		 1364 return (char*)big;
1365 return Nullch;
8d063cd8
LW		 1366}
1367
79072805 1368I32
864dbfa3 1369Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
79072805 1370{
bbce6d69 1371 register U8 *a = (U8 *)s1;
1372 register U8 *b = (U8 *)s2;
79072805 1373 while (len--) {
22c35a8c 1374 if (*a != *b && *a != PL_fold[*b])
bbce6d69 1375 return 1;
1376 a++,b++;
1377 }
1378 return 0;
1379}
1380
1381I32
864dbfa3 1382Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
bbce6d69 1383{
1384 register U8 *a = (U8 *)s1;
1385 register U8 *b = (U8 *)s2;
1386 while (len--) {
22c35a8c 1387 if (*a != *b && *a != PL_fold_locale[*b])
bbce6d69 1388 return 1;
1389 a++,b++;
79072805
LW		 1390 }
1391 return 0;
1392}
1393
8d063cd8
LW		 1394/* copy a string to a safe spot */
1395
954c1994
GS		 1396/*
1397=for apidoc savepv
1398
1399Copy a string to a safe spot. This does not use an SV.
1400
1401=cut
1402*/
1403
8d063cd8 1404char *
864dbfa3 1405Perl_savepv(pTHX_ const char *sv)
8d063cd8 1406{
a687059c 1407 register char *newaddr;
8d063cd8 1408
79072805
LW		 1409 New(902,newaddr,strlen(sv)+1,char);
1410 (void)strcpy(newaddr,sv);
8d063cd8
LW		 1411 return newaddr;
1412}
1413
a687059c
LW		 1414/* same thing but with a known length */
1415
954c1994
GS		 1416/*
1417=for apidoc savepvn
1418
1419Copy a string to a safe spot. The C<len> indicates number of bytes to
1420copy. This does not use an SV.
1421
1422=cut
1423*/
1424
a687059c 1425char *
864dbfa3 1426Perl_savepvn(pTHX_ const char *sv, register I32 len)
a687059c
LW		 1427{
1428 register char *newaddr;
1429
1430 New(903,newaddr,len+1,char);
79072805 1431 Copy(sv,newaddr,len,char); /* might not be null terminated */
a687059c
LW		 1432 newaddr[len] = '\0'; /* is now */
1433 return newaddr;
1434}
1435
cea2e8a9 1436/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 1437
76e3520e 1438STATIC SV *
cea2e8a9 1439S_mess_alloc(pTHX)
fc36a67e 1440{
1441 SV *sv;
1442 XPVMG *any;
1443
e72dc28c
GS		 1444 if (!PL_dirty)
1445 return sv_2mortal(newSVpvn("",0));
1446
0372dbb6
GS		 1447 if (PL_mess_sv)
1448 return PL_mess_sv;
1449
fc36a67e 1450 /* Create as PVMG now, to avoid any upgrading later */
1451 New(905, sv, 1, SV);
1452 Newz(905, any, 1, XPVMG);
1453 SvFLAGS(sv) = SVt_PVMG;
1454 SvANY(sv) = (void*)any;
1455 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1456 PL_mess_sv = sv;
fc36a67e 1457 return sv;
1458}
1459
c5be433b 1460#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1461char *
1462Perl_form_nocontext(const char* pat, ...)
1463{
1464 dTHX;
c5be433b 1465 char *retval;
cea2e8a9
GS		 1466 va_list args;
1467 va_start(args, pat);
c5be433b 1468 retval = vform(pat, &args);
cea2e8a9 1469 va_end(args);
c5be433b 1470 return retval;
cea2e8a9 1471}
c5be433b 1472#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1473
8990e307 1474char *
864dbfa3 1475Perl_form(pTHX_ const char* pat, ...)
8990e307 1476{
c5be433b 1477 char *retval;
46fc3d4c 1478 va_list args;
46fc3d4c 1479 va_start(args, pat);
c5be433b 1480 retval = vform(pat, &args);
46fc3d4c 1481 va_end(args);
c5be433b
GS		 1482 return retval;
1483}
1484
1485char *
1486Perl_vform(pTHX_ const char *pat, va_list *args)
1487{
1488 SV *sv = mess_alloc();
1489 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
e72dc28c 1490 return SvPVX(sv);
46fc3d4c 1491}
a687059c 1492
5a844595
GS		 1493#if defined(PERL_IMPLICIT_CONTEXT)
1494SV *
1495Perl_mess_nocontext(const char *pat, ...)
1496{
1497 dTHX;
1498 SV *retval;
1499 va_list args;
1500 va_start(args, pat);
1501 retval = vmess(pat, &args);
1502 va_end(args);
1503 return retval;
1504}
1505#endif /* PERL_IMPLICIT_CONTEXT */
1506
06bf62c7 1507SV *
5a844595
GS		 1508Perl_mess(pTHX_ const char *pat, ...)
1509{
1510 SV *retval;
1511 va_list args;
1512 va_start(args, pat);
1513 retval = vmess(pat, &args);
1514 va_end(args);
1515 return retval;
1516}
1517
1518SV *
1519Perl_vmess(pTHX_ const char *pat, va_list *args)
46fc3d4c 1520{
e72dc28c 1521 SV *sv = mess_alloc();
46fc3d4c 1522 static char dgd[] = " during global destruction.\n";
1523
fc36a67e 1524 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
46fc3d4c 1525 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
57843af0 1526 if (CopLINE(PL_curcop))
ed094faf
GS		 1527 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1528 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
515f54a1
GS		 1529 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1530 bool line_mode = (RsSIMPLE(PL_rs) &&
7c1e0849 1531 SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
57def98f 1532 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
cf2093f6 1533 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
a1d180c4 1534 line_mode ? "line" : "chunk",
cf2093f6 1535 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1536 }
9efbc0eb 1537#ifdef USE_THREADS
e8e6f333
GS		 1538 if (thr->tid)
1539 Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
9efbc0eb 1540#endif
515f54a1 1541 sv_catpv(sv, PL_dirty ? dgd : ".\n");
a687059c 1542 }
06bf62c7 1543 return sv;
a687059c
LW		 1544}
1545
c5be433b
GS		 1546OP *
1547Perl_vdie(pTHX_ const char* pat, va_list *args)
36477c24 1548{
36477c24 1549 char *message;
3280af22 1550 int was_in_eval = PL_in_eval;
36477c24 1551 HV *stash;
1552 GV *gv;
1553 CV *cv;
06bf62c7
GS		 1554 SV *msv;
1555 STRLEN msglen;
36477c24 1556
bf49b057 1557 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 1558 "%p: die: curstack = %p, mainstack = %p\n",
533c011a 1559 thr, PL_curstack, PL_mainstack));
36477c24 1560
06bf62c7 1561 if (pat) {
5a844595
GS		 1562 msv = vmess(pat, args);
1563 if (PL_errors && SvCUR(PL_errors)) {
1564 sv_catsv(PL_errors, msv);
1565 message = SvPV(PL_errors, msglen);
1566 SvCUR_set(PL_errors, 0);
1567 }
1568 else
1569 message = SvPV(msv,msglen);
06bf62c7
GS		 1570 }
1571 else {
1572 message = Nullch;
0f79a09d 1573 msglen = 0;
06bf62c7 1574 }
36477c24 1575
bf49b057 1576 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 1577 "%p: die: message = %s\ndiehook = %p\n",
533c011a 1578 thr, message, PL_diehook));
3280af22 1579 if (PL_diehook) {
cea2e8a9 1580 /* sv_2cv might call Perl_croak() */
3280af22 1581 SV *olddiehook = PL_diehook;
1738f5c4 1582 ENTER;
3280af22
NIS		 1583 SAVESPTR(PL_diehook);
1584 PL_diehook = Nullsv;
1738f5c4
CS		 1585 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1586 LEAVE;
1587 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1588 dSP;
774d564b 1589 SV *msg;
1590
1591 ENTER;
3a1f2dc9 1592 save_re_context();
79cb57f6 1593 if (message) {
06bf62c7 1594 msg = newSVpvn(message, msglen);
4e6ea2c3
GS		 1595 SvREADONLY_on(msg);
1596 SAVEFREESV(msg);
1597 }
1598 else {
1599 msg = ERRSV;
1600 }
1738f5c4 1601
e788e7d3 1602 PUSHSTACKi(PERLSI_DIEHOOK);
924508f0 1603 PUSHMARK(SP);
1738f5c4
CS		 1604 XPUSHs(msg);
1605 PUTBACK;
0cdb2077 1606 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1607 POPSTACK;
774d564b 1608 LEAVE;
1738f5c4 1609 }
36477c24 1610 }
1611
06bf62c7 1612 PL_restartop = die_where(message, msglen);
bf49b057 1613 DEBUG_S(PerlIO_printf(Perl_debug_log,
7c06b590 1614 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
533c011a 1615 thr, PL_restartop, was_in_eval, PL_top_env));
3280af22 1616 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
6224f72b 1617 JMPENV_JUMP(3);
3280af22 1618 return PL_restartop;
36477c24 1619}
1620
c5be433b 1621#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1622OP *
1623Perl_die_nocontext(const char* pat, ...)
a687059c 1624{
cea2e8a9
GS		 1625 dTHX;
1626 OP *o;
a687059c 1627 va_list args;
cea2e8a9 1628 va_start(args, pat);
c5be433b 1629 o = vdie(pat, &args);
cea2e8a9
GS		 1630 va_end(args);
1631 return o;
1632}
c5be433b 1633#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS		 1634
1635OP *
1636Perl_die(pTHX_ const char* pat, ...)
1637{
1638 OP *o;
1639 va_list args;
1640 va_start(args, pat);
c5be433b 1641 o = vdie(pat, &args);
cea2e8a9
GS		 1642 va_end(args);
1643 return o;
1644}
1645
c5be433b
GS		 1646void
1647Perl_vcroak(pTHX_ const char* pat, va_list *args)
cea2e8a9 1648{
de3bb511 1649 char *message;
748a9306
LW		 1650 HV *stash;
1651 GV *gv;
1652 CV *cv;
06bf62c7
GS		 1653 SV *msv;
1654 STRLEN msglen;
a687059c 1655
9983fa3c
GS		 1656 if (pat) {
1657 msv = vmess(pat, args);
1658 if (PL_errors && SvCUR(PL_errors)) {
1659 sv_catsv(PL_errors, msv);
1660 message = SvPV(PL_errors, msglen);
1661 SvCUR_set(PL_errors, 0);
1662 }
1663 else
1664 message = SvPV(msv,msglen);
1665 }
1666 else {
1667 message = Nullch;
1668 msglen = 0;
5a844595 1669 }
5a844595 1670
b900a521
JH		 1671 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1672 PTR2UV(thr), message));
5a844595 1673
3280af22 1674 if (PL_diehook) {
cea2e8a9 1675 /* sv_2cv might call Perl_croak() */
3280af22 1676 SV *olddiehook = PL_diehook;
1738f5c4 1677 ENTER;
3280af22
NIS		 1678 SAVESPTR(PL_diehook);
1679 PL_diehook = Nullsv;
20cec16a 1680 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1738f5c4
CS		 1681 LEAVE;
1682 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1683 dSP;
774d564b 1684 SV *msg;
1685
1686 ENTER;
3a1f2dc9 1687 save_re_context();
9983fa3c
GS		 1688 if (message) {
1689 msg = newSVpvn(message, msglen);
1690 SvREADONLY_on(msg);
1691 SAVEFREESV(msg);
1692 }
1693 else {
1694 msg = ERRSV;
1695 }
20cec16a 1696
e788e7d3 1697 PUSHSTACKi(PERLSI_DIEHOOK);
924508f0 1698 PUSHMARK(SP);
1738f5c4 1699 XPUSHs(msg);
20cec16a 1700 PUTBACK;
864dbfa3 1701 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1702 POPSTACK;
774d564b 1703 LEAVE;
20cec16a 1704 }
748a9306 1705 }
3280af22 1706 if (PL_in_eval) {
06bf62c7 1707 PL_restartop = die_where(message, msglen);
6224f72b 1708 JMPENV_JUMP(3);
a0d0e21e 1709 }
d175a3f0
GS		 1710 {
1711#ifdef USE_SFIO
1712 /* SFIO can really mess with your errno */
1713 int e = errno;
1714#endif
bf49b057
GS		 1715 PerlIO *serr = Perl_error_log;
1716
1717 PerlIO_write(serr, message, msglen);
1718 (void)PerlIO_flush(serr);
d175a3f0
GS		 1719#ifdef USE_SFIO
1720 errno = e;
1721#endif
1722 }
f86702cc 1723 my_failure_exit();
a687059c
LW		 1724}
1725
c5be433b 1726#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1727void
cea2e8a9 1728Perl_croak_nocontext(const char *pat, ...)
a687059c 1729{
cea2e8a9 1730 dTHX;
a687059c 1731 va_list args;
cea2e8a9 1732 va_start(args, pat);
c5be433b 1733 vcroak(pat, &args);
cea2e8a9
GS		 1734 /* NOTREACHED */
1735 va_end(args);
1736}
1737#endif /* PERL_IMPLICIT_CONTEXT */
1738
954c1994
GS		 1739/*
1740=for apidoc croak
1741
9983fa3c
GS		 1742This is the XSUB-writer's interface to Perl's C<die> function.
1743Normally use this function the same way you use the C C<printf>
1744function. See C<warn>.
1745
1746If you want to throw an exception object, assign the object to
1747C<$@> and then pass C<Nullch> to croak():
1748
1749 errsv = get_sv("@", TRUE);
1750 sv_setsv(errsv, exception_object);
1751 croak(Nullch);
954c1994
GS		 1752
1753=cut
1754*/
1755
cea2e8a9
GS		 1756void
1757Perl_croak(pTHX_ const char *pat, ...)
1758{
1759 va_list args;
1760 va_start(args, pat);
c5be433b 1761 vcroak(pat, &args);
cea2e8a9
GS		 1762 /* NOTREACHED */
1763 va_end(args);
1764}
1765
c5be433b
GS		 1766void
1767Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1768{
de3bb511 1769 char *message;
748a9306
LW		 1770 HV *stash;
1771 GV *gv;
1772 CV *cv;
06bf62c7
GS		 1773 SV *msv;
1774 STRLEN msglen;
a687059c 1775
5a844595 1776 msv = vmess(pat, args);
06bf62c7 1777 message = SvPV(msv, msglen);
a687059c 1778
3280af22 1779 if (PL_warnhook) {
cea2e8a9 1780 /* sv_2cv might call Perl_warn() */
3280af22 1781 SV *oldwarnhook = PL_warnhook;
1738f5c4 1782 ENTER;
3280af22
NIS		 1783 SAVESPTR(PL_warnhook);
1784 PL_warnhook = Nullsv;
20cec16a 1785 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1738f5c4
CS		 1786 LEAVE;
1787 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1788 dSP;
774d564b 1789 SV *msg;
1790
1791 ENTER;
3a1f2dc9 1792 save_re_context();
06bf62c7 1793 msg = newSVpvn(message, msglen);
774d564b 1794 SvREADONLY_on(msg);
1795 SAVEFREESV(msg);
1796
e788e7d3 1797 PUSHSTACKi(PERLSI_WARNHOOK);
924508f0 1798 PUSHMARK(SP);
774d564b 1799 XPUSHs(msg);
20cec16a 1800 PUTBACK;
864dbfa3 1801 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1802 POPSTACK;
774d564b 1803 LEAVE;
20cec16a 1804 return;
1805 }
748a9306 1806 }
bf49b057
GS		 1807 {
1808 PerlIO *serr = Perl_error_log;
1809
1810 PerlIO_write(serr, message, msglen);
a687059c 1811#ifdef LEAKTEST
a1d180c4 1812 DEBUG_L(*message == '!'
bf49b057
GS		 1813 ? (xstat(message[1]=='!'
1814 ? (message[2]=='!' ? 2 : 1)
1815 : 0)
1816 , 0)
1817 : 0);
a687059c 1818#endif
bf49b057
GS		 1819 (void)PerlIO_flush(serr);
1820 }
a687059c 1821}
8d063cd8 1822
c5be433b 1823#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1824void
1825Perl_warn_nocontext(const char *pat, ...)
1826{
1827 dTHX;
1828 va_list args;
1829 va_start(args, pat);
c5be433b 1830 vwarn(pat, &args);
cea2e8a9
GS		 1831 va_end(args);
1832}
1833#endif /* PERL_IMPLICIT_CONTEXT */
1834
954c1994
GS		 1835/*
1836=for apidoc warn
1837
1838This is the XSUB-writer's interface to Perl's C<warn> function. Use this
1839function the same way you use the C C<printf> function. See
1840C<croak>.
1841
1842=cut
1843*/
1844
cea2e8a9
GS		 1845void
1846Perl_warn(pTHX_ const char *pat, ...)
1847{
1848 va_list args;
1849 va_start(args, pat);
c5be433b 1850 vwarn(pat, &args);
cea2e8a9
GS		 1851 va_end(args);
1852}
1853
c5be433b
GS		 1854#if defined(PERL_IMPLICIT_CONTEXT)
1855void
1856Perl_warner_nocontext(U32 err, const char *pat, ...)
1857{
1858 dTHX;
1859 va_list args;
1860 va_start(args, pat);
1861 vwarner(err, pat, &args);
1862 va_end(args);
1863}
1864#endif /* PERL_IMPLICIT_CONTEXT */
1865
599cee73 1866void
864dbfa3 1867Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1868{
1869 va_list args;
c5be433b
GS		 1870 va_start(args, pat);
1871 vwarner(err, pat, &args);
1872 va_end(args);
1873}
1874
1875void
1876Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1877{
599cee73
PM		 1878 char *message;
1879 HV *stash;
1880 GV *gv;
1881 CV *cv;
06bf62c7
GS		 1882 SV *msv;
1883 STRLEN msglen;
599cee73 1884
5a844595 1885 msv = vmess(pat, args);
06bf62c7 1886 message = SvPV(msv, msglen);
599cee73
PM		 1887
1888 if (ckDEAD(err)) {
1889#ifdef USE_THREADS
b900a521 1890 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
599cee73
PM		 1891#endif /* USE_THREADS */
1892 if (PL_diehook) {
cea2e8a9 1893 /* sv_2cv might call Perl_croak() */
599cee73
PM		 1894 SV *olddiehook = PL_diehook;
1895 ENTER;
1896 SAVESPTR(PL_diehook);
1897 PL_diehook = Nullsv;
1898 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1899 LEAVE;
1900 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1901 dSP;
1902 SV *msg;
a1d180c4 1903
599cee73 1904 ENTER;
3a1f2dc9 1905 save_re_context();
06bf62c7 1906 msg = newSVpvn(message, msglen);
599cee73
PM		 1907 SvREADONLY_on(msg);
1908 SAVEFREESV(msg);
a1d180c4 1909
3a1f2dc9 1910 PUSHSTACKi(PERLSI_DIEHOOK);
599cee73
PM		 1911 PUSHMARK(sp);
1912 XPUSHs(msg);
1913 PUTBACK;
864dbfa3 1914 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1915 POPSTACK;
599cee73
PM		 1916 LEAVE;
1917 }
1918 }
1919 if (PL_in_eval) {
06bf62c7 1920 PL_restartop = die_where(message, msglen);
599cee73
PM		 1921 JMPENV_JUMP(3);
1922 }
bf49b057
GS		 1923 {
1924 PerlIO *serr = Perl_error_log;
1925 PerlIO_write(serr, message, msglen);
1926 (void)PerlIO_flush(serr);
1927 }
599cee73
PM		 1928 my_failure_exit();
1929
1930 }
1931 else {
1932 if (PL_warnhook) {
cea2e8a9 1933 /* sv_2cv might call Perl_warn() */
599cee73
PM		 1934 SV *oldwarnhook = PL_warnhook;
1935 ENTER;
1936 SAVESPTR(PL_warnhook);
1937 PL_warnhook = Nullsv;
1938 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
3a1f2dc9 1939 LEAVE;
599cee73
PM		 1940 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1941 dSP;
1942 SV *msg;
a1d180c4 1943
599cee73 1944 ENTER;
3a1f2dc9 1945 save_re_context();
06bf62c7 1946 msg = newSVpvn(message, msglen);
599cee73
PM		 1947 SvREADONLY_on(msg);
1948 SAVEFREESV(msg);
a1d180c4 1949
3a1f2dc9 1950 PUSHSTACKi(PERLSI_WARNHOOK);
599cee73
PM		 1951 PUSHMARK(sp);
1952 XPUSHs(msg);
1953 PUTBACK;
864dbfa3 1954 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1955 POPSTACK;
599cee73
PM		 1956 LEAVE;
1957 return;
1958 }
1959 }
bf49b057
GS		 1960 {
1961 PerlIO *serr = Perl_error_log;
1962 PerlIO_write(serr, message, msglen);
599cee73 1963#ifdef LEAKTEST
a1d180c4 1964 DEBUG_L(*message == '!'
06247ec9
JH		 1965 ? (xstat(message[1]=='!'
1966 ? (message[2]=='!' ? 2 : 1)
1967 : 0)
1968 , 0)
1969 : 0);
599cee73 1970#endif
bf49b057
GS		 1971 (void)PerlIO_flush(serr);
1972 }
599cee73
PM		 1973 }
1974}
1975
13b6e58c
JH		 1976#ifdef USE_ENVIRON_ARRAY
1977 /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
47dafe4d 1978#if !defined(WIN32)
8d063cd8 1979void
864dbfa3 1980Perl_my_setenv(pTHX_ char *nam, char *val)
8d063cd8 1981{
f2517201
GS		 1982#ifndef PERL_USE_SAFE_PUTENV
1983 /* most putenv()s leak, so we manipulate environ directly */
79072805 1984 register I32 i=setenv_getix(nam); /* where does it go? */
8d063cd8 1985
3280af22 1986 if (environ == PL_origenviron) { /* need we copy environment? */
79072805
LW		 1987 I32 j;
1988 I32 max;
fe14fcc3
LW		 1989 char **tmpenv;
1990
de3bb511 1991 /*SUPPRESS 530*/
fe14fcc3 1992 for (max = i; environ[max]; max++) ;
f2517201
GS		 1993 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1994 for (j=0; j<max; j++) { /* copy environment */
1995 tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
1996 strcpy(tmpenv[j], environ[j]);
1997 }
fe14fcc3
LW		 1998 tmpenv[max] = Nullch;
1999 environ = tmpenv; /* tell exec where it is now */
2000 }
a687059c 2001 if (!val) {
f2517201 2002 safesysfree(environ[i]);
a687059c
LW		 2003 while (environ[i]) {
2004 environ[i] = environ[i+1];
2005 i++;
2006 }
2007 return;
2008 }
8d063cd8 2009 if (!environ[i]) { /* does not exist yet */
f2517201 2010 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
8d063cd8
LW		 2011 environ[i+1] = Nullch; /* make sure it's null terminated */
2012 }
fe14fcc3 2013 else
f2517201
GS		 2014 safesysfree(environ[i]);
2015 environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
2016
a687059c 2017 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
f2517201
GS		 2018
2019#else /* PERL_USE_SAFE_PUTENV */
47dafe4d
EF		 2020# if defined(__CYGWIN__)
2021 setenv(nam, val, 1);
2022# else
f2517201
GS		 2023 char *new_env;
2024
2025 new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
f2517201 2026 (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
f2517201 2027 (void)putenv(new_env);
47dafe4d 2028# endif /* __CYGWIN__ */
f2517201 2029#endif /* PERL_USE_SAFE_PUTENV */
8d063cd8
LW		 2030}
2031
47dafe4d 2032#else /* WIN32 */
68dc0745 2033
2034void
864dbfa3 2035Perl_my_setenv(pTHX_ char *nam,char *val)
68dc0745 2036{
3e3baf6d
TB		 2037
2038#ifdef USE_WIN32_RTL_ENV
2039
68dc0745 2040 register char *envstr;
2041 STRLEN namlen = strlen(nam);
3e3baf6d
TB		 2042 STRLEN vallen;
2043 char *oldstr = environ[setenv_getix(nam)];
2044
2045 /* putenv() has totally broken semantics in both the Borland
2046 * and Microsoft CRTLs. They either store the passed pointer in
2047 * the environment without making a copy, or make a copy and don't
2048 * free it. And on top of that, they dont free() old entries that
2049 * are being replaced/deleted. This means the caller must
2050 * free any old entries somehow, or we end up with a memory
2051 * leak every time my_setenv() is called. One might think
2052 * one could directly manipulate environ[], like the UNIX code
2053 * above, but direct changes to environ are not allowed when
2054 * calling putenv(), since the RTLs maintain an internal
2055 * *copy* of environ[]. Bad, bad, *bad* stink.
2056 * GSAR 97-06-07
2057 */
68dc0745 2058
3e3baf6d
TB		 2059 if (!val) {
2060 if (!oldstr)
2061 return;
2062 val = "";
2063 vallen = 0;
2064 }
2065 else
2066 vallen = strlen(val);
f2517201 2067 envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char));
68dc0745 2068 (void)sprintf(envstr,"%s=%s",nam,val);
76e3520e 2069 (void)PerlEnv_putenv(envstr);
3e3baf6d 2070 if (oldstr)
f2517201 2071 safesysfree(oldstr);
3e3baf6d 2072#ifdef _MSC_VER
f2517201 2073 safesysfree(envstr); /* MSVCRT leaks without this */
3e3baf6d
TB		 2074#endif
2075
2076#else /* !USE_WIN32_RTL_ENV */
2077
ac5c734f
GS		 2078 register char *envstr;
2079 STRLEN len = strlen(nam) + 3;
2080 if (!val) {
2081 val = "";
2082 }
2083 len += strlen(val);
2084 New(904, envstr, len, char);
2085 (void)sprintf(envstr,"%s=%s",nam,val);
2086 (void)PerlEnv_putenv(envstr);
2087 Safefree(envstr);
3e3baf6d
TB		 2088
2089#endif
2090}
2091
2092#endif /* WIN32 */
2093
2094I32
864dbfa3 2095Perl_setenv_getix(pTHX_ char *nam)
3e3baf6d
TB		 2096{
2097 register I32 i, len = strlen(nam);
2098
2099 for (i = 0; environ[i]; i++) {
2100 if (
2101#ifdef WIN32
2102 strnicmp(environ[i],nam,len) == 0
2103#else
2104 strnEQ(environ[i],nam,len)
2105#endif
2106 && environ[i][len] == '=')
2107 break; /* strnEQ must come first to avoid */
2108 } /* potential SEGV's */
2109 return i;
68dc0745 2110}
2111
ed79a026 2112#endif /* !VMS && !EPOC*/
378cc40b 2113
16d20bd9 2114#ifdef UNLINK_ALL_VERSIONS
79072805 2115I32
864dbfa3 2116Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
378cc40b 2117{
79072805 2118 I32 i;
378cc40b 2119
6ad3d225 2120 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
378cc40b
LW		 2121 return i ? 0 : -1;
2122}
2123#endif
2124
7a3f2258 2125/* this is a drop-in replacement for bcopy() */
85e6fe83 2126#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
378cc40b 2127char *
7a3f2258 2128Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b
LW		 2129{
2130 char *retval = to;
2131
7c0587c8
LW		 2132 if (from - to >= 0) {
2133 while (len--)
2134 *to++ = *from++;
2135 }
2136 else {
2137 to += len;
2138 from += len;
2139 while (len--)
faf8582f 2140 *(--to) = *(--from);
7c0587c8 2141 }
378cc40b
LW		 2142 return retval;
2143}
ffed7fef 2144#endif
378cc40b 2145
7a3f2258 2146/* this is a drop-in replacement for memset() */
fc36a67e 2147#ifndef HAS_MEMSET
2148void *
7a3f2258 2149Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 2150{
2151 char *retval = loc;
2152
2153 while (len--)
2154 *loc++ = ch;
2155 return retval;
2156}
2157#endif
2158
7a3f2258 2159/* this is a drop-in replacement for bzero() */
7c0587c8 2160#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 2161char *
7a3f2258 2162Perl_my_bzero(register char *loc, register I32 len)
378cc40b
LW		 2163{
2164 char *retval = loc;
2165
2166 while (len--)
2167 *loc++ = 0;
2168 return retval;
2169}
2170#endif
7c0587c8 2171
7a3f2258 2172/* this is a drop-in replacement for memcmp() */
36477c24 2173#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 2174I32
7a3f2258 2175Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 2176{
36477c24 2177 register U8 *a = (U8 *)s1;
2178 register U8 *b = (U8 *)s2;
79072805 2179 register I32 tmp;
7c0587c8
LW		 2180
2181 while (len--) {
36477c24 2182 if (tmp = *a++ - *b++)
7c0587c8
LW		 2183 return tmp;
2184 }
2185 return 0;
2186}
36477c24 2187#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 2188
fe14fcc3 2189#ifndef HAS_VPRINTF
a687059c 2190
85e6fe83 2191#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 2192char *
2193#else
2194int
2195#endif
08105a92 2196vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 2197{
2198 FILE fakebuf;
2199
2200 fakebuf._ptr = dest;
2201 fakebuf._cnt = 32767;
35c8bce7
LW		 2202#ifndef _IOSTRG
2203#define _IOSTRG 0
2204#endif
a687059c
LW		 2205 fakebuf._flag = _IOWRT|_IOSTRG;
2206 _doprnt(pat, args, &fakebuf); /* what a kludge */
2207 (void)putc('\0', &fakebuf);
85e6fe83 2208#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 2209 return(dest);
2210#else
2211 return 0; /* perl doesn't use return value */
2212#endif
2213}
2214
fe14fcc3 2215#endif /* HAS_VPRINTF */
a687059c
LW		 2216
2217#ifdef MYSWAP
ffed7fef 2218#if BYTEORDER != 0x4321
a687059c 2219short
864dbfa3 2220Perl_my_swap(pTHX_ short s)
a687059c
LW		 2221{
2222#if (BYTEORDER & 1) == 0
2223 short result;
2224
2225 result = ((s & 255) << 8) + ((s >> 8) & 255);
2226 return result;
2227#else
2228 return s;
2229#endif
2230}
2231
2232long
864dbfa3 2233Perl_my_htonl(pTHX_ long l)
a687059c
LW		 2234{
2235 union {
2236 long result;
ffed7fef 2237 char c[sizeof(long)];
a687059c
LW		 2238 } u;
2239
ffed7fef 2240#if BYTEORDER == 0x1234
a687059c
LW		 2241 u.c[0] = (l >> 24) & 255;
2242 u.c[1] = (l >> 16) & 255;
2243 u.c[2] = (l >> 8) & 255;
2244 u.c[3] = l & 255;
2245 return u.result;
2246#else
ffed7fef 2247#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2248 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2249#else
79072805
LW		 2250 register I32 o;
2251 register I32 s;
a687059c 2252
ffed7fef
LW		 2253 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2254 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 2255 }
2256 return u.result;
2257#endif
2258#endif
2259}
2260
2261long
864dbfa3 2262Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 2263{
2264 union {
2265 long l;
ffed7fef 2266 char c[sizeof(long)];
a687059c
LW		 2267 } u;
2268
ffed7fef 2269#if BYTEORDER == 0x1234
a687059c
LW		 2270 u.c[0] = (l >> 24) & 255;
2271 u.c[1] = (l >> 16) & 255;
2272 u.c[2] = (l >> 8) & 255;
2273 u.c[3] = l & 255;
2274 return u.l;
2275#else
ffed7fef 2276#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 2277 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 2278#else
79072805
LW		 2279 register I32 o;
2280 register I32 s;
a687059c
LW		 2281
2282 u.l = l;
2283 l = 0;
ffed7fef
LW		 2284 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2285 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 2286 }
2287 return l;
2288#endif
2289#endif
2290}
2291
ffed7fef 2292#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 2293#endif /* MYSWAP */
2294
2295/*
2296 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2297 * If these functions are defined,
2298 * the BYTEORDER is neither 0x1234 nor 0x4321.
2299 * However, this is not assumed.
2300 * -DWS
2301 */
2302
2303#define HTOV(name,type) \
2304 type \
ba106d47 2305 name (register type n) \
988174c1
LW		 2306 { \
2307 union { \
2308 type value; \
2309 char c[sizeof(type)]; \
2310 } u; \
79072805
LW		 2311 register I32 i; \
2312 register I32 s; \
988174c1
LW		 2313 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
2314 u.c[i] = (n >> s) & 0xFF; \
2315 } \
2316 return u.value; \
2317 }
2318
2319#define VTOH(name,type) \
2320 type \
ba106d47 2321 name (register type n) \
988174c1
LW		 2322 { \
2323 union { \
2324 type value; \
2325 char c[sizeof(type)]; \
2326 } u; \
79072805
LW		 2327 register I32 i; \
2328 register I32 s; \
988174c1
LW		 2329 u.value = n; \
2330 n = 0; \
2331 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
2332 n += (u.c[i] & 0xFF) << s; \
2333 } \
2334 return n; \
2335 }
2336
2337#if defined(HAS_HTOVS) && !defined(htovs)
2338HTOV(htovs,short)
2339#endif
2340#if defined(HAS_HTOVL) && !defined(htovl)
2341HTOV(htovl,long)
2342#endif
2343#if defined(HAS_VTOHS) && !defined(vtohs)
2344VTOH(vtohs,short)
2345#endif
2346#if defined(HAS_VTOHL) && !defined(vtohl)
2347VTOH(vtohl,long)
2348#endif
a687059c 2349
5f05dabc 2350 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2351#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2352PerlIO *
864dbfa3 2353Perl_my_popen(pTHX_ char *cmd, char *mode)
a687059c
LW		 2354{
2355 int p[2];
8ac85365 2356 register I32 This, that;
d8a83dd3 2357 register Pid_t pid;
79072805 2358 SV *sv;
1738f5c4 2359 I32 doexec = strNE(cmd,"-");
e446cec8
IZ		 2360 I32 did_pipes = 0;
2361 int pp[2];
a687059c 2362
45bc9206 2363 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2364#ifdef OS2
2365 if (doexec) {
23da6c43 2366 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2367 }
a1d180c4 2368#endif
8ac85365
NIS		 2369 This = (*mode == 'w');
2370 that = !This;
3280af22 2371 if (doexec && PL_tainting) {
bbce6d69 2372 taint_env();
2373 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2374 }
c2267164
IZ		 2375 if (PerlProc_pipe(p) < 0)
2376 return Nullfp;
e446cec8
IZ		 2377 if (doexec && PerlProc_pipe(pp) >= 0)
2378 did_pipes = 1;
a687059c
LW		 2379 while ((pid = (doexec?vfork():fork())) < 0) {
2380 if (errno != EAGAIN) {
6ad3d225 2381 PerlLIO_close(p[This]);
e446cec8
IZ		 2382 if (did_pipes) {
2383 PerlLIO_close(pp[0]);
2384 PerlLIO_close(pp[1]);
2385 }
a687059c 2386 if (!doexec)
cea2e8a9 2387 Perl_croak(aTHX_ "Can't fork");
a687059c
LW		 2388 return Nullfp;
2389 }
2390 sleep(5);
2391 }
2392 if (pid == 0) {
79072805
LW		 2393 GV* tmpgv;
2394
30ac6d9b
GS		 2395#undef THIS
2396#undef THAT
a687059c 2397#define THIS that
8ac85365 2398#define THAT This
6ad3d225 2399 PerlLIO_close(p[THAT]);
e446cec8
IZ		 2400 if (did_pipes) {
2401 PerlLIO_close(pp[0]);
2402#if defined(HAS_FCNTL) && defined(F_SETFD)
2403 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2404#endif
2405 }
a687059c 2406 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2407 PerlLIO_dup2(p[THIS], *mode == 'r');
2408 PerlLIO_close(p[THIS]);
a687059c 2409 }
4435c477 2410#ifndef OS2
a687059c 2411 if (doexec) {
a0d0e21e 2412#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2413 int fd;
2414
2415#ifndef NOFILE
2416#define NOFILE 20
2417#endif
6b88bc9c 2418 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
e446cec8
IZ		 2419 if (fd != pp[1])
2420 PerlLIO_close(fd);
ae986130 2421#endif
e446cec8 2422 do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */
6ad3d225 2423 PerlProc__exit(1);
a687059c 2424 }
4435c477 2425#endif /* defined OS2 */
de3bb511 2426 /*SUPPRESS 560*/
155aba94 2427 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
7766f137 2428 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
3280af22
NIS		 2429 PL_forkprocess = 0;
2430 hv_clear(PL_pidstatus); /* we have no children */
a687059c
LW		 2431 return Nullfp;
2432#undef THIS
2433#undef THAT
2434 }
62b28dd9 2435 do_execfree(); /* free any memory malloced by child on vfork */
6ad3d225 2436 PerlLIO_close(p[that]);
e446cec8
IZ		 2437 if (did_pipes)
2438 PerlLIO_close(pp[1]);
8ac85365 2439 if (p[that] < p[This]) {
6ad3d225
GS		 2440 PerlLIO_dup2(p[This], p[that]);
2441 PerlLIO_close(p[This]);
8ac85365 2442 p[This] = p[that];
62b28dd9 2443 }
4755096e 2444 LOCK_FDPID_MUTEX;
3280af22 2445 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2446 UNLOCK_FDPID_MUTEX;
a0d0e21e 2447 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2448 SvIVX(sv) = pid;
3280af22 2449 PL_forkprocess = pid;
e446cec8
IZ		 2450 if (did_pipes && pid > 0) {
2451 int errkid;
2452 int n = 0, n1;
2453
2454 while (n < sizeof(int)) {
2455 n1 = PerlLIO_read(pp[0],
2456 (void*)(((char*)&errkid)+n),
2457 (sizeof(int)) - n);
2458 if (n1 <= 0)
2459 break;
2460 n += n1;
2461 }
2f96c702
IZ		 2462 PerlLIO_close(pp[0]);
2463 did_pipes = 0;
e446cec8 2464 if (n) { /* Error */
faa466a7 2465 int pid2, status;
e446cec8 2466 if (n != sizeof(int))
cea2e8a9 2467 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2468 do {
2469 pid2 = wait4pid(pid, &status, 0);
2470 } while (pid2 == -1 && errno == EINTR);
e446cec8
IZ		 2471 errno = errkid; /* Propagate errno from kid */
2472 return Nullfp;
2473 }
2474 }
2475 if (did_pipes)
2476 PerlLIO_close(pp[0]);
8ac85365 2477 return PerlIO_fdopen(p[This], mode);
a687059c 2478}
7c0587c8 2479#else
55497cff 2480#if defined(atarist) || defined(DJGPP)
7c0587c8 2481FILE *popen();
760ac839 2482PerlIO *
864dbfa3 2483Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2484{
45bc9206 2485 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2486 /* Call system's popen() to get a FILE *, then import it.
2487 used 0 for 2nd parameter to PerlIO_importFILE;
2488 apparently not used
2489 */
2490 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8
LW		 2491}
2492#endif
2493
2494#endif /* !DOSISH */
a687059c 2495
748a9306 2496#ifdef DUMP_FDS
35ff7856 2497void
864dbfa3 2498Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2499{
2500 int fd;
2501 struct stat tmpstatbuf;
2502
bf49b057 2503 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2504 for (fd = 0; fd < 32; fd++) {
6ad3d225 2505 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2506 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2507 }
bf49b057 2508 PerlIO_printf(Perl_debug_log,"\n");
ae986130 2509}
35ff7856 2510#endif /* DUMP_FDS */
ae986130 2511
fe14fcc3 2512#ifndef HAS_DUP2
fec02dd3 2513int
ba106d47 2514dup2(int oldfd, int newfd)
a687059c 2515{
a0d0e21e 2516#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2517 if (oldfd == newfd)
2518 return oldfd;
6ad3d225 2519 PerlLIO_close(newfd);
fec02dd3 2520 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2521#else
fc36a67e 2522#define DUP2_MAX_FDS 256
2523 int fdtmp[DUP2_MAX_FDS];
79072805 2524 I32 fdx = 0;
ae986130
LW		 2525 int fd;
2526
fe14fcc3 2527 if (oldfd == newfd)
fec02dd3 2528 return oldfd;
6ad3d225 2529 PerlLIO_close(newfd);
fc36a67e 2530 /* good enough for low fd's... */
6ad3d225 2531 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2532 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2533 PerlLIO_close(fd);
fc36a67e 2534 fd = -1;
2535 break;
2536 }
ae986130 2537 fdtmp[fdx++] = fd;
fc36a67e 2538 }
ae986130 2539 while (fdx > 0)
6ad3d225 2540 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2541 return fd;
62b28dd9 2542#endif
a687059c
LW		 2543}
2544#endif
2545
64ca3a65 2546#ifndef PERL_MICRO
ff68c719 2547#ifdef HAS_SIGACTION
2548
2549Sighandler_t
864dbfa3 2550Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2551{
2552 struct sigaction act, oact;
2553
2554 act.sa_handler = handler;
2555 sigemptyset(&act.sa_mask);
2556 act.sa_flags = 0;
2557#ifdef SA_RESTART
0a8e0eff 2558#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS)
ff68c719 2559 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2560#endif
0a8e0eff 2561#endif
85264bed
CS		 2562#ifdef SA_NOCLDWAIT
2563 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2564 act.sa_flags |= SA_NOCLDWAIT;
2565#endif
ff68c719 2566 if (sigaction(signo, &act, &oact) == -1)
36477c24 2567 return SIG_ERR;
ff68c719 2568 else
36477c24 2569 return oact.sa_handler;
ff68c719 2570}
2571
2572Sighandler_t
864dbfa3 2573Perl_rsignal_state(pTHX_ int signo)
ff68c719 2574{
2575 struct sigaction oact;
2576
2577 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2578 return SIG_ERR;
2579 else
2580 return oact.sa_handler;
2581}
2582
2583int
864dbfa3 2584Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2585{
2586 struct sigaction act;
2587
2588 act.sa_handler = handler;
2589 sigemptyset(&act.sa_mask);
2590 act.sa_flags = 0;
2591#ifdef SA_RESTART
0a8e0eff 2592#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS)
ff68c719 2593 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2594#endif
0a8e0eff 2595#endif
85264bed
CS		 2596#ifdef SA_NOCLDWAIT
2597 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2598 act.sa_flags |= SA_NOCLDWAIT;
2599#endif
ff68c719 2600 return sigaction(signo, &act, save);
2601}
2602
2603int
864dbfa3 2604Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2605{
2606 return sigaction(signo, save, (struct sigaction *)NULL);
2607}
2608
2609#else /* !HAS_SIGACTION */
2610
2611Sighandler_t
864dbfa3 2612Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2613{
6ad3d225 2614 return PerlProc_signal(signo, handler);
ff68c719 2615}
2616
2617static int sig_trapped;
2618
2619static
2620Signal_t
4e35701f 2621sig_trap(int signo)
ff68c719 2622{
2623 sig_trapped++;
2624}
2625
2626Sighandler_t
864dbfa3 2627Perl_rsignal_state(pTHX_ int signo)
ff68c719 2628{
2629 Sighandler_t oldsig;
2630
2631 sig_trapped = 0;
6ad3d225
GS		 2632 oldsig = PerlProc_signal(signo, sig_trap);
2633 PerlProc_signal(signo, oldsig);
ff68c719 2634 if (sig_trapped)
7766f137 2635 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2636 return oldsig;
2637}
2638
2639int
864dbfa3 2640Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2641{
6ad3d225 2642 *save = PerlProc_signal(signo, handler);
ff68c719 2643 return (*save == SIG_ERR) ? -1 : 0;
2644}
2645
2646int
864dbfa3 2647Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2648{
6ad3d225 2649 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2650}
2651
2652#endif /* !HAS_SIGACTION */
64ca3a65 2653#endif /* !PERL_MICRO */
ff68c719 2654
5f05dabc 2655 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2656#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2657I32
864dbfa3 2658Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2659{
ff68c719 2660 Sigsave_t hstat, istat, qstat;
a687059c 2661 int status;
a0d0e21e 2662 SV **svp;
d8a83dd3
JH		 2663 Pid_t pid;
2664 Pid_t pid2;
03136e13
CS		 2665 bool close_failed;
2666 int saved_errno;
2667#ifdef VMS
2668 int saved_vaxc_errno;
2669#endif
22fae026
TM		 2670#ifdef WIN32
2671 int saved_win32_errno;
2672#endif
a687059c 2673
4755096e 2674 LOCK_FDPID_MUTEX;
3280af22 2675 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2676 UNLOCK_FDPID_MUTEX;
25d92023 2677 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2678 SvREFCNT_dec(*svp);
3280af22 2679 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2680#ifdef OS2
2681 if (pid == -1) { /* Opened by popen. */
2682 return my_syspclose(ptr);
2683 }
a1d180c4 2684#endif
03136e13
CS		 2685 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2686 saved_errno = errno;
2687#ifdef VMS
2688 saved_vaxc_errno = vaxc$errno;
2689#endif
22fae026
TM		 2690#ifdef WIN32
2691 saved_win32_errno = GetLastError();
2692#endif
03136e13 2693 }
7c0587c8 2694#ifdef UTS
6ad3d225 2695 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2696#endif
64ca3a65 2697#ifndef PERL_MICRO
ff68c719 2698 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2699 rsignal_save(SIGINT, SIG_IGN, &istat);
2700 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2701#endif
748a9306 2702 do {
1d3434b8
GS		 2703 pid2 = wait4pid(pid, &status, 0);
2704 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2705#ifndef PERL_MICRO
ff68c719 2706 rsignal_restore(SIGHUP, &hstat);
2707 rsignal_restore(SIGINT, &istat);
2708 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2709#endif
03136e13
CS		 2710 if (close_failed) {
2711 SETERRNO(saved_errno, saved_vaxc_errno);
2712 return -1;
2713 }
1d3434b8 2714 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2715}
4633a7c4
LW		 2716#endif /* !DOSISH */
2717
cd39f2b6 2718#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
79072805 2719I32
d8a83dd3 2720Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2721{
79072805
LW		 2722 SV *sv;
2723 SV** svp;
fc36a67e 2724 char spid[TYPE_CHARS(int)];
20188a90
LW		 2725
2726 if (!pid)
2727 return -1;
68a29c53 2728#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
20188a90 2729 if (pid > 0) {
7b0972df 2730 sprintf(spid, "%"IVdf, (IV)pid);
3280af22
NIS		 2731 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2732 if (svp && *svp != &PL_sv_undef) {
463ee0b2 2733 *statusp = SvIVX(*svp);
3280af22 2734 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW		 2735 return pid;
2736 }
2737 }
2738 else {
79072805 2739 HE *entry;
20188a90 2740
3280af22 2741 hv_iterinit(PL_pidstatus);
155aba94 2742 if ((entry = hv_iternext(PL_pidstatus))) {
a0d0e21e 2743 pid = atoi(hv_iterkey(entry,(I32*)statusp));
3280af22 2744 sv = hv_iterval(PL_pidstatus,entry);
463ee0b2 2745 *statusp = SvIVX(sv);
7b0972df 2746 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2747 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW		 2748 return pid;
2749 }
2750 }
68a29c53 2751#endif
79072805 2752#ifdef HAS_WAITPID
367f3c24
IZ		 2753# ifdef HAS_WAITPID_RUNTIME
2754 if (!HAS_WAITPID_RUNTIME)
2755 goto hard_way;
2756# endif
f55ee38a 2757 return PerlProc_waitpid(pid,statusp,flags);
367f3c24
IZ		 2758#endif
2759#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
a0d0e21e 2760 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
367f3c24
IZ		 2761#endif
2762#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2763 hard_way:
a0d0e21e
LW		 2764 {
2765 I32 result;
2766 if (flags)
cea2e8a9 2767 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2768 else {
76e3520e 2769 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2770 pidgone(result,*statusp);
2771 if (result < 0)
2772 *statusp = -1;
2773 }
2774 return result;
a687059c
LW		 2775 }
2776#endif
a687059c 2777}
2d7a9237 2778#endif /* !DOSISH || OS2 || WIN32 */
a687059c 2779
7c0587c8 2780void
de3bb511 2781/*SUPPRESS 590*/
d8a83dd3 2782Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2783{
79072805 2784 register SV *sv;
fc36a67e 2785 char spid[TYPE_CHARS(int)];
a687059c 2786
7b0972df 2787 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2788 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2789 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2790 SvIVX(sv) = status;
20188a90 2791 return;
a687059c
LW		 2792}
2793
55497cff 2794#if defined(atarist) || defined(OS2) || defined(DJGPP)
7c0587c8 2795int pclose();
ddcf38b7
IZ		 2796#ifdef HAS_FORK
2797int /* Cannot prototype with I32
2798 in os2ish.h. */
ba106d47 2799my_syspclose(PerlIO *ptr)
ddcf38b7 2800#else
79072805 2801I32
864dbfa3 2802Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2803#endif
a687059c 2804{
760ac839
LW		 2805 /* Needs work for PerlIO ! */
2806 FILE *f = PerlIO_findFILE(ptr);
2807 I32 result = pclose(f);
933fea7f
GS		 2808#if defined(DJGPP)
2809 result = (result << 8) & 0xff00;
2810#endif
760ac839
LW		 2811 PerlIO_releaseFILE(ptr,f);
2812 return result;
a687059c 2813}
7c0587c8 2814#endif
9f68db38
LW		 2815
2816void
864dbfa3 2817Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2818{
79072805 2819 register I32 todo;
08105a92 2820 register const char *frombase = from;
9f68db38
LW		 2821
2822 if (len == 1) {
08105a92 2823 register const char c = *from;
9f68db38 2824 while (count-- > 0)
5926133d 2825 *to++ = c;
9f68db38
LW		 2826 return;
2827 }
2828 while (count-- > 0) {
2829 for (todo = len; todo > 0; todo--) {
2830 *to++ = *from++;
2831 }
2832 from = frombase;
2833 }
2834}
0f85fab0 2835
463ee0b2 2836U32
65202027 2837Perl_cast_ulong(pTHX_ NV f)
0f85fab0
LW		 2838{
2839 long along;
2840
27e2fb84 2841#if CASTFLAGS & 2
34de22dd
LW		 2842# define BIGDOUBLE 2147483648.0
2843 if (f >= BIGDOUBLE)
2844 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
2845#endif
0f85fab0
LW		 2846 if (f >= 0.0)
2847 return (unsigned long)f;
2848 along = (long)f;
2849 return (unsigned long)along;
2850}
ed6116ce 2851# undef BIGDOUBLE
5d94fbed 2852
5d94fbed
AD		 2853/* Unfortunately, on some systems the cast_uv() function doesn't
2854 work with the system-supplied definition of ULONG_MAX. The
2855 comparison (f >= ULONG_MAX) always comes out true. It must be a
2856 problem with the compiler constant folding.
2857
2858 In any case, this workaround should be fine on any two's complement
2859 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2860 ccflags.
2861 --Andy Dougherty <doughera@lafcol.lafayette.edu>
2862*/
1eb770ff 2863
2864/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2865 of LONG_(MIN/MAX).
2866 -- Kenneth Albanowski <kjahds@kjahds.com>
a1d180c4 2867*/
1eb770ff 2868
20cec16a 2869#ifndef MY_UV_MAX
2870# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
5d94fbed
AD		 2871#endif
2872
ed6116ce 2873I32
65202027 2874Perl_cast_i32(pTHX_ NV f)
ed6116ce 2875{
20cec16a 2876 if (f >= I32_MAX)
2877 return (I32) I32_MAX;
2878 if (f <= I32_MIN)
2879 return (I32) I32_MIN;
ed6116ce
LW		 2880 return (I32) f;
2881}
a0d0e21e
LW		 2882
2883IV
65202027 2884Perl_cast_iv(pTHX_ NV f)
a0d0e21e 2885{
25da4f38
IZ		 2886 if (f >= IV_MAX) {
2887 UV uv;
2888
65202027 2889 if (f >= (NV)UV_MAX)
25da4f38
IZ		 2890 return (IV) UV_MAX;
2891 uv = (UV) f;
2892 return (IV)uv;
2893 }
20cec16a 2894 if (f <= IV_MIN)
2895 return (IV) IV_MIN;
a0d0e21e
LW		 2896 return (IV) f;
2897}
5d94fbed
AD		 2898
2899UV
65202027 2900Perl_cast_uv(pTHX_ NV f)
5d94fbed 2901{
20cec16a 2902 if (f >= MY_UV_MAX)
2903 return (UV) MY_UV_MAX;
25da4f38
IZ		 2904 if (f < 0) {
2905 IV iv;
2906
2907 if (f < IV_MIN)
2908 return (UV)IV_MIN;
2909 iv = (IV) f;
2910 return (UV) iv;
2911 }
5d94fbed
AD		 2912 return (UV) f;
2913}
2914
fe14fcc3 2915#ifndef HAS_RENAME
79072805 2916I32
864dbfa3 2917Perl_same_dirent(pTHX_ char *a, char *b)
62b28dd9 2918{
93a17b20
LW		 2919 char *fa = strrchr(a,'/');
2920 char *fb = strrchr(b,'/');
62b28dd9
LW		 2921 struct stat tmpstatbuf1;
2922 struct stat tmpstatbuf2;
46fc3d4c 2923 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2924
2925 if (fa)
2926 fa++;
2927 else
2928 fa = a;
2929 if (fb)
2930 fb++;
2931 else
2932 fb = b;
2933 if (strNE(a,b))
2934 return FALSE;
2935 if (fa == a)
46fc3d4c 2936 sv_setpv(tmpsv, ".");
62b28dd9 2937 else
46fc3d4c 2938 sv_setpvn(tmpsv, a, fa - a);
c6ed36e1 2939 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2940 return FALSE;
2941 if (fb == b)
46fc3d4c 2942 sv_setpv(tmpsv, ".");
62b28dd9 2943 else
46fc3d4c 2944 sv_setpvn(tmpsv, b, fb - b);
c6ed36e1 2945 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2946 return FALSE;
2947 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2948 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2949}
fe14fcc3
LW		 2950#endif /* !HAS_RENAME */
2951
9e24b6e2 2952NV
ba210ebe 2953Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
4f19785b
WSI		 2954{
2955 register char *s = start;
9e24b6e2
JH		 2956 register NV rnv = 0.0;
2957 register UV ruv = 0;
252aa082 2958 register bool seenb = FALSE;
9e24b6e2 2959 register bool overflowed = FALSE;
252aa082
JH		 2960
2961 for (; len-- && *s; s++) {
2962 if (!(*s == '0' || *s == '1')) {
b21ed0a9
GS		 2963 if (*s == '_' && len && *retlen
2964 && (s[1] == '0' || s[1] == '1'))
2965 {
2966 --len;
2967 ++s;
2968 }
2969 else if (seenb == FALSE && *s == 'b' && ruv == 0) {
252aa082
JH		 2970 /* Disallow 0bbb0b0bbb... */
2971 seenb = TRUE;
252aa082
JH		 2972 continue;
2973 }
2974 else {
627300f0
JH		 2975 if (ckWARN(WARN_DIGIT))
2976 Perl_warner(aTHX_ WARN_DIGIT,
252aa082
JH		 2977 "Illegal binary digit '%c' ignored", *s);
2978 break;
2979 }
9e24b6e2
JH		 2980 }
2981 if (!overflowed) {
2982 register UV xuv = ruv << 1;
2983
2984 if ((xuv >> 1) != ruv) {
9e24b6e2
JH		 2985 overflowed = TRUE;
2986 rnv = (NV) ruv;
627300f0
JH		 2987 if (ckWARN_d(WARN_OVERFLOW))
2988 Perl_warner(aTHX_ WARN_OVERFLOW,
9e24b6e2 2989 "Integer overflow in binary number");
b21ed0a9
GS		 2990 }
2991 else
9e24b6e2
JH		 2992 ruv = xuv | (*s - '0');
2993 }
2994 if (overflowed) {
2995 rnv *= 2;
2996 /* If an NV has not enough bits in its mantissa to
2997 * represent an UV this summing of small low-order numbers
2998 * is a waste of time (because the NV cannot preserve
2999 * the low-order bits anyway): we could just remember when
3000 * did we overflow and in the end just multiply rnv by the
2cc4c2dc 3001 * right amount. */
9e24b6e2 3002 rnv += (*s - '0');
f248d071 3003 }
4f19785b 3004 }
9e24b6e2
JH		 3005 if (!overflowed)
3006 rnv = (NV) ruv;
893fe2c2 3007 if ( ( overflowed && rnv > 4294967295.0)
15041a67 3008#if UVSIZE > 4
893fe2c2
JH		 3009 || (!overflowed && ruv > 0xffffffff )
3010#endif
a1d180c4 3011 ) {
627300f0
JH		 3012 if (ckWARN(WARN_PORTABLE))
3013 Perl_warner(aTHX_ WARN_PORTABLE,
252aa082 3014 "Binary number > 0b11111111111111111111111111111111 non-portable");
4f19785b
WSI		 3015 }
3016 *retlen = s - start;
9e24b6e2 3017 return rnv;
4f19785b 3018}
9e24b6e2
JH		 3019
3020NV
ba210ebe 3021Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
fe14fcc3
LW		 3022{
3023 register char *s = start;
9e24b6e2
JH		 3024 register NV rnv = 0.0;
3025 register UV ruv = 0;
3026 register bool overflowed = FALSE;
252aa082
JH		 3027
3028 for (; len-- && *s; s++) {
3029 if (!(*s >= '0' && *s <= '7')) {
b21ed0a9
GS		 3030 if (*s == '_' && len && *retlen
3031 && (s[1] >= '0' && s[1] <= '7'))
3032 {
3033 --len;
3034 ++s;
3035 }
252aa082 3036 else {
f84f607d
JH		 3037 /* Allow \octal to work the DWIM way (that is, stop scanning
3038 * as soon as non-octal characters are seen, complain only iff
3039 * someone seems to want to use the digits eight and nine). */
252aa082 3040 if (*s == '8' || *s == '9') {
627300f0
JH		 3041 if (ckWARN(WARN_DIGIT))
3042 Perl_warner(aTHX_ WARN_DIGIT,
252aa082
JH		 3043 "Illegal octal digit '%c' ignored", *s);
3044 }
3045 break;
3046 }
55497cff 3047 }
9e24b6e2 3048 if (!overflowed) {
893fe2c2 3049 register UV xuv = ruv << 3;
9e24b6e2
JH		 3050
3051 if ((xuv >> 3) != ruv) {
9e24b6e2
JH		 3052 overflowed = TRUE;
3053 rnv = (NV) ruv;
627300f0
JH		 3054 if (ckWARN_d(WARN_OVERFLOW))
3055 Perl_warner(aTHX_ WARN_OVERFLOW,
9e24b6e2 3056 "Integer overflow in octal number");
b21ed0a9
GS		 3057 }
3058 else
9e24b6e2
JH		 3059 ruv = xuv | (*s - '0');
3060 }
3061 if (overflowed) {
3062 rnv *= 8.0;
3063 /* If an NV has not enough bits in its mantissa to
3064 * represent an UV this summing of small low-order numbers
3065 * is a waste of time (because the NV cannot preserve
3066 * the low-order bits anyway): we could just remember when
3067 * did we overflow and in the end just multiply rnv by the
3068 * right amount of 8-tuples. */
3069 rnv += (NV)(*s - '0');
3070 }
fe14fcc3 3071 }
9e24b6e2
JH		 3072 if (!overflowed)
3073 rnv = (NV) ruv;
893fe2c2 3074 if ( ( overflowed && rnv > 4294967295.0)
15041a67 3075#if UVSIZE > 4
893fe2c2
JH		 3076 || (!overflowed && ruv > 0xffffffff )
3077#endif
3078 ) {
627300f0
JH		 3079 if (ckWARN(WARN_PORTABLE))
3080 Perl_warner(aTHX_ WARN_PORTABLE,
252aa082 3081 "Octal number > 037777777777 non-portable");
d008e5eb 3082 }
fe14fcc3 3083 *retlen = s - start;
9e24b6e2 3084 return rnv;
fe14fcc3
LW		 3085}
3086
9e24b6e2 3087NV
ba210ebe 3088Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
fe14fcc3
LW		 3089{
3090 register char *s = start;
9e24b6e2
JH		 3091 register NV rnv = 0.0;
3092 register UV ruv = 0;
9e24b6e2 3093 register bool overflowed = FALSE;
9e24b6e2 3094 char *hexdigit;
fe14fcc3 3095
cfd3e6cc
JH		 3096 if (len > 2) {
3097 if (s[0] == 'x') {
3098 s++;
3099 len--;
3100 }
3101 else if (len > 3 && s[0] == '0' && s[1] == 'x') {
3102 s+=2;
3103 len-=2;
3104 }
3105 }
3106
9e24b6e2
JH		 3107 for (; len-- && *s; s++) {
3108 hexdigit = strchr((char *) PL_hexdigit, *s);
3109 if (!hexdigit) {
b21ed0a9
GS		 3110 if (*s == '_' && len && *retlen && s[1]
3111 && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
3112 {
3113 --len;
3114 ++s;
3115 }
a0ed51b3 3116 else {
627300f0
JH		 3117 if (ckWARN(WARN_DIGIT))
3118 Perl_warner(aTHX_ WARN_DIGIT,
252aa082 3119 "Illegal hexadecimal digit '%c' ignored", *s);
a0ed51b3
LW		 3120 break;
3121 }
3122 }
9e24b6e2
JH		 3123 if (!overflowed) {
3124 register UV xuv = ruv << 4;
3125
3126 if ((xuv >> 4) != ruv) {
9e24b6e2
JH		 3127 overflowed = TRUE;
3128 rnv = (NV) ruv;
627300f0
JH		 3129 if (ckWARN_d(WARN_OVERFLOW))
3130 Perl_warner(aTHX_ WARN_OVERFLOW,
9e24b6e2 3131 "Integer overflow in hexadecimal number");
b21ed0a9
GS		 3132 }
3133 else
9e24b6e2
JH		 3134 ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
3135 }
3136 if (overflowed) {
3137 rnv *= 16.0;
3138 /* If an NV has not enough bits in its mantissa to
3139 * represent an UV this summing of small low-order numbers
3140 * is a waste of time (because the NV cannot preserve
3141 * the low-order bits anyway): we could just remember when
3142 * did we overflow and in the end just multiply rnv by the
3143 * right amount of 16-tuples. */
3144 rnv += (NV)((hexdigit - PL_hexdigit) & 15);
3145 }
6ff81951 3146 }
9e24b6e2
JH		 3147 if (!overflowed)
3148 rnv = (NV) ruv;
893fe2c2 3149 if ( ( overflowed && rnv > 4294967295.0)
15041a67 3150#if UVSIZE > 4
893fe2c2
JH		 3151 || (!overflowed && ruv > 0xffffffff )
3152#endif
a1d180c4 3153 ) {
627300f0
JH		 3154 if (ckWARN(WARN_PORTABLE))
3155 Perl_warner(aTHX_ WARN_PORTABLE,
252aa082
JH		 3156 "Hexadecimal number > 0xffffffff non-portable");
3157 }
fe14fcc3 3158 *retlen = s - start;
9e24b6e2 3159 return rnv;
fe14fcc3 3160}
760ac839 3161
491527d0 3162char*
864dbfa3 3163Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
491527d0 3164{
491527d0
GS		 3165 char *xfound = Nullch;
3166 char *xfailed = Nullch;
0f31cffe 3167 char tmpbuf[MAXPATHLEN];
491527d0
GS		 3168 register char *s;
3169 I32 len;
3170 int retval;
3171#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3172# define SEARCH_EXTS ".bat", ".cmd", NULL
3173# define MAX_EXT_LEN 4
3174#endif
3175#ifdef OS2
3176# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3177# define MAX_EXT_LEN 4
3178#endif
3179#ifdef VMS
3180# define SEARCH_EXTS ".pl", ".com", NULL
3181# define MAX_EXT_LEN 4
3182#endif
3183 /* additional extensions to try in each dir if scriptname not found */
3184#ifdef SEARCH_EXTS
3185 char *exts[] = { SEARCH_EXTS };
3186 char **ext = search_ext ? search_ext : exts;
3187 int extidx = 0, i = 0;
3188 char *curext = Nullch;
3189#else
3190# define MAX_EXT_LEN 0
3191#endif
3192
3193 /*
3194 * If dosearch is true and if scriptname does not contain path
3195 * delimiters, search the PATH for scriptname.
3196 *
3197 * If SEARCH_EXTS is also defined, will look for each
3198 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3199 * while searching the PATH.
3200 *
3201 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3202 * proceeds as follows:
3203 * If DOSISH or VMSISH:
3204 * + look for ./scriptname{,.foo,.bar}
3205 * + search the PATH for scriptname{,.foo,.bar}
3206 *
3207 * If !DOSISH:
3208 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3209 * this will not look in '.' if it's not in the PATH)
3210 */
84486fc6 3211 tmpbuf[0] = '\0';
491527d0
GS		 3212
3213#ifdef VMS
3214# ifdef ALWAYS_DEFTYPES
3215 len = strlen(scriptname);
3216 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3217 int hasdir, idx = 0, deftypes = 1;
3218 bool seen_dot = 1;
3219
3220 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
3221# else
3222 if (dosearch) {
3223 int hasdir, idx = 0, deftypes = 1;
3224 bool seen_dot = 1;
3225
3226 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
3227# endif
3228 /* The first time through, just add SEARCH_EXTS to whatever we
3229 * already have, so we can check for default file types. */
3230 while (deftypes ||
84486fc6 3231 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3232 {
3233 if (deftypes) {
3234 deftypes = 0;
84486fc6 3235 *tmpbuf = '\0';
491527d0 3236 }
84486fc6
GS		 3237 if ((strlen(tmpbuf) + strlen(scriptname)
3238 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3239 continue; /* don't search dir with too-long name */
84486fc6 3240 strcat(tmpbuf, scriptname);
491527d0
GS		 3241#else /* !VMS */
3242
3243#ifdef DOSISH
3244 if (strEQ(scriptname, "-"))
3245 dosearch = 0;
3246 if (dosearch) { /* Look in '.' first. */
3247 char *cur = scriptname;
3248#ifdef SEARCH_EXTS
3249 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3250 while (ext[i])
3251 if (strEQ(ext[i++],curext)) {
3252 extidx = -1; /* already has an ext */
3253 break;
3254 }
3255 do {
3256#endif
3257 DEBUG_p(PerlIO_printf(Perl_debug_log,
3258 "Looking for %s\n",cur));
017f25f1
IZ		 3259 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3260 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3261 dosearch = 0;
3262 scriptname = cur;
3263#ifdef SEARCH_EXTS
3264 break;
3265#endif
3266 }
3267#ifdef SEARCH_EXTS
3268 if (cur == scriptname) {
3269 len = strlen(scriptname);
84486fc6 3270 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3271 break;
84486fc6 3272 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 3273 }
3274 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 3275 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 3276#endif
3277 }
3278#endif
3279
cd39f2b6
JH		 3280#ifdef MACOS_TRADITIONAL
3281 if (dosearch && !strchr(scriptname, ':') &&
3282 (s = PerlEnv_getenv("Commands")))
3283#else
491527d0
GS		 3284 if (dosearch && !strchr(scriptname, '/')
3285#ifdef DOSISH
3286 && !strchr(scriptname, '\\')
3287#endif
cd39f2b6
JH		 3288 && (s = PerlEnv_getenv("PATH")))
3289#endif
3290 {
491527d0
GS		 3291 bool seen_dot = 0;
3292
3280af22
NIS		 3293 PL_bufend = s + strlen(s);
3294 while (s < PL_bufend) {
cd39f2b6
JH		 3295#ifdef MACOS_TRADITIONAL
3296 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3297 ',',
3298 &len);
3299#else
491527d0
GS		 3300#if defined(atarist) || defined(DOSISH)
3301 for (len = 0; *s
3302# ifdef atarist
3303 && *s != ','
3304# endif
3305 && *s != ';'; len++, s++) {
84486fc6
GS		 3306 if (len < sizeof tmpbuf)
3307 tmpbuf[len] = *s;
491527d0 3308 }
84486fc6
GS		 3309 if (len < sizeof tmpbuf)
3310 tmpbuf[len] = '\0';
491527d0 3311#else /* ! (atarist || DOSISH) */
3280af22 3312 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 3313 ':',
3314 &len);
3315#endif /* ! (atarist || DOSISH) */
cd39f2b6 3316#endif /* MACOS_TRADITIONAL */
3280af22 3317 if (s < PL_bufend)
491527d0 3318 s++;
84486fc6 3319 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 3320 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 3321#ifdef MACOS_TRADITIONAL
3322 if (len && tmpbuf[len - 1] != ':')
3323 tmpbuf[len++] = ':';
3324#else
491527d0 3325 if (len
61ae2fbf 3326#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 3327 && tmpbuf[len - 1] != '/'
3328 && tmpbuf[len - 1] != '\\'
491527d0
GS		 3329#endif
3330 )
84486fc6
GS		 3331 tmpbuf[len++] = '/';
3332 if (len == 2 && tmpbuf[0] == '.')
491527d0 3333 seen_dot = 1;
cd39f2b6 3334#endif
84486fc6 3335 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 3336#endif /* !VMS */
3337
3338#ifdef SEARCH_EXTS
84486fc6 3339 len = strlen(tmpbuf);
491527d0
GS		 3340 if (extidx > 0) /* reset after previous loop */
3341 extidx = 0;
3342 do {
3343#endif
84486fc6 3344 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3345 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3346 if (S_ISDIR(PL_statbuf.st_mode)) {
3347 retval = -1;
3348 }
491527d0
GS		 3349#ifdef SEARCH_EXTS
3350 } while ( retval < 0 /* not there */
3351 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 3352 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 3353 );
3354#endif
3355 if (retval < 0)
3356 continue;
3280af22
NIS		 3357 if (S_ISREG(PL_statbuf.st_mode)
3358 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 3359#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 3360 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3361#endif
3362 )
3363 {
84486fc6 3364 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3365 break;
3366 }
3367 if (!xfailed)
84486fc6 3368 xfailed = savepv(tmpbuf);
491527d0
GS		 3369 }
3370#ifndef DOSISH
017f25f1 3371 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3372 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3373 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3374#endif
3375 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3376 if (!xfound) {
3377 if (flags & 1) { /* do or die? */
cea2e8a9 3378 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3379 (xfailed ? "execute" : "find"),
3380 (xfailed ? xfailed : scriptname),
3381 (xfailed ? "" : " on PATH"),
3382 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3383 }
3384 scriptname = Nullch;
3385 }
491527d0
GS		 3386 if (xfailed)
3387 Safefree(xfailed);
3388 scriptname = xfound;
3389 }
9ccb31f9 3390 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 3391}
3392
ba869deb
GS		 3393#ifndef PERL_GET_CONTEXT_DEFINED
3394
3395void *
3396Perl_get_context(void)
3397{
3398#if defined(USE_THREADS) || defined(USE_ITHREADS)
3399# ifdef OLD_PTHREADS_API
3400 pthread_addr_t t;
3401 if (pthread_getspecific(PL_thr_key, &t))
3402 Perl_croak_nocontext("panic: pthread_getspecific");
3403 return (void*)t;
3404# else
c44d3fdb
GS		 3405# ifdef I_MACH_CTHREADS
3406 return (void*)cthread_data(cthread_self());
3407# else
ba869deb
GS		 3408 return (void*)pthread_getspecific(PL_thr_key);
3409# endif
c44d3fdb 3410# endif
ba869deb
GS		 3411#else
3412 return (void*)NULL;
3413#endif
3414}
3415
3416void
3417Perl_set_context(void *t)
3418{
3419#if defined(USE_THREADS) || defined(USE_ITHREADS)
c44d3fdb
GS		 3420# ifdef I_MACH_CTHREADS
3421 cthread_set_data(cthread_self(), t);
3422# else
ba869deb
GS		 3423 if (pthread_setspecific(PL_thr_key, t))
3424 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3425# endif
ba869deb
GS		 3426#endif
3427}
3428
3429#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3430
11343788 3431#ifdef USE_THREADS
ba869deb 3432
12ca11f6
MB		 3433#ifdef FAKE_THREADS
3434/* Very simplistic scheduler for now */
3435void
3436schedule(void)
3437{
c7848ba1 3438 thr = thr->i.next_run;
12ca11f6
MB		 3439}
3440
3441void
864dbfa3 3442Perl_cond_init(pTHX_ perl_cond *cp)
12ca11f6
MB		 3443{
3444 *cp = 0;
3445}
3446
3447void
864dbfa3 3448Perl_cond_signal(pTHX_ perl_cond *cp)
12ca11f6 3449{
51dd5992 3450 perl_os_thread t;
12ca11f6 3451 perl_cond cond = *cp;
a1d180c4 3452
12ca11f6
MB		 3453 if (!cond)
3454 return;
3455 t = cond->thread;
3456 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB		 3457 t->i.next_run = thr->i.next_run;
3458 thr->i.next_run->i.prev_run = t;
3459 t->i.prev_run = thr;
3460 thr->i.next_run = t;
3461 thr->i.wait_queue = 0;
12ca11f6
MB		 3462 /* Remove from the wait queue */
3463 *cp = cond->next;
3464 Safefree(cond);
3465}
3466
3467void
864dbfa3 3468Perl_cond_broadcast(pTHX_ perl_cond *cp)
12ca11f6 3469{
51dd5992 3470 perl_os_thread t;
12ca11f6 3471 perl_cond cond, cond_next;
a1d180c4 3472
12ca11f6
MB		 3473 for (cond = *cp; cond; cond = cond_next) {
3474 t = cond->thread;
3475 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB		 3476 t->i.next_run = thr->i.next_run;
3477 thr->i.next_run->i.prev_run = t;
3478 t->i.prev_run = thr;
3479 thr->i.next_run = t;
3480 thr->i.wait_queue = 0;
12ca11f6
MB		 3481 /* Remove from the wait queue */
3482 cond_next = cond->next;
3483 Safefree(cond);
3484 }
3485 *cp = 0;
3486}
3487
3488void
864dbfa3 3489Perl_cond_wait(pTHX_ perl_cond *cp)
12ca11f6
MB		 3490{
3491 perl_cond cond;
3492
c7848ba1 3493 if (thr->i.next_run == thr)
cea2e8a9 3494 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
a1d180c4 3495
0f15f207 3496 New(666, cond, 1, struct perl_wait_queue);
12ca11f6
MB		 3497 cond->thread = thr;
3498 cond->next = *cp;
3499 *cp = cond;
c7848ba1 3500 thr->i.wait_queue = cond;
12ca11f6 3501 /* Remove ourselves from runnable queue */
c7848ba1
MB		 3502 thr->i.next_run->i.prev_run = thr->i.prev_run;
3503 thr->i.prev_run->i.next_run = thr->i.next_run;
12ca11f6
MB		 3504}
3505#endif /* FAKE_THREADS */
3506
f93b4edd 3507MAGIC *
864dbfa3 3508Perl_condpair_magic(pTHX_ SV *sv)
f93b4edd
MB		 3509{
3510 MAGIC *mg;
a1d180c4 3511
f93b4edd
MB		 3512 SvUPGRADE(sv, SVt_PVMG);
3513 mg = mg_find(sv, 'm');
3514 if (!mg) {
3515 condpair_t *cp;
3516
3517 New(53, cp, 1, condpair_t);
3518 MUTEX_INIT(&cp->mutex);
3519 COND_INIT(&cp->owner_cond);
3520 COND_INIT(&cp->cond);
3521 cp->owner = 0;
1feb2720 3522 LOCK_CRED_MUTEX; /* XXX need separate mutex? */
f93b4edd
MB		 3523 mg = mg_find(sv, 'm');
3524 if (mg) {
3525 /* someone else beat us to initialising it */
1feb2720 3526 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
f93b4edd
MB		 3527 MUTEX_DESTROY(&cp->mutex);
3528 COND_DESTROY(&cp->owner_cond);
3529 COND_DESTROY(&cp->cond);
3530 Safefree(cp);
3531 }
3532 else {
3533 sv_magic(sv, Nullsv, 'm', 0, 0);
3534 mg = SvMAGIC(sv);
3535 mg->mg_ptr = (char *)cp;
565764a8 3536 mg->mg_len = sizeof(cp);
1feb2720 3537 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
bf49b057 3538 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
c7848ba1 3539 "%p: condpair_magic %p\n", thr, sv));)
f93b4edd
MB		 3540 }
3541 }
3542 return mg;
3543}
a863c7d1 3544
3d35f11b 3545SV *
4755096e 3546Perl_sv_lock(pTHX_ SV *osv)
3d35f11b
GS		 3547{
3548 MAGIC *mg;
3549 SV *sv = osv;
3550
631cfb58 3551 LOCK_SV_LOCK_MUTEX;
3d35f11b
GS		 3552 if (SvROK(sv)) {
3553 sv = SvRV(sv);
3d35f11b
GS		 3554 }
3555
3556 mg = condpair_magic(sv);
3557 MUTEX_LOCK(MgMUTEXP(mg));
3558 if (MgOWNER(mg) == thr)
3559 MUTEX_UNLOCK(MgMUTEXP(mg));
4755096e 3560 else {
3d35f11b
GS		 3561 while (MgOWNER(mg))
3562 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3563 MgOWNER(mg) = thr;
4755096e
GS		 3564 DEBUG_S(PerlIO_printf(Perl_debug_log,
3565 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3d35f11b
GS		 3566 PTR2UV(thr), PTR2UV(sv));)
3567 MUTEX_UNLOCK(MgMUTEXP(mg));
3568 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3569 }
631cfb58 3570 UNLOCK_SV_LOCK_MUTEX;
4755096e 3571 return sv;
3d35f11b
GS		 3572}
3573
a863c7d1 3574/*
199100c8
MB		 3575 * Make a new perl thread structure using t as a prototype. Some of the
3576 * fields for the new thread are copied from the prototype thread, t,
3577 * so t should not be running in perl at the time this function is
3578 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3579 * thread calling new_struct_thread) clearly satisfies this constraint.
a863c7d1 3580 */
52e1cb5e 3581struct perl_thread *
864dbfa3 3582Perl_new_struct_thread(pTHX_ struct perl_thread *t)
a863c7d1 3583{
c5be433b 3584#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3585 struct perl_thread *thr;
cea2e8a9 3586#endif
a863c7d1 3587 SV *sv;
199100c8
MB		 3588 SV **svp;
3589 I32 i;
3590