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