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