This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
More Chip patches (tweaked for _5x). The final one mentioned here
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
9607fc9c 3 * Copyright (c) 1991-1997, 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"
8d063cd8 16#include "perl.h"
31da6858 17#include "perlmem.h"
62b28dd9 18
6eb13c3b 19#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
a687059c 20#include <signal.h>
62b28dd9 21#endif
a687059c 22
36477c24
PP
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
fe14fcc3
LW
43#ifdef I_FCNTL
44# include <fcntl.h>
45#endif
46#ifdef I_SYS_FILE
47# include <sys/file.h>
48#endif
49
ff68c719
PP
50#ifdef I_SYS_WAIT
51# include <sys/wait.h>
52#endif
53
8d063cd8 54#define FLUSH
8d063cd8 55
a0d0e21e
LW
56#ifdef LEAKTEST
57static void xstat _((void));
58#endif
59
55497cff 60#ifndef MYMALLOC
de3bb511 61
8d063cd8
LW
62/* paranoid version of malloc */
63
a687059c
LW
64/* NOTE: Do not call the next three routines directly. Use the macros
65 * in handy.h, so that we can easily redefine everything to do tracking of
66 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 67 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW
68 */
69
bd4080b3 70Malloc_t
f0f333f4 71safemalloc(MEM_SIZE size)
8d063cd8 72{
bd4080b3 73 Malloc_t ptr;
55497cff 74#ifdef HAS_64K_LIMIT
62b28dd9 75 if (size > 0xffff) {
760ac839 76 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
79072805 77 my_exit(1);
62b28dd9 78 }
55497cff 79#endif /* HAS_64K_LIMIT */
34de22dd
LW
80#ifdef DEBUGGING
81 if ((long)size < 0)
463ee0b2 82 croak("panic: malloc");
34de22dd 83#endif
3028581b 84 ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
79072805 85#if !(defined(I286) || defined(atarist))
760ac839 86 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
79072805 87#else
760ac839 88 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
8d063cd8
LW
89#endif
90 if (ptr != Nullch)
91 return ptr;
7c0587c8
LW
92 else if (nomemok)
93 return Nullch;
8d063cd8 94 else {
760ac839 95 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
79072805 96 my_exit(1);
4e35701f 97 return Nullch;
8d063cd8
LW
98 }
99 /*NOTREACHED*/
100}
101
102/* paranoid version of realloc */
103
bd4080b3 104Malloc_t
f0f333f4 105saferealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 106{
bd4080b3 107 Malloc_t ptr;
ecfc5424 108#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
3028581b 109 Malloc_t PerlMem_realloc();
ecfc5424 110#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 111
55497cff 112#ifdef HAS_64K_LIMIT
5f05dabc
PP
113 if (size > 0xffff) {
114 PerlIO_printf(PerlIO_stderr(),
115 "Reallocation too large: %lx\n", size) FLUSH;
116 my_exit(1);
117 }
55497cff 118#endif /* HAS_64K_LIMIT */
378cc40b 119 if (!where)
463ee0b2 120 croak("Null realloc");
34de22dd
LW
121#ifdef DEBUGGING
122 if ((long)size < 0)
463ee0b2 123 croak("panic: realloc");
34de22dd 124#endif
3028581b 125 ptr = PerlMem_realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
79072805
LW
126
127#if !(defined(I286) || defined(atarist))
128 DEBUG_m( {
760ac839
LW
129 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++);
130 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
79072805
LW
131 } )
132#else
133 DEBUG_m( {
760ac839
LW
134 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++);
135 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
79072805 136 } )
8d063cd8 137#endif
79072805 138
8d063cd8
LW
139 if (ptr != Nullch)
140 return ptr;
7c0587c8
LW
141 else if (nomemok)
142 return Nullch;
8d063cd8 143 else {
760ac839 144 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
79072805 145 my_exit(1);
4e35701f 146 return Nullch;
8d063cd8
LW
147 }
148 /*NOTREACHED*/
149}
150
151/* safe version of free */
152
54310121 153Free_t
f0f333f4 154safefree(Malloc_t where)
8d063cd8 155{
79072805 156#if !(defined(I286) || defined(atarist))
f0f333f4 157 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,an++));
79072805 158#else
f0f333f4 159 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,an++));
8d063cd8 160#endif
378cc40b 161 if (where) {
de3bb511 162 /*SUPPRESS 701*/
3028581b 163 PerlMem_free(where);
378cc40b 164 }
8d063cd8
LW
165}
166
1050c9ca
PP
167/* safe version of calloc */
168
bd4080b3 169Malloc_t
f0f333f4 170safecalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 171{
bd4080b3 172 Malloc_t ptr;
1050c9ca 173
55497cff 174#ifdef HAS_64K_LIMIT
5f05dabc
PP
175 if (size * count > 0xffff) {
176 PerlIO_printf(PerlIO_stderr(),
177 "Allocation too large: %lx\n", size * count) FLUSH;
178 my_exit(1);
179 }
55497cff 180#endif /* HAS_64K_LIMIT */
1050c9ca
PP
181#ifdef DEBUGGING
182 if ((long)size < 0 || (long)count < 0)
183 croak("panic: calloc");
184#endif
0b7c1c42 185 size *= count;
3028581b 186 ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
1050c9ca 187#if !(defined(I286) || defined(atarist))
fb73857a 188 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
1050c9ca 189#else
fb73857a 190 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
1050c9ca 191#endif
1050c9ca
PP
192 if (ptr != Nullch) {
193 memset((void*)ptr, 0, size);
194 return ptr;
195 }
196 else if (nomemok)
197 return Nullch;
198 else {
760ac839 199 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
1050c9ca 200 my_exit(1);
4e35701f 201 return Nullch;
1050c9ca
PP
202 }
203 /*NOTREACHED*/
204}
205
55497cff 206#endif /* !MYMALLOC */
de3bb511 207
a687059c
LW
208#ifdef LEAKTEST
209
210#define ALIGN sizeof(long)
8d063cd8 211
bd4080b3 212Malloc_t
f0f333f4 213safexmalloc(I32 x, MEM_SIZE size)
8d063cd8 214{
bd4080b3 215 register Malloc_t where;
8d063cd8 216
a687059c
LW
217 where = safemalloc(size + ALIGN);
218 xcount[x]++;
219 where[0] = x % 100;
220 where[1] = x / 100;
221 return where + ALIGN;
8d063cd8 222}
8d063cd8 223
bd4080b3 224Malloc_t
f0f333f4 225safexrealloc(Malloc_t where, MEM_SIZE size)
a687059c 226{
bd4080b3 227 register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
a0d0e21e 228 return new + ALIGN;
a687059c
LW
229}
230
231void
f0f333f4 232safexfree(Malloc_t where)
a687059c 233{
79072805 234 I32 x;
a687059c
LW
235
236 if (!where)
237 return;
238 where -= ALIGN;
239 x = where[0] + 100 * where[1];
240 xcount[x]--;
241 safefree(where);
242}
243
bd4080b3 244Malloc_t
f0f333f4 245safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
1050c9ca 246{
bd4080b3 247 register Malloc_t where;
1050c9ca
PP
248
249 where = safexmalloc(x, size * count + ALIGN);
250 xcount[x]++;
251 memset((void*)where + ALIGN, 0, size * count);
252 where[0] = x % 100;
253 where[1] = x / 100;
254 return where + ALIGN;
255}
256
7c0587c8 257static void
f0f333f4 258xstat(void)
8d063cd8 259{
79072805 260 register I32 i;
8d063cd8 261
a687059c 262 for (i = 0; i < MAXXCOUNT; i++) {
de3bb511 263 if (xcount[i] > lastxcount[i]) {
760ac839 264 PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
a687059c 265 lastxcount[i] = xcount[i];
8d063cd8
LW
266 }
267 }
8d063cd8 268}
a687059c
LW
269
270#endif /* LEAKTEST */
8d063cd8
LW
271
272/* copy a string up to some (non-backslashed) delimiter, if any */
273
274char *
8ac85365 275delimcpy(register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
8d063cd8 276{
fc36a67e
PP
277 register I32 tolen;
278 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b
LW
279 if (*from == '\\') {
280 if (from[1] == delim)
281 from++;
fc36a67e
PP
282 else {
283 if (to < toend)
284 *to++ = *from;
285 tolen++;
286 from++;
287 }
378cc40b 288 }
bedebaa5 289 else if (*from == delim)
8d063cd8 290 break;
fc36a67e
PP
291 if (to < toend)
292 *to++ = *from;
8d063cd8 293 }
bedebaa5
CS
294 if (to < toend)
295 *to = '\0';
fc36a67e 296 *retlen = tolen;
8d063cd8
LW
297 return from;
298}
299
300/* return ptr to little string in big string, NULL if not found */
378cc40b 301/* This routine was donated by Corey Satten. */
8d063cd8
LW
302
303char *
8ac85365 304instr(register char *big, register char *little)
378cc40b
LW
305{
306 register char *s, *x;
79072805 307 register I32 first;
378cc40b 308
a687059c
LW
309 if (!little)
310 return big;
311 first = *little++;
378cc40b
LW
312 if (!first)
313 return big;
314 while (*big) {
315 if (*big++ != first)
316 continue;
317 for (x=big,s=little; *s; /**/ ) {
318 if (!*x)
319 return Nullch;
320 if (*s++ != *x++) {
321 s--;
322 break;
323 }
324 }
325 if (!*s)
326 return big-1;
327 }
328 return Nullch;
329}
8d063cd8 330
a687059c
LW
331/* same as instr but allow embedded nulls */
332
333char *
8ac85365 334ninstr(register char *big, register char *bigend, char *little, char *lend)
8d063cd8 335{
a687059c 336 register char *s, *x;
79072805 337 register I32 first = *little;
a687059c 338 register char *littleend = lend;
378cc40b 339
a0d0e21e 340 if (!first && little >= littleend)
a687059c 341 return big;
de3bb511
LW
342 if (bigend - big < littleend - little)
343 return Nullch;
a687059c
LW
344 bigend -= littleend - little++;
345 while (big <= bigend) {
346 if (*big++ != first)
347 continue;
348 for (x=big,s=little; s < littleend; /**/ ) {
349 if (*s++ != *x++) {
350 s--;
351 break;
352 }
353 }
354 if (s >= littleend)
355 return big-1;
378cc40b 356 }
a687059c
LW
357 return Nullch;
358}
359
360/* reverse of the above--find last substring */
361
362char *
8ac85365 363rninstr(register char *big, char *bigend, char *little, char *lend)
a687059c
LW
364{
365 register char *bigbeg;
366 register char *s, *x;
79072805 367 register I32 first = *little;
a687059c
LW
368 register char *littleend = lend;
369
a0d0e21e 370 if (!first && little >= littleend)
a687059c
LW
371 return bigend;
372 bigbeg = big;
373 big = bigend - (littleend - little++);
374 while (big >= bigbeg) {
375 if (*big-- != first)
376 continue;
377 for (x=big+2,s=little; s < littleend; /**/ ) {
378 if (*s++ != *x++) {
379 s--;
380 break;
381 }
382 }
383 if (s >= littleend)
384 return big+1;
378cc40b 385 }
a687059c 386 return Nullch;
378cc40b 387}
a687059c 388
bbce6d69
PP
389/*
390 * Set up for a new ctype locale.
391 */
55497cff 392void
8ac85365 393perl_new_ctype(char *newctype)
ef7eada9 394{
36477c24
PP
395#ifdef USE_LOCALE_CTYPE
396
bbce6d69 397 int i;
ef7eada9 398
bbce6d69
PP
399 for (i = 0; i < 256; i++) {
400 if (isUPPER_LC(i))
401 fold_locale[i] = toLOWER_LC(i);
402 else if (isLOWER_LC(i))
403 fold_locale[i] = toUPPER_LC(i);
404 else
405 fold_locale[i] = i;
406 }
bbce6d69 407
36477c24
PP
408#endif /* USE_LOCALE_CTYPE */
409}
bbce6d69
PP
410
411/*
412 * Set up for a new collation locale.
413 */
414void
8ac85365 415perl_new_collate(char *newcoll)
bbce6d69 416{
36477c24
PP
417#ifdef USE_LOCALE_COLLATE
418
bbce6d69
PP
419 if (! newcoll) {
420 if (collation_name) {
421 ++collation_ix;
422 Safefree(collation_name);
423 collation_name = NULL;
424 collation_standard = TRUE;
bbce6d69
PP
425 collxfrm_base = 0;
426 collxfrm_mult = 2;
bbce6d69
PP
427 }
428 return;
429 }
430
431 if (! collation_name || strNE(collation_name, newcoll)) {
432 ++collation_ix;
433 Safefree(collation_name);
434 collation_name = savepv(newcoll);
ff68c719 435 collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
bbce6d69 436
bbce6d69
PP
437 {
438 /* 2: at most so many chars ('a', 'b'). */
439 /* 50: surely no system expands a char more. */
440#define XFRMBUFSIZE (2 * 50)
441 char xbuf[XFRMBUFSIZE];
442 Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
443 Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
444 SSize_t mult = fb - fa;
445 if (mult < 1)
446 croak("strxfrm() gets absurd");
447 collxfrm_base = (fa > mult) ? (fa - mult) : 0;
448 collxfrm_mult = mult;
449 }
bbce6d69 450 }
bbce6d69 451
36477c24
PP
452#endif /* USE_LOCALE_COLLATE */
453}
bbce6d69
PP
454
455/*
456 * Set up for a new numeric locale.
457 */
458void
8ac85365 459perl_new_numeric(char *newnum)
bbce6d69 460{
36477c24
PP
461#ifdef USE_LOCALE_NUMERIC
462
bbce6d69
PP
463 if (! newnum) {
464 if (numeric_name) {
465 Safefree(numeric_name);
466 numeric_name = NULL;
467 numeric_standard = TRUE;
468 numeric_local = TRUE;
469 }
470 return;
471 }
472
473 if (! numeric_name || strNE(numeric_name, newnum)) {
474 Safefree(numeric_name);
475 numeric_name = savepv(newnum);
ff68c719 476 numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
bbce6d69
PP
477 numeric_local = TRUE;
478 }
36477c24
PP
479
480#endif /* USE_LOCALE_NUMERIC */
bbce6d69
PP
481}
482
483void
8ac85365 484perl_set_numeric_standard(void)
bbce6d69 485{
5f05dabc
PP
486#ifdef USE_LOCALE_NUMERIC
487
bbce6d69
PP
488 if (! numeric_standard) {
489 setlocale(LC_NUMERIC, "C");
490 numeric_standard = TRUE;
491 numeric_local = FALSE;
492 }
5f05dabc
PP
493
494#endif /* USE_LOCALE_NUMERIC */
bbce6d69
PP
495}
496
497void
8ac85365 498perl_set_numeric_local(void)
bbce6d69 499{
5f05dabc
PP
500#ifdef USE_LOCALE_NUMERIC
501
bbce6d69
PP
502 if (! numeric_local) {
503 setlocale(LC_NUMERIC, numeric_name);
504 numeric_standard = FALSE;
505 numeric_local = TRUE;
506 }
bbce6d69 507
36477c24 508#endif /* USE_LOCALE_NUMERIC */
5f05dabc 509}
36477c24 510
bbce6d69 511
36477c24
PP
512/*
513 * Initialize locale awareness.
514 */
f0c5b223 515int
8ac85365 516perl_init_i18nl10n(int printwarn)
f0c5b223
TB
517{
518 int ok = 1;
519 /* returns
520 * 1 = set ok or not applicable,
521 * 0 = fallback to C locale,
522 * -1 = fallback to C locale failed
523 */
bbce6d69 524
36477c24 525#ifdef USE_LOCALE
bbce6d69 526
36477c24 527#ifdef USE_LOCALE_CTYPE
bbce6d69 528 char *curctype = NULL;
36477c24
PP
529#endif /* USE_LOCALE_CTYPE */
530#ifdef USE_LOCALE_COLLATE
bbce6d69 531 char *curcoll = NULL;
36477c24
PP
532#endif /* USE_LOCALE_COLLATE */
533#ifdef USE_LOCALE_NUMERIC
bbce6d69 534 char *curnum = NULL;
36477c24 535#endif /* USE_LOCALE_NUMERIC */
5fd9e9a4
GS
536 char *lc_all = PerlEnv_getenv("LC_ALL");
537 char *lang = PerlEnv_getenv("LANG");
bbce6d69 538 bool setlocale_failure = FALSE;
f0c5b223 539
02b32252
CS
540#ifdef LOCALE_ENVIRON_REQUIRED
541
542 /*
543 * Ultrix setlocale(..., "") fails if there are no environment
544 * variables from which to get a locale name.
545 */
546
547 bool done = FALSE;
548
549#ifdef LC_ALL
550 if (lang) {
551 if (setlocale(LC_ALL, ""))
552 done = TRUE;
553 else
554 setlocale_failure = TRUE;
555 }
556 if (!setlocale_failure)
557#endif /* LC_ALL */
558 {
559#ifdef USE_LOCALE_CTYPE
560 if (! (curctype = setlocale(LC_CTYPE,
5fd9e9a4 561 (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
02b32252
CS
562 ? "" : Nullch)))
563 setlocale_failure = TRUE;
564#endif /* USE_LOCALE_CTYPE */
565#ifdef USE_LOCALE_COLLATE
566 if (! (curcoll = setlocale(LC_COLLATE,
5fd9e9a4 567 (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
02b32252
CS
568 ? "" : Nullch)))
569 setlocale_failure = TRUE;
570#endif /* USE_LOCALE_COLLATE */
571#ifdef USE_LOCALE_NUMERIC
572 if (! (curnum = setlocale(LC_NUMERIC,
5fd9e9a4 573 (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
02b32252
CS
574 ? "" : Nullch)))
575 setlocale_failure = TRUE;
576#endif /* USE_LOCALE_NUMERIC */
577 }
578
579#else /* !LOCALE_ENVIRON_REQUIRED */
580
bbce6d69 581#ifdef LC_ALL
5f05dabc 582
bbce6d69
PP
583 if (! setlocale(LC_ALL, ""))
584 setlocale_failure = TRUE;
5f05dabc
PP
585 else {
586#ifdef USE_LOCALE_CTYPE
587 curctype = setlocale(LC_CTYPE, Nullch);
588#endif /* USE_LOCALE_CTYPE */
589#ifdef USE_LOCALE_COLLATE
590 curcoll = setlocale(LC_COLLATE, Nullch);
591#endif /* USE_LOCALE_COLLATE */
592#ifdef USE_LOCALE_NUMERIC
593 curnum = setlocale(LC_NUMERIC, Nullch);
594#endif /* USE_LOCALE_NUMERIC */
595 }
596
597#else /* !LC_ALL */
bbce6d69 598
36477c24 599#ifdef USE_LOCALE_CTYPE
5f05dabc 600 if (! (curctype = setlocale(LC_CTYPE, "")))
bbce6d69 601 setlocale_failure = TRUE;
36477c24
PP
602#endif /* USE_LOCALE_CTYPE */
603#ifdef USE_LOCALE_COLLATE
5f05dabc 604 if (! (curcoll = setlocale(LC_COLLATE, "")))
bbce6d69 605 setlocale_failure = TRUE;
36477c24
PP
606#endif /* USE_LOCALE_COLLATE */
607#ifdef USE_LOCALE_NUMERIC
5f05dabc 608 if (! (curnum = setlocale(LC_NUMERIC, "")))
bbce6d69 609 setlocale_failure = TRUE;
36477c24 610#endif /* USE_LOCALE_NUMERIC */
bbce6d69 611
5f05dabc
PP
612#endif /* LC_ALL */
613
02b32252
CS
614#endif /* !LOCALE_ENVIRON_REQUIRED */
615
5f05dabc
PP
616 if (setlocale_failure) {
617 char *p;
618 bool locwarn = (printwarn > 1 ||
619 printwarn &&
5fd9e9a4 620 (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
20cec16a 621
5f05dabc
PP
622 if (locwarn) {
623#ifdef LC_ALL
624
625 PerlIO_printf(PerlIO_stderr(),
626 "perl: warning: Setting locale failed.\n");
627
628#else /* !LC_ALL */
629
ef7eada9 630 PerlIO_printf(PerlIO_stderr(),
bbce6d69 631 "perl: warning: Setting locale failed for the categories:\n\t");
36477c24 632#ifdef USE_LOCALE_CTYPE
bbce6d69 633 if (! curctype)
5f05dabc 634 PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
36477c24
PP
635#endif /* USE_LOCALE_CTYPE */
636#ifdef USE_LOCALE_COLLATE
bbce6d69 637 if (! curcoll)
5f05dabc 638 PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
36477c24
PP
639#endif /* USE_LOCALE_COLLATE */
640#ifdef USE_LOCALE_NUMERIC
bbce6d69 641 if (! curnum)
5f05dabc 642 PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC ");
36477c24 643#endif /* USE_LOCALE_NUMERIC */
bbce6d69
PP
644 PerlIO_printf(PerlIO_stderr(), "\n");
645
5f05dabc
PP
646#endif /* LC_ALL */
647
760ac839 648 PerlIO_printf(PerlIO_stderr(),
bbce6d69 649 "perl: warning: Please check that your locale settings:\n");
ef7eada9
JH
650
651 PerlIO_printf(PerlIO_stderr(),
bbce6d69
PP
652 "\tLC_ALL = %c%s%c,\n",
653 lc_all ? '"' : '(',
654 lc_all ? lc_all : "unset",
655 lc_all ? '"' : ')');
5f05dabc
PP
656
657 {
658 char **e;
659 for (e = environ; *e; e++) {
660 if (strnEQ(*e, "LC_", 3)
661 && strnNE(*e, "LC_ALL=", 7)
662 && (p = strchr(*e, '=')))
663 PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n",
fb73857a 664 (int)(p - *e), *e, p + 1);
5f05dabc
PP
665 }
666 }
667
ef7eada9 668 PerlIO_printf(PerlIO_stderr(),
bbce6d69 669 "\tLANG = %c%s%c\n",
5f05dabc 670 lang ? '"' : '(',
bbce6d69
PP
671 lang ? lang : "unset",
672 lang ? '"' : ')');
ef7eada9 673
bbce6d69
PP
674 PerlIO_printf(PerlIO_stderr(),
675 " are supported and installed on your system.\n");
5f05dabc 676 }
ef7eada9 677
5f05dabc
PP
678#ifdef LC_ALL
679
680 if (setlocale(LC_ALL, "C")) {
681 if (locwarn)
682 PerlIO_printf(PerlIO_stderr(),
683 "perl: warning: Falling back to the standard locale (\"C\").\n");
bbce6d69 684 ok = 0;
ef7eada9 685 }
5f05dabc
PP
686 else {
687 if (locwarn)
688 PerlIO_printf(PerlIO_stderr(),
689 "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
690 ok = -1;
691 }
bbce6d69 692
5f05dabc
PP
693#else /* ! LC_ALL */
694
695 if (0
36477c24 696#ifdef USE_LOCALE_CTYPE
5f05dabc 697 || !(curctype || setlocale(LC_CTYPE, "C"))
36477c24
PP
698#endif /* USE_LOCALE_CTYPE */
699#ifdef USE_LOCALE_COLLATE
5f05dabc 700 || !(curcoll || setlocale(LC_COLLATE, "C"))
36477c24
PP
701#endif /* USE_LOCALE_COLLATE */
702#ifdef USE_LOCALE_NUMERIC
5f05dabc 703 || !(curnum || setlocale(LC_NUMERIC, "C"))
36477c24 704#endif /* USE_LOCALE_NUMERIC */
5f05dabc
PP
705 )
706 {
707 if (locwarn)
bbce6d69 708 PerlIO_printf(PerlIO_stderr(),
5f05dabc
PP
709 "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
710 ok = -1;
bbce6d69 711 }
5f05dabc 712
bbce6d69 713#endif /* ! LC_ALL */
5f05dabc
PP
714
715#ifdef USE_LOCALE_CTYPE
716 curctype = setlocale(LC_CTYPE, Nullch);
717#endif /* USE_LOCALE_CTYPE */
718#ifdef USE_LOCALE_COLLATE
719 curcoll = setlocale(LC_COLLATE, Nullch);
720#endif /* USE_LOCALE_COLLATE */
721#ifdef USE_LOCALE_NUMERIC
722 curnum = setlocale(LC_NUMERIC, Nullch);
723#endif /* USE_LOCALE_NUMERIC */
ef7eada9
JH
724 }
725
36477c24 726#ifdef USE_LOCALE_CTYPE
bbce6d69 727 perl_new_ctype(curctype);
36477c24 728#endif /* USE_LOCALE_CTYPE */
bbce6d69 729
36477c24 730#ifdef USE_LOCALE_COLLATE
bbce6d69 731 perl_new_collate(curcoll);
36477c24 732#endif /* USE_LOCALE_COLLATE */
bbce6d69 733
36477c24 734#ifdef USE_LOCALE_NUMERIC
bbce6d69 735 perl_new_numeric(curnum);
36477c24 736#endif /* USE_LOCALE_NUMERIC */
ef7eada9 737
36477c24 738#endif /* USE_LOCALE */
ef7eada9 739
f0c5b223
TB
740 return ok;
741}
742
bbce6d69
PP
743/* Backwards compatibility. */
744int
8ac85365 745perl_init_i18nl14n(int printwarn)
bbce6d69 746{
5f05dabc 747 return perl_init_i18nl10n(printwarn);
bbce6d69 748}
ef7eada9 749
36477c24 750#ifdef USE_LOCALE_COLLATE
ef7eada9 751
bbce6d69
PP
752/*
753 * mem_collxfrm() is a bit like strxfrm() but with two important
754 * differences. First, it handles embedded NULs. Second, it allocates
755 * a bit more memory than needed for the transformed data itself.
756 * The real transformed data begins at offset sizeof(collationix).
757 * Please see sv_collxfrm() to see how this is used.
758 */
759char *
8ac85365 760mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen)
bbce6d69
PP
761{
762 char *xbuf;
763 STRLEN xalloc, xin, xout;
764
765 /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
766 /* the +1 is for the terminating NUL. */
767
768 xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
769 New(171, xbuf, xalloc, char);
770 if (! xbuf)
771 goto bad;
772
773 *(U32*)xbuf = collation_ix;
774 xout = sizeof(collation_ix);
775 for (xin = 0; xin < len; ) {
776 SSize_t xused;
777
778 for (;;) {
779 xused = strxfrm(xbuf + xout, s + xin, xalloc - xout);
780 if (xused == -1)
781 goto bad;
782 if (xused < xalloc - xout)
783 break;
784 xalloc = (2 * xalloc) + 1;
785 Renew(xbuf, xalloc, char);
786 if (! xbuf)
787 goto bad;
788 }
ef7eada9 789
bbce6d69
PP
790 xin += strlen(s + xin) + 1;
791 xout += xused;
792
793 /* Embedded NULs are understood but silently skipped
794 * because they make no sense in locale collation. */
795 }
ef7eada9 796
bbce6d69
PP
797 xbuf[xout] = '\0';
798 *xlen = xout - sizeof(collation_ix);
799 return xbuf;
800
801 bad:
802 Safefree(xbuf);
803 *xlen = 0;
804 return NULL;
ef7eada9
JH
805}
806
36477c24 807#endif /* USE_LOCALE_COLLATE */
bbce6d69 808
378cc40b 809void
8ac85365 810fbm_compile(SV *sv)
378cc40b 811{
a687059c
LW
812 register unsigned char *s;
813 register unsigned char *table;
79072805
LW
814 register U32 i;
815 register U32 len = SvCUR(sv);
816 I32 rarest = 0;
817 U32 frequency = 256;
818
c277df42
IZ
819 sv_upgrade(sv, SVt_PVBM);
820 if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */
748a9306 821 return; /* can't have offsets that big */
02128f11
IZ
822 if (len > 2) {
823 Sv_Grow(sv,len + 258);
824 table = (unsigned char*)(SvPVX(sv) + len + 1);
825 s = table - 2;
826 for (i = 0; i < 256; i++) {
827 table[i] = len;
828 }
829 i = 0;
830 while (s >= (unsigned char*)(SvPVX(sv)))
831 {
832 if (table[*s] == len)
833 table[*s] = i;
834 s--,i++;
835 }
378cc40b 836 }
bbce6d69 837 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
79072805 838 SvVALID_on(sv);
378cc40b 839
463ee0b2 840 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
bbce6d69
PP
841 for (i = 0; i < len; i++) {
842 if (freq[s[i]] < frequency) {
843 rarest = i;
844 frequency = freq[s[i]];
378cc40b
LW
845 }
846 }
79072805
LW
847 BmRARE(sv) = s[rarest];
848 BmPREVIOUS(sv) = rarest;
760ac839 849 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
378cc40b
LW
850}
851
378cc40b 852char *
8ac85365 853fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr)
378cc40b 854{
a687059c 855 register unsigned char *s;
79072805
LW
856 register I32 tmp;
857 register I32 littlelen;
a687059c
LW
858 register unsigned char *little;
859 register unsigned char *table;
860 register unsigned char *olds;
861 register unsigned char *oldlittle;
378cc40b 862
79072805 863 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
a0d0e21e
LW
864 STRLEN len;
865 char *l = SvPV(littlestr,len);
c277df42 866 if (!len) {
02128f11
IZ
867 if (SvTAIL(littlestr)) { /* Can be only 0-len constant
868 substr => we can ignore SvVALID */
869 if (multiline) {
870 char *t = "\n";
3fe6f2dc
MB
871 if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend,
872 t, t + len))) {
873 return (char*)s;
874 }
02128f11 875 }
c277df42 876 if (bigend > big && bigend[-1] == '\n')
161b471a 877 return (char *)(bigend - 1);
c277df42 878 else
161b471a 879 return (char *) bigend;
c277df42 880 }
d48672a2 881 return (char*)big;
c277df42 882 }
a0d0e21e 883 return ninstr((char*)big,(char*)bigend, l, l + len);
d48672a2 884 }
378cc40b 885
79072805
LW
886 littlelen = SvCUR(littlestr);
887 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
0f85fab0
LW
888 if (littlelen > bigend - big)
889 return Nullch;
463ee0b2 890 little = (unsigned char*)SvPVX(littlestr);
bbce6d69 891 s = bigend - littlelen;
02128f11
IZ
892 if (s > big
893 && bigend[-1] == '\n'
894 && s[-1] == *little && memEQ((char*)s - 1,(char*)little,littlelen))
895 return (char*)s - 1; /* how sweet it is */
896 else if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
bbce6d69 897 return (char*)s; /* how sweet it is */
02128f11
IZ
898 return Nullch;
899 }
900 if (littlelen <= 2) {
901 unsigned char c1 = (unsigned char)SvPVX(littlestr)[0];
902 unsigned char c2 = (unsigned char)SvPVX(littlestr)[1];
903 /* This may do extra comparisons if littlelen == 2, but this
904 should be hidden in the noise since we do less indirection. */
905
906 s = big;
907 bigend -= littlelen;
908 while (s <= bigend) {
909 if (s[0] == c1
910 && (littlelen == 1 || s[1] == c2)
911 && (!SvTAIL(littlestr)
912 || s == bigend
913 || s[littlelen] == '\n')) /* Automatically multiline */
3fe6f2dc
MB
914 {
915 return (char*)s;
916 }
02128f11 917 s++;
a687059c 918 }
bbce6d69 919 return Nullch;
a687059c 920 }
463ee0b2 921 table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
62b28dd9
LW
922 if (--littlelen >= bigend - big)
923 return Nullch;
924 s = big + littlelen;
a687059c 925 oldlittle = little = table - 2;
bbce6d69
PP
926 if (s < bigend) {
927 top2:
928 /*SUPPRESS 560*/
929 if (tmp = table[*s]) {
62b28dd9 930#ifdef POINTERRIGOR
bbce6d69
PP
931 if (bigend - s > tmp) {
932 s += tmp;
933 goto top2;
934 }
62b28dd9 935#else
bbce6d69
PP
936 if ((s += tmp) < bigend)
937 goto top2;
62b28dd9 938#endif
bbce6d69 939 return Nullch;
a687059c 940 }
bbce6d69
PP
941 else {
942 tmp = littlelen; /* less expensive than calling strncmp() */
943 olds = s;
944 while (tmp--) {
945 if (*--s == *--little)
946 continue;
c277df42 947 differ:
bbce6d69
PP
948 s = olds + 1; /* here we pay the price for failure */
949 little = oldlittle;
950 if (s < bigend) /* fake up continue to outer loop */
62b28dd9 951 goto top2;
62b28dd9 952 return Nullch;
a687059c 953 }
c277df42
IZ
954 if (SvTAIL(littlestr) /* automatically multiline */
955 && olds + 1 != bigend
956 && olds[1] != '\n')
957 goto differ;
bbce6d69 958 return (char *)s;
378cc40b
LW
959 }
960 }
961 return Nullch;
962}
963
c277df42
IZ
964/* start_shift, end_shift are positive quantities which give offsets
965 of ends of some substring of bigstr.
966 If `last' we want the last occurence.
967 old_posp is the way of communication between consequent calls if
968 the next call needs to find the .
969 The initial *old_posp should be -1.
970 Note that we do not take into account SvTAIL, so it may give wrong
971 positives if _ALL flag is set.
972 */
973
378cc40b 974char *
c277df42 975screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
378cc40b 976{
a687059c
LW
977 register unsigned char *s, *x;
978 register unsigned char *big;
79072805
LW
979 register I32 pos;
980 register I32 previous;
981 register I32 first;
a687059c 982 register unsigned char *little;
c277df42 983 register I32 stop_pos;
a687059c 984 register unsigned char *littleend;
c277df42 985 I32 found = 0;
378cc40b 986
c277df42
IZ
987 if (*old_posp == -1
988 ? (pos = screamfirst[BmRARE(littlestr)]) < 0
989 : (((pos = *old_posp), pos += screamnext[pos]) == 0))
378cc40b 990 return Nullch;
463ee0b2 991 little = (unsigned char *)(SvPVX(littlestr));
79072805 992 littleend = little + SvCUR(littlestr);
378cc40b 993 first = *little++;
c277df42 994 /* The value of pos we can start at: */
79072805 995 previous = BmPREVIOUS(littlestr);
463ee0b2 996 big = (unsigned char *)(SvPVX(bigstr));
c277df42
IZ
997 /* The value of pos we can stop at: */
998 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
999 if (previous + start_shift > stop_pos) return Nullch;
1000 while (pos < previous + start_shift) {
378cc40b
LW
1001 if (!(pos += screamnext[pos]))
1002 return Nullch;
1003 }
de3bb511 1004#ifdef POINTERRIGOR
bbce6d69 1005 do {
c277df42 1006 if (pos >= stop_pos) return Nullch;
bbce6d69
PP
1007 if (big[pos-previous] != first)
1008 continue;
1009 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
bbce6d69
PP
1010 if (*s++ != *x++) {
1011 s--;
1012 break;
de3bb511 1013 }
bbce6d69 1014 }
c277df42
IZ
1015 if (s == littleend) {
1016 *old_posp = pos;
1017 if (!last) return (char *)(big+pos-previous);
1018 found = 1;
1019 }
bbce6d69 1020 } while ( pos += screamnext[pos] );
c277df42 1021 return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
de3bb511
LW
1022#else /* !POINTERRIGOR */
1023 big -= previous;
bbce6d69 1024 do {
c277df42 1025 if (pos >= stop_pos) return Nullch;
bbce6d69
PP
1026 if (big[pos] != first)
1027 continue;
1028 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69
PP
1029 if (*s++ != *x++) {
1030 s--;
1031 break;
378cc40b 1032 }
bbce6d69 1033 }
c277df42
IZ
1034 if (s == littleend) {
1035 *old_posp = pos;
1036 if (!last) return (char *)(big+pos);
1037 found = 1;
1038 }
bbce6d69 1039 } while ( pos += screamnext[pos] );
c277df42 1040 return (last && found) ? (char *)(big+(*old_posp)) : Nullch;
de3bb511 1041#endif /* POINTERRIGOR */
8d063cd8
LW
1042}
1043
79072805 1044I32
8ac85365 1045ibcmp(char *s1, char *s2, register I32 len)
79072805 1046{
bbce6d69
PP
1047 register U8 *a = (U8 *)s1;
1048 register U8 *b = (U8 *)s2;
79072805 1049 while (len--) {
bbce6d69
PP
1050 if (*a != *b && *a != fold[*b])
1051 return 1;
1052 a++,b++;
1053 }
1054 return 0;
1055}
1056
1057I32
8ac85365 1058ibcmp_locale(char *s1, char *s2, register I32 len)
bbce6d69
PP
1059{
1060 register U8 *a = (U8 *)s1;
1061 register U8 *b = (U8 *)s2;
1062 while (len--) {
1063 if (*a != *b && *a != fold_locale[*b])
1064 return 1;
1065 a++,b++;
79072805
LW
1066 }
1067 return 0;
1068}
1069
8d063cd8
LW
1070/* copy a string to a safe spot */
1071
1072char *
8ac85365 1073savepv(char *sv)
8d063cd8 1074{
a687059c 1075 register char *newaddr;
8d063cd8 1076
79072805
LW
1077 New(902,newaddr,strlen(sv)+1,char);
1078 (void)strcpy(newaddr,sv);
8d063cd8
LW
1079 return newaddr;
1080}
1081
a687059c
LW
1082/* same thing but with a known length */
1083
1084char *
8ac85365 1085savepvn(char *sv, register I32 len)
a687059c
LW
1086{
1087 register char *newaddr;
1088
1089 New(903,newaddr,len+1,char);
79072805 1090 Copy(sv,newaddr,len,char); /* might not be null terminated */
a687059c
LW
1091 newaddr[len] = '\0'; /* is now */
1092 return newaddr;
1093}
1094
fc36a67e
PP
1095/* the SV for form() and mess() is not kept in an arena */
1096
1097static SV *
8ac85365 1098mess_alloc(void)
fc36a67e
PP
1099{
1100 SV *sv;
1101 XPVMG *any;
1102
1103 /* Create as PVMG now, to avoid any upgrading later */
1104 New(905, sv, 1, SV);
1105 Newz(905, any, 1, XPVMG);
1106 SvFLAGS(sv) = SVt_PVMG;
1107 SvANY(sv) = (void*)any;
1108 SvREFCNT(sv) = 1 << 30; /* practically infinite */
1109 return sv;
1110}
1111
a0d0e21e 1112#ifdef I_STDARG
8990e307 1113char *
46fc3d4c 1114form(const char* pat, ...)
a687059c
LW
1115#else
1116/*VARARGS0*/
de3bb511 1117char *
46fc3d4c 1118form(pat, va_alist)
71be2cbc 1119 const char *pat;
46fc3d4c 1120 va_dcl
8990e307
LW
1121#endif
1122{
46fc3d4c
PP
1123 va_list args;
1124#ifdef I_STDARG
1125 va_start(args, pat);
a687059c 1126#else
46fc3d4c 1127 va_start(args);
d48672a2 1128#endif
fc36a67e
PP
1129 if (!mess_sv)
1130 mess_sv = mess_alloc();
1131 sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
46fc3d4c 1132 va_end(args);
fc36a67e 1133 return SvPVX(mess_sv);
46fc3d4c 1134}
a687059c 1135
46fc3d4c 1136char *
8ac85365 1137mess(const char *pat, va_list *args)
46fc3d4c
PP
1138{
1139 SV *sv;
1140 static char dgd[] = " during global destruction.\n";
1141
46fc3d4c 1142 if (!mess_sv)
fc36a67e 1143 mess_sv = mess_alloc();
46fc3d4c 1144 sv = mess_sv;
fc36a67e 1145 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
46fc3d4c 1146 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
e858de61 1147 dTHR;
2304df62 1148 if (dirty)
46fc3d4c 1149 sv_catpv(sv, dgd);
2304df62 1150 else {
46fc3d4c 1151 if (curcop->cop_line)
fc36a67e 1152 sv_catpvf(sv, " at %_ line %ld",
46fc3d4c 1153 GvSV(curcop->cop_filegv), (long)curcop->cop_line);
c07a80fd
PP
1154 if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
1155 bool line_mode = (RsSIMPLE(rs) &&
1156 SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
46fc3d4c
PP
1157 sv_catpvf(sv, ", <%s> %s %ld",
1158 last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
1159 line_mode ? "line" : "chunk",
1160 (long)IoLINES(GvIOp(last_in_gv)));
2304df62 1161 }
46fc3d4c 1162 sv_catpv(sv, ".\n");
a687059c 1163 }
a687059c 1164 }
46fc3d4c 1165 return SvPVX(sv);
a687059c
LW
1166}
1167
ecfc5424 1168#ifdef I_STDARG
36477c24 1169OP *
71be2cbc 1170die(const char* pat, ...)
36477c24
PP
1171#else
1172/*VARARGS0*/
1173OP *
1174die(pat, va_alist)
71be2cbc 1175 const char *pat;
36477c24
PP
1176 va_dcl
1177#endif
1178{
5dc0d613 1179 dTHR;
36477c24
PP
1180 va_list args;
1181 char *message;
36477c24
PP
1182 int was_in_eval = in_eval;
1183 HV *stash;
1184 GV *gv;
1185 CV *cv;
1186
57d3b86d 1187#ifdef USE_THREADS
199100c8
MB
1188 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1189 "%p: die: curstack = %p, mainstack = %p\n",
1190 thr, curstack, mainstack));
57d3b86d 1191#endif /* USE_THREADS */
36477c24
PP
1192 /* We have to switch back to mainstack or die_where may try to pop
1193 * the eval block from the wrong stack if die is being called from a
1194 * signal handler. - dkindred@cs.cmu.edu */
1195 if (curstack != mainstack) {
1196 dSP;
1197 SWITCHSTACK(curstack, mainstack);
1198 }
1199
1200#ifdef I_STDARG
1201 va_start(args, pat);
1202#else
1203 va_start(args);
1204#endif
1205 message = mess(pat, &args);
1206 va_end(args);
1207
57d3b86d 1208#ifdef USE_THREADS
199100c8
MB
1209 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1210 "%p: die: message = %s\ndiehook = %p\n",
1211 thr, message, diehook));
57d3b86d 1212#endif /* USE_THREADS */
1738f5c4
CS
1213 if (diehook) {
1214 /* sv_2cv might call croak() */
1215 SV *olddiehook = diehook;
1216 ENTER;
1217 SAVESPTR(diehook);
1218 diehook = Nullsv;
1219 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1220 LEAVE;
1221 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1222 dSP;
774d564b
PP
1223 SV *msg;
1224
1225 ENTER;
1226 msg = newSVpv(message, 0);
1227 SvREADONLY_on(msg);
1228 SAVEFREESV(msg);
1738f5c4
CS
1229
1230 PUSHMARK(sp);
1231 XPUSHs(msg);
1232 PUTBACK;
1233 perl_call_sv((SV*)cv, G_DISCARD);
1234
774d564b 1235 LEAVE;
1738f5c4 1236 }
36477c24
PP
1237 }
1238
1239 restartop = die_where(message);
57d3b86d 1240#ifdef USE_THREADS
d9f997d7 1241 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
7c06b590
GS
1242 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1243 thr, restartop, was_in_eval, top_env));
57d3b86d 1244#endif /* USE_THREADS */
7c06b590 1245 if ((!restartop && was_in_eval) || top_env->je_prev)
54310121 1246 JMPENV_JUMP(3);
36477c24
PP
1247 return restartop;
1248}
1249
1250#ifdef I_STDARG
79072805 1251void
71be2cbc 1252croak(const char* pat, ...)
463ee0b2 1253#else
8990e307
LW
1254/*VARARGS0*/
1255void
1256croak(pat, va_alist)
1257 char *pat;
1258 va_dcl
463ee0b2 1259#endif
a687059c 1260{
11343788 1261 dTHR;
a687059c 1262 va_list args;
de3bb511 1263 char *message;
748a9306
LW
1264 HV *stash;
1265 GV *gv;
1266 CV *cv;
a687059c 1267
a0d0e21e 1268#ifdef I_STDARG
8990e307
LW
1269 va_start(args, pat);
1270#else
a687059c 1271 va_start(args);
8990e307 1272#endif
2304df62 1273 message = mess(pat, &args);
a687059c 1274 va_end(args);
11343788 1275#ifdef USE_THREADS
d9f997d7 1276 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
11343788 1277#endif /* USE_THREADS */
20cec16a 1278 if (diehook) {
1738f5c4 1279 /* sv_2cv might call croak() */
20cec16a 1280 SV *olddiehook = diehook;
1738f5c4
CS
1281 ENTER;
1282 SAVESPTR(diehook);
1283 diehook = Nullsv;
20cec16a 1284 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1738f5c4
CS
1285 LEAVE;
1286 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1287 dSP;
774d564b
PP
1288 SV *msg;
1289
1290 ENTER;
1291 msg = newSVpv(message, 0);
1292 SvREADONLY_on(msg);
1293 SAVEFREESV(msg);
20cec16a
PP
1294
1295 PUSHMARK(sp);
1738f5c4 1296 XPUSHs(msg);
20cec16a
PP
1297 PUTBACK;
1298 perl_call_sv((SV*)cv, G_DISCARD);
36477c24 1299
774d564b 1300 LEAVE;
20cec16a 1301 }
748a9306 1302 }
a0d0e21e
LW
1303 if (in_eval) {
1304 restartop = die_where(message);
54310121 1305 JMPENV_JUMP(3);
a0d0e21e 1306 }
760ac839
LW
1307 PerlIO_puts(PerlIO_stderr(),message);
1308 (void)PerlIO_flush(PerlIO_stderr());
f86702cc 1309 my_failure_exit();
a687059c
LW
1310}
1311
8990e307 1312void
ecfc5424 1313#ifdef I_STDARG
71be2cbc 1314warn(const char* pat,...)
463ee0b2 1315#else
8990e307
LW
1316/*VARARGS0*/
1317warn(pat,va_alist)
71be2cbc 1318 const char *pat;
8990e307 1319 va_dcl
463ee0b2 1320#endif
a687059c
LW
1321{
1322 va_list args;
de3bb511 1323 char *message;
748a9306
LW
1324 HV *stash;
1325 GV *gv;
1326 CV *cv;
a687059c 1327
a0d0e21e 1328#ifdef I_STDARG
8990e307
LW
1329 va_start(args, pat);
1330#else
a687059c 1331 va_start(args);
8990e307 1332#endif
2304df62 1333 message = mess(pat, &args);
a687059c
LW
1334 va_end(args);
1335
20cec16a 1336 if (warnhook) {
1738f5c4 1337 /* sv_2cv might call warn() */
11343788 1338 dTHR;
20cec16a 1339 SV *oldwarnhook = warnhook;
1738f5c4
CS
1340 ENTER;
1341 SAVESPTR(warnhook);
1342 warnhook = Nullsv;
20cec16a 1343 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1738f5c4
CS
1344 LEAVE;
1345 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1346 dSP;
774d564b
PP
1347 SV *msg;
1348
1349 ENTER;
1350 msg = newSVpv(message, 0);
1351 SvREADONLY_on(msg);
1352 SAVEFREESV(msg);
1353
20cec16a 1354 PUSHMARK(sp);
774d564b 1355 XPUSHs(msg);
20cec16a
PP
1356 PUTBACK;
1357 perl_call_sv((SV*)cv, G_DISCARD);
774d564b
PP
1358
1359 LEAVE;
20cec16a
PP
1360 return;
1361 }
748a9306 1362 }
20cec16a 1363 PerlIO_puts(PerlIO_stderr(),message);
a687059c 1364#ifdef LEAKTEST
20cec16a 1365 DEBUG_L(xstat());
a687059c 1366#endif
20cec16a 1367 (void)PerlIO_flush(PerlIO_stderr());
a687059c 1368}
8d063cd8 1369
a0d0e21e 1370#ifndef VMS /* VMS' my_setenv() is in VMS.c */
3e3baf6d 1371#ifndef WIN32
8d063cd8 1372void
8ac85365 1373my_setenv(char *nam, char *val)
8d063cd8 1374{
79072805 1375 register I32 i=setenv_getix(nam); /* where does it go? */
8d063cd8 1376
fe14fcc3 1377 if (environ == origenviron) { /* need we copy environment? */
79072805
LW
1378 I32 j;
1379 I32 max;
fe14fcc3
LW
1380 char **tmpenv;
1381
de3bb511 1382 /*SUPPRESS 530*/
fe14fcc3
LW
1383 for (max = i; environ[max]; max++) ;
1384 New(901,tmpenv, max+2, char*);
1385 for (j=0; j<max; j++) /* copy environment */
a0d0e21e 1386 tmpenv[j] = savepv(environ[j]);
fe14fcc3
LW
1387 tmpenv[max] = Nullch;
1388 environ = tmpenv; /* tell exec where it is now */
1389 }
a687059c 1390 if (!val) {
e5ebf479 1391 Safefree(environ[i]);
a687059c
LW
1392 while (environ[i]) {
1393 environ[i] = environ[i+1];
1394 i++;
1395 }
1396 return;
1397 }
8d063cd8 1398 if (!environ[i]) { /* does not exist yet */
fe14fcc3 1399 Renew(environ, i+2, char*); /* just expand it a bit */
8d063cd8
LW
1400 environ[i+1] = Nullch; /* make sure it's null terminated */
1401 }
fe14fcc3
LW
1402 else
1403 Safefree(environ[i]);
a687059c 1404 New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
62b28dd9 1405#ifndef MSDOS
a687059c 1406 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
62b28dd9
LW
1407#else
1408 /* MS-DOS requires environment variable names to be in uppercase */
fe14fcc3
LW
1409 /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1410 * some utilities and applications may break because they only look
1411 * for upper case strings. (Fixed strupr() bug here.)]
1412 */
1413 strcpy(environ[i],nam); strupr(environ[i]);
62b28dd9
LW
1414 (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1415#endif /* MSDOS */
8d063cd8
LW
1416}
1417
3e3baf6d 1418#else /* if WIN32 */
68dc0745
PP
1419
1420void
4e35701f 1421my_setenv(char *nam,char *val)
68dc0745 1422{
3e3baf6d
TB
1423
1424#ifdef USE_WIN32_RTL_ENV
1425
68dc0745
PP
1426 register char *envstr;
1427 STRLEN namlen = strlen(nam);
3e3baf6d
TB
1428 STRLEN vallen;
1429 char *oldstr = environ[setenv_getix(nam)];
1430
1431 /* putenv() has totally broken semantics in both the Borland
1432 * and Microsoft CRTLs. They either store the passed pointer in
1433 * the environment without making a copy, or make a copy and don't
1434 * free it. And on top of that, they dont free() old entries that
1435 * are being replaced/deleted. This means the caller must
1436 * free any old entries somehow, or we end up with a memory
1437 * leak every time my_setenv() is called. One might think
1438 * one could directly manipulate environ[], like the UNIX code
1439 * above, but direct changes to environ are not allowed when
1440 * calling putenv(), since the RTLs maintain an internal
1441 * *copy* of environ[]. Bad, bad, *bad* stink.
1442 * GSAR 97-06-07
1443 */
68dc0745 1444
3e3baf6d
TB
1445 if (!val) {
1446 if (!oldstr)
1447 return;
1448 val = "";
1449 vallen = 0;
1450 }
1451 else
1452 vallen = strlen(val);
fc36a67e 1453 New(904, envstr, namlen + vallen + 3, char);
68dc0745 1454 (void)sprintf(envstr,"%s=%s",nam,val);
5fd9e9a4 1455 (void)PerlEnv_putenv(envstr);
3e3baf6d
TB
1456 if (oldstr)
1457 Safefree(oldstr);
1458#ifdef _MSC_VER
1459 Safefree(envstr); /* MSVCRT leaks without this */
1460#endif
1461
1462#else /* !USE_WIN32_RTL_ENV */
1463
1464 /* The sane way to deal with the environment.
1465 * Has these advantages over putenv() & co.:
1466 * * enables us to store a truly empty value in the
1467 * environment (like in UNIX).
1468 * * we don't have to deal with RTL globals, bugs and leaks.
1469 * * Much faster.
1470 * Why you may want to enable USE_WIN32_RTL_ENV:
1471 * * environ[] and RTL functions will not reflect changes,
1472 * which might be an issue if extensions want to access
1473 * the env. via RTL. This cuts both ways, since RTL will
1474 * not see changes made by extensions that call the Win32
1475 * functions directly, either.
1476 * GSAR 97-06-07
1477 */
1478 SetEnvironmentVariable(nam,val);
1479
1480#endif
1481}
1482
1483#endif /* WIN32 */
1484
1485I32
8ac85365 1486setenv_getix(char *nam)
3e3baf6d
TB
1487{
1488 register I32 i, len = strlen(nam);
1489
1490 for (i = 0; environ[i]; i++) {
1491 if (
1492#ifdef WIN32
1493 strnicmp(environ[i],nam,len) == 0
1494#else
1495 strnEQ(environ[i],nam,len)
1496#endif
1497 && environ[i][len] == '=')
1498 break; /* strnEQ must come first to avoid */
1499 } /* potential SEGV's */
1500 return i;
68dc0745
PP
1501}
1502
a0d0e21e 1503#endif /* !VMS */
378cc40b 1504
16d20bd9 1505#ifdef UNLINK_ALL_VERSIONS
79072805 1506I32
378cc40b
LW
1507unlnk(f) /* unlink all versions of a file */
1508char *f;
1509{
79072805 1510 I32 i;
378cc40b 1511
3028581b 1512 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
378cc40b
LW
1513 return i ? 0 : -1;
1514}
1515#endif
1516
85e6fe83 1517#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
378cc40b 1518char *
4e35701f 1519my_bcopy(register char *from,register char *to,register I32 len)
378cc40b
LW
1520{
1521 char *retval = to;
1522
7c0587c8
LW
1523 if (from - to >= 0) {
1524 while (len--)
1525 *to++ = *from++;
1526 }
1527 else {
1528 to += len;
1529 from += len;
1530 while (len--)
faf8582f 1531 *(--to) = *(--from);
7c0587c8 1532 }
378cc40b
LW
1533 return retval;
1534}
ffed7fef 1535#endif
378cc40b 1536
fc36a67e
PP
1537#ifndef HAS_MEMSET
1538void *
1539my_memset(loc,ch,len)
1540register char *loc;
1541register I32 ch;
1542register I32 len;
1543{
1544 char *retval = loc;
1545
1546 while (len--)
1547 *loc++ = ch;
1548 return retval;
1549}
1550#endif
1551
7c0587c8 1552#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1553char *
7c0587c8 1554my_bzero(loc,len)
378cc40b 1555register char *loc;
79072805 1556register I32 len;
378cc40b
LW
1557{
1558 char *retval = loc;
1559
1560 while (len--)
1561 *loc++ = 0;
1562 return retval;
1563}
1564#endif
7c0587c8 1565
36477c24 1566#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1567I32
7c0587c8 1568my_memcmp(s1,s2,len)
36477c24
PP
1569char *s1;
1570char *s2;
79072805 1571register I32 len;
7c0587c8 1572{
36477c24
PP
1573 register U8 *a = (U8 *)s1;
1574 register U8 *b = (U8 *)s2;
79072805 1575 register I32 tmp;
7c0587c8
LW
1576
1577 while (len--) {
36477c24 1578 if (tmp = *a++ - *b++)
7c0587c8
LW
1579 return tmp;
1580 }
1581 return 0;
1582}
36477c24 1583#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1584
4633a7c4 1585#if defined(I_STDARG) || defined(I_VARARGS)
fe14fcc3 1586#ifndef HAS_VPRINTF
a687059c 1587
85e6fe83 1588#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1589char *
1590#else
1591int
1592#endif
1593vsprintf(dest, pat, args)
71be2cbc
PP
1594char *dest;
1595const char *pat;
1596char *args;
a687059c
LW
1597{
1598 FILE fakebuf;
1599
1600 fakebuf._ptr = dest;
1601 fakebuf._cnt = 32767;
35c8bce7
LW
1602#ifndef _IOSTRG
1603#define _IOSTRG 0
1604#endif
a687059c
LW
1605 fakebuf._flag = _IOWRT|_IOSTRG;
1606 _doprnt(pat, args, &fakebuf); /* what a kludge */
1607 (void)putc('\0', &fakebuf);
85e6fe83 1608#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1609 return(dest);
1610#else
1611 return 0; /* perl doesn't use return value */
1612#endif
1613}
1614
fe14fcc3 1615#endif /* HAS_VPRINTF */
4633a7c4 1616#endif /* I_VARARGS || I_STDARGS */
a687059c
LW
1617
1618#ifdef MYSWAP
ffed7fef 1619#if BYTEORDER != 0x4321
a687059c 1620short
748a9306 1621#ifndef CAN_PROTOTYPE
a687059c
LW
1622my_swap(s)
1623short s;
748a9306
LW
1624#else
1625my_swap(short s)
1626#endif
a687059c
LW
1627{
1628#if (BYTEORDER & 1) == 0
1629 short result;
1630
1631 result = ((s & 255) << 8) + ((s >> 8) & 255);
1632 return result;
1633#else
1634 return s;
1635#endif
1636}
1637
1638long
748a9306
LW
1639#ifndef CAN_PROTOTYPE
1640my_htonl(l)
a687059c 1641register long l;
748a9306
LW
1642#else
1643my_htonl(long l)
1644#endif
a687059c
LW
1645{
1646 union {
1647 long result;
ffed7fef 1648 char c[sizeof(long)];
a687059c
LW
1649 } u;
1650
ffed7fef 1651#if BYTEORDER == 0x1234
a687059c
LW
1652 u.c[0] = (l >> 24) & 255;
1653 u.c[1] = (l >> 16) & 255;
1654 u.c[2] = (l >> 8) & 255;
1655 u.c[3] = l & 255;
1656 return u.result;
1657#else
ffed7fef 1658#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
463ee0b2 1659 croak("Unknown BYTEORDER\n");
a687059c 1660#else
79072805
LW
1661 register I32 o;
1662 register I32 s;
a687059c 1663
ffed7fef
LW
1664 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1665 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW
1666 }
1667 return u.result;
1668#endif
1669#endif
1670}
1671
1672long
748a9306
LW
1673#ifndef CAN_PROTOTYPE
1674my_ntohl(l)
a687059c 1675register long l;
748a9306
LW
1676#else
1677my_ntohl(long l)
1678#endif
a687059c
LW
1679{
1680 union {
1681 long l;
ffed7fef 1682 char c[sizeof(long)];
a687059c
LW
1683 } u;
1684
ffed7fef 1685#if BYTEORDER == 0x1234
a687059c
LW
1686 u.c[0] = (l >> 24) & 255;
1687 u.c[1] = (l >> 16) & 255;
1688 u.c[2] = (l >> 8) & 255;
1689 u.c[3] = l & 255;
1690 return u.l;
1691#else
ffed7fef 1692#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
463ee0b2 1693 croak("Unknown BYTEORDER\n");
a687059c 1694#else
79072805
LW
1695 register I32 o;
1696 register I32 s;
a687059c
LW
1697
1698 u.l = l;
1699 l = 0;
ffed7fef
LW
1700 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1701 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW
1702 }
1703 return l;
1704#endif
1705#endif
1706}
1707
ffed7fef 1708#endif /* BYTEORDER != 0x4321 */
988174c1
LW
1709#endif /* MYSWAP */
1710
1711/*
1712 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1713 * If these functions are defined,
1714 * the BYTEORDER is neither 0x1234 nor 0x4321.
1715 * However, this is not assumed.
1716 * -DWS
1717 */
1718
1719#define HTOV(name,type) \
1720 type \
1721 name (n) \
1722 register type n; \
1723 { \
1724 union { \
1725 type value; \
1726 char c[sizeof(type)]; \
1727 } u; \
79072805
LW
1728 register I32 i; \
1729 register I32 s; \
988174c1
LW
1730 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1731 u.c[i] = (n >> s) & 0xFF; \
1732 } \
1733 return u.value; \
1734 }
1735
1736#define VTOH(name,type) \
1737 type \
1738 name (n) \
1739 register type n; \
1740 { \
1741 union { \
1742 type value; \
1743 char c[sizeof(type)]; \
1744 } u; \
79072805
LW
1745 register I32 i; \
1746 register I32 s; \
988174c1
LW
1747 u.value = n; \
1748 n = 0; \
1749 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1750 n += (u.c[i] & 0xFF) << s; \
1751 } \
1752 return n; \
1753 }
1754
1755#if defined(HAS_HTOVS) && !defined(htovs)
1756HTOV(htovs,short)
1757#endif
1758#if defined(HAS_HTOVL) && !defined(htovl)
1759HTOV(htovl,long)
1760#endif
1761#if defined(HAS_VTOHS) && !defined(vtohs)
1762VTOH(vtohs,short)
1763#endif
1764#if defined(HAS_VTOHL) && !defined(vtohl)
1765VTOH(vtohl,long)
1766#endif
a687059c 1767
5f05dabc
PP
1768 /* VMS' my_popen() is in VMS.c, same with OS/2. */
1769#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
760ac839 1770PerlIO *
8ac85365 1771my_popen(char *cmd, char *mode)
a687059c
LW
1772{
1773 int p[2];
8ac85365 1774 register I32 This, that;
79072805
LW
1775 register I32 pid;
1776 SV *sv;
1738f5c4 1777 I32 doexec = strNE(cmd,"-");
a687059c 1778
ddcf38b7
IZ
1779#ifdef OS2
1780 if (doexec) {
1781 return my_syspopen(cmd,mode);
1782 }
1783#endif
3028581b 1784 if (PerlProc_pipe(p) < 0)
a687059c 1785 return Nullfp;
8ac85365
NIS
1786 This = (*mode == 'w');
1787 that = !This;
bbce6d69
PP
1788 if (doexec && tainting) {
1789 taint_env();
1790 taint_proper("Insecure %s%s", "EXEC");
d48672a2 1791 }
a687059c
LW
1792 while ((pid = (doexec?vfork():fork())) < 0) {
1793 if (errno != EAGAIN) {
3028581b 1794 PerlLIO_close(p[This]);
a687059c 1795 if (!doexec)
463ee0b2 1796 croak("Can't fork");
a687059c
LW
1797 return Nullfp;
1798 }
1799 sleep(5);
1800 }
1801 if (pid == 0) {
79072805
LW
1802 GV* tmpgv;
1803
a687059c 1804#define THIS that
8ac85365 1805#define THAT This
3028581b 1806 PerlLIO_close(p[THAT]);
a687059c 1807 if (p[THIS] != (*mode == 'r')) {
3028581b
GS
1808 PerlLIO_dup2(p[THIS], *mode == 'r');
1809 PerlLIO_close(p[THIS]);
a687059c
LW
1810 }
1811 if (doexec) {
a0d0e21e 1812#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
1813 int fd;
1814
1815#ifndef NOFILE
1816#define NOFILE 20
1817#endif
d48672a2 1818 for (fd = maxsysfd + 1; fd < NOFILE; fd++)
3028581b 1819 PerlLIO_close(fd);
ae986130 1820#endif
a687059c 1821 do_exec(cmd); /* may or may not use the shell */
3028581b 1822 PerlProc__exit(1);
a687059c 1823 }
de3bb511 1824 /*SUPPRESS 560*/
85e6fe83 1825 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 1826 sv_setiv(GvSV(tmpgv), (IV)getpid());
9f68db38 1827 forkprocess = 0;
463ee0b2 1828 hv_clear(pidstatus); /* we have no children */
a687059c
LW
1829 return Nullfp;
1830#undef THIS
1831#undef THAT
1832 }
62b28dd9 1833 do_execfree(); /* free any memory malloced by child on vfork */
3028581b 1834 PerlLIO_close(p[that]);
8ac85365 1835 if (p[that] < p[This]) {
3028581b
GS
1836 PerlLIO_dup2(p[This], p[that]);
1837 PerlLIO_close(p[This]);
8ac85365 1838 p[This] = p[that];
62b28dd9 1839 }
8ac85365 1840 sv = *av_fetch(fdpid,p[This],TRUE);
a0d0e21e 1841 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 1842 SvIVX(sv) = pid;
a687059c 1843 forkprocess = pid;
8ac85365 1844 return PerlIO_fdopen(p[This], mode);
a687059c 1845}
7c0587c8 1846#else
55497cff 1847#if defined(atarist) || defined(DJGPP)
7c0587c8 1848FILE *popen();
760ac839 1849PerlIO *
79072805 1850my_popen(cmd,mode)
7c0587c8
LW
1851char *cmd;
1852char *mode;
1853{
760ac839 1854 /* Needs work for PerlIO ! */
55497cff
PP
1855 /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
1856 return popen(PerlIO_exportFILE(cmd, 0), mode);
7c0587c8
LW
1857}
1858#endif
1859
1860#endif /* !DOSISH */
a687059c 1861
748a9306 1862#ifdef DUMP_FDS
79072805 1863dump_fds(s)
ae986130
LW
1864char *s;
1865{
1866 int fd;
1867 struct stat tmpstatbuf;
1868
760ac839 1869 PerlIO_printf(PerlIO_stderr(),"%s", s);
ae986130 1870 for (fd = 0; fd < 32; fd++) {
3028581b 1871 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
760ac839 1872 PerlIO_printf(PerlIO_stderr()," %d",fd);
ae986130 1873 }
760ac839 1874 PerlIO_printf(PerlIO_stderr(),"\n");
ae986130
LW
1875}
1876#endif
1877
fe14fcc3 1878#ifndef HAS_DUP2
fec02dd3 1879int
a687059c
LW
1880dup2(oldfd,newfd)
1881int oldfd;
1882int newfd;
1883{
a0d0e21e 1884#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
1885 if (oldfd == newfd)
1886 return oldfd;
3028581b 1887 PerlLIO_close(newfd);
fec02dd3 1888 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 1889#else
fc36a67e
PP
1890#define DUP2_MAX_FDS 256
1891 int fdtmp[DUP2_MAX_FDS];
79072805 1892 I32 fdx = 0;
ae986130
LW
1893 int fd;
1894
fe14fcc3 1895 if (oldfd == newfd)
fec02dd3 1896 return oldfd;
3028581b 1897 PerlLIO_close(newfd);
fc36a67e 1898 /* good enough for low fd's... */
3028581b 1899 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 1900 if (fdx >= DUP2_MAX_FDS) {
3028581b 1901 PerlLIO_close(fd);
fc36a67e
PP
1902 fd = -1;
1903 break;
1904 }
ae986130 1905 fdtmp[fdx++] = fd;
fc36a67e 1906 }
ae986130 1907 while (fdx > 0)
3028581b 1908 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 1909 return fd;
62b28dd9 1910#endif
a687059c
LW
1911}
1912#endif
1913
ff68c719
PP
1914
1915#ifdef HAS_SIGACTION
1916
1917Sighandler_t
8ac85365 1918rsignal(int signo, Sighandler_t handler)
ff68c719
PP
1919{
1920 struct sigaction act, oact;
1921
1922 act.sa_handler = handler;
1923 sigemptyset(&act.sa_mask);
1924 act.sa_flags = 0;
1925#ifdef SA_RESTART
1926 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1927#endif
1928 if (sigaction(signo, &act, &oact) == -1)
36477c24 1929 return SIG_ERR;
ff68c719 1930 else
36477c24 1931 return oact.sa_handler;
ff68c719
PP
1932}
1933
1934Sighandler_t
8ac85365 1935rsignal_state(int signo)
ff68c719
PP
1936{
1937 struct sigaction oact;
1938
1939 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
1940 return SIG_ERR;
1941 else
1942 return oact.sa_handler;
1943}
1944
1945int
8ac85365 1946rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719
PP
1947{
1948 struct sigaction act;
1949
1950 act.sa_handler = handler;
1951 sigemptyset(&act.sa_mask);
1952 act.sa_flags = 0;
1953#ifdef SA_RESTART
1954 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1955#endif
1956 return sigaction(signo, &act, save);
1957}
1958
1959int
8ac85365 1960rsignal_restore(int signo, Sigsave_t *save)
ff68c719
PP
1961{
1962 return sigaction(signo, save, (struct sigaction *)NULL);
1963}
1964
1965#else /* !HAS_SIGACTION */
1966
1967Sighandler_t
4e35701f 1968rsignal(int signo, Sighandler_t handler)
ff68c719 1969{
3028581b 1970 return PerlProc_signal(signo, handler);
ff68c719
PP
1971}
1972
1973static int sig_trapped;
1974
1975static
1976Signal_t
4e35701f 1977sig_trap(int signo)
ff68c719
PP
1978{
1979 sig_trapped++;
1980}
1981
1982Sighandler_t
4e35701f 1983rsignal_state(int signo)
ff68c719
PP
1984{
1985 Sighandler_t oldsig;
1986
1987 sig_trapped = 0;
3028581b
GS
1988 oldsig = PerlProc_signal(signo, sig_trap);
1989 PerlProc_signal(signo, oldsig);
ff68c719 1990 if (sig_trapped)
3028581b 1991 PerlProc_kill(getpid(), signo);
ff68c719
PP
1992 return oldsig;
1993}
1994
1995int
4e35701f 1996rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 1997{
3028581b 1998 *save = PerlProc_signal(signo, handler);
ff68c719
PP
1999 return (*save == SIG_ERR) ? -1 : 0;
2000}
2001
2002int
4e35701f 2003rsignal_restore(int signo, Sigsave_t *save)
ff68c719 2004{
3028581b 2005 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719
PP
2006}
2007
2008#endif /* !HAS_SIGACTION */
2009
5f05dabc
PP
2010 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2011#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
79072805 2012I32
6acef3b7 2013my_pclose(PerlIO *ptr)
a687059c 2014{
ff68c719 2015 Sigsave_t hstat, istat, qstat;
a687059c 2016 int status;
a0d0e21e 2017 SV **svp;
20188a90 2018 int pid;
03136e13
CS
2019 bool close_failed;
2020 int saved_errno;
2021#ifdef VMS
2022 int saved_vaxc_errno;
2023#endif
22fae026
TM
2024#ifdef WIN32
2025 int saved_win32_errno;
2026#endif
a687059c 2027
760ac839 2028 svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
748a9306 2029 pid = (int)SvIVX(*svp);
a0d0e21e
LW
2030 SvREFCNT_dec(*svp);
2031 *svp = &sv_undef;
ddcf38b7
IZ
2032#ifdef OS2
2033 if (pid == -1) { /* Opened by popen. */
2034 return my_syspclose(ptr);
2035 }
2036#endif
03136e13
CS
2037 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2038 saved_errno = errno;
2039#ifdef VMS
2040 saved_vaxc_errno = vaxc$errno;
2041#endif
22fae026
TM
2042#ifdef WIN32
2043 saved_win32_errno = GetLastError();
2044#endif
03136e13 2045 }
7c0587c8 2046#ifdef UTS
3028581b 2047 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2048#endif
ff68c719
PP
2049 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2050 rsignal_save(SIGINT, SIG_IGN, &istat);
2051 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
748a9306
LW
2052 do {
2053 pid = wait4pid(pid, &status, 0);
2054 } while (pid == -1 && errno == EINTR);
ff68c719
PP
2055 rsignal_restore(SIGHUP, &hstat);
2056 rsignal_restore(SIGINT, &istat);
2057 rsignal_restore(SIGQUIT, &qstat);
03136e13
CS
2058 if (close_failed) {
2059 SETERRNO(saved_errno, saved_vaxc_errno);
2060 return -1;
2061 }
2062 return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
20188a90 2063}
4633a7c4
LW
2064#endif /* !DOSISH */
2065
2d7a9237 2066#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
79072805 2067I32
8ac85365 2068wait4pid(int pid, int *statusp, int flags)
20188a90 2069{
79072805
LW
2070 SV *sv;
2071 SV** svp;
fc36a67e 2072 char spid[TYPE_CHARS(int)];
20188a90
LW
2073
2074 if (!pid)
2075 return -1;
20188a90
LW
2076 if (pid > 0) {
2077 sprintf(spid, "%d", pid);
79072805
LW
2078 svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
2079 if (svp && *svp != &sv_undef) {
463ee0b2 2080 *statusp = SvIVX(*svp);
748a9306 2081 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW
2082 return pid;
2083 }
2084 }
2085 else {
79072805 2086 HE *entry;
20188a90 2087
79072805
LW
2088 hv_iterinit(pidstatus);
2089 if (entry = hv_iternext(pidstatus)) {
a0d0e21e 2090 pid = atoi(hv_iterkey(entry,(I32*)statusp));
79072805 2091 sv = hv_iterval(pidstatus,entry);
463ee0b2 2092 *statusp = SvIVX(sv);
20188a90 2093 sprintf(spid, "%d", pid);
748a9306 2094 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW
2095 return pid;
2096 }
2097 }
79072805 2098#ifdef HAS_WAITPID
367f3c24
IZ
2099# ifdef HAS_WAITPID_RUNTIME
2100 if (!HAS_WAITPID_RUNTIME)
2101 goto hard_way;
2102# endif
79072805 2103 return waitpid(pid,statusp,flags);
367f3c24
IZ
2104#endif
2105#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
a0d0e21e 2106 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
367f3c24
IZ
2107#endif
2108#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2109 hard_way:
a0d0e21e
LW
2110 {
2111 I32 result;
2112 if (flags)
2113 croak("Can't do waitpid with flags");
2114 else {
2115 while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
2116 pidgone(result,*statusp);
2117 if (result < 0)
2118 *statusp = -1;
2119 }
2120 return result;
a687059c
LW
2121 }
2122#endif
a687059c 2123}
2d7a9237 2124#endif /* !DOSISH || OS2 || WIN32 */
a687059c 2125
7c0587c8 2126void
de3bb511 2127/*SUPPRESS 590*/
8ac85365 2128pidgone(int pid, int status)
a687059c 2129{
79072805 2130 register SV *sv;
fc36a67e 2131 char spid[TYPE_CHARS(int)];
a687059c 2132
20188a90 2133 sprintf(spid, "%d", pid);
79072805 2134 sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2135 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2136 SvIVX(sv) = status;
20188a90 2137 return;
a687059c
LW
2138}
2139
55497cff 2140#if defined(atarist) || defined(OS2) || defined(DJGPP)
7c0587c8 2141int pclose();
ddcf38b7
IZ
2142#ifdef HAS_FORK
2143int /* Cannot prototype with I32
2144 in os2ish.h. */
2145my_syspclose(ptr)
2146#else
79072805
LW
2147I32
2148my_pclose(ptr)
ddcf38b7 2149#endif
760ac839 2150PerlIO *ptr;
a687059c 2151{
760ac839
LW
2152 /* Needs work for PerlIO ! */
2153 FILE *f = PerlIO_findFILE(ptr);
2154 I32 result = pclose(f);
2155 PerlIO_releaseFILE(ptr,f);
2156 return result;
a687059c 2157}
7c0587c8 2158#endif
9f68db38
LW
2159
2160void
8ac85365 2161repeatcpy(register char *to, register char *from, I32 len, register I32 count)
9f68db38 2162{
79072805 2163 register I32 todo;
9f68db38
LW
2164 register char *frombase = from;
2165
2166 if (len == 1) {
2167 todo = *from;
2168 while (count-- > 0)
2169 *to++ = todo;
2170 return;
2171 }
2172 while (count-- > 0) {
2173 for (todo = len; todo > 0; todo--) {
2174 *to++ = *from++;
2175 }
2176 from = frombase;
2177 }
2178}
0f85fab0
LW
2179
2180#ifndef CASTNEGFLOAT
463ee0b2 2181U32
79072805 2182cast_ulong(f)
0f85fab0
LW
2183double f;
2184{
2185 long along;
2186
27e2fb84 2187#if CASTFLAGS & 2
34de22dd
LW
2188# define BIGDOUBLE 2147483648.0
2189 if (f >= BIGDOUBLE)
2190 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
2191#endif
0f85fab0
LW
2192 if (f >= 0.0)
2193 return (unsigned long)f;
2194 along = (long)f;
2195 return (unsigned long)along;
2196}
ed6116ce
LW
2197# undef BIGDOUBLE
2198#endif
2199
2200#ifndef CASTI32
5d94fbed 2201
5d94fbed
AD
2202/* Unfortunately, on some systems the cast_uv() function doesn't
2203 work with the system-supplied definition of ULONG_MAX. The
2204 comparison (f >= ULONG_MAX) always comes out true. It must be a
2205 problem with the compiler constant folding.
2206
2207 In any case, this workaround should be fine on any two's complement
2208 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2209 ccflags.
2210 --Andy Dougherty <doughera@lafcol.lafayette.edu>
2211*/
1eb770ff
PP
2212
2213/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2214 of LONG_(MIN/MAX).
2215 -- Kenneth Albanowski <kjahds@kjahds.com>
2216*/
2217
20cec16a
PP
2218#ifndef MY_UV_MAX
2219# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
5d94fbed
AD
2220#endif
2221
ed6116ce
LW
2222I32
2223cast_i32(f)
2224double f;
2225{
20cec16a
PP
2226 if (f >= I32_MAX)
2227 return (I32) I32_MAX;
2228 if (f <= I32_MIN)
2229 return (I32) I32_MIN;
ed6116ce
LW
2230 return (I32) f;
2231}
a0d0e21e
LW
2232
2233IV
2234cast_iv(f)
2235double f;
2236{
20cec16a
PP
2237 if (f >= IV_MAX)
2238 return (IV) IV_MAX;
2239 if (f <= IV_MIN)
2240 return (IV) IV_MIN;
a0d0e21e
LW
2241 return (IV) f;
2242}
5d94fbed
AD
2243
2244UV
2245cast_uv(f)
2246double f;
2247{
20cec16a
PP
2248 if (f >= MY_UV_MAX)
2249 return (UV) MY_UV_MAX;
5d94fbed
AD
2250 return (UV) f;
2251}
2252
0f85fab0 2253#endif
62b28dd9 2254
fe14fcc3 2255#ifndef HAS_RENAME
79072805 2256I32
62b28dd9
LW
2257same_dirent(a,b)
2258char *a;
2259char *b;
2260{
93a17b20
LW
2261 char *fa = strrchr(a,'/');
2262 char *fb = strrchr(b,'/');
62b28dd9
LW
2263 struct stat tmpstatbuf1;
2264 struct stat tmpstatbuf2;
46fc3d4c 2265 SV *tmpsv = sv_newmortal();
62b28dd9
LW
2266
2267 if (fa)
2268 fa++;
2269 else
2270 fa = a;
2271 if (fb)
2272 fb++;
2273 else
2274 fb = b;
2275 if (strNE(a,b))
2276 return FALSE;
2277 if (fa == a)
46fc3d4c 2278 sv_setpv(tmpsv, ".");
62b28dd9 2279 else
46fc3d4c
PP
2280 sv_setpvn(tmpsv, a, fa - a);
2281 if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW
2282 return FALSE;
2283 if (fb == b)
46fc3d4c 2284 sv_setpv(tmpsv, ".");
62b28dd9 2285 else
46fc3d4c
PP
2286 sv_setpvn(tmpsv, b, fb - b);
2287 if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW
2288 return FALSE;
2289 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2290 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2291}
fe14fcc3
LW
2292#endif /* !HAS_RENAME */
2293
55497cff 2294UV
8ac85365 2295scan_oct(char *start, I32 len, I32 *retlen)
fe14fcc3
LW
2296{
2297 register char *s = start;
55497cff
PP
2298 register UV retval = 0;
2299 bool overflowed = FALSE;
fe14fcc3 2300
748a9306 2301 while (len && *s >= '0' && *s <= '7') {
55497cff
PP
2302 register UV n = retval << 3;
2303 if (!overflowed && (n >> 3) != retval) {
2304 warn("Integer overflow in octal number");
2305 overflowed = TRUE;
2306 }
2307 retval = n | (*s++ - '0');
748a9306 2308 len--;
fe14fcc3 2309 }
748a9306
LW
2310 if (dowarn && len && (*s == '8' || *s == '9'))
2311 warn("Illegal octal digit ignored");
fe14fcc3
LW
2312 *retlen = s - start;
2313 return retval;
2314}
2315
71be2cbc 2316UV
8ac85365 2317scan_hex(char *start, I32 len, I32 *retlen)
fe14fcc3
LW
2318{
2319 register char *s = start;
55497cff
PP
2320 register UV retval = 0;
2321 bool overflowed = FALSE;
fe14fcc3
LW
2322 char *tmp;
2323
4e35701f 2324 while (len-- && *s && (tmp = strchr((char *) hexdigit, *s))) {
55497cff
PP
2325 register UV n = retval << 4;
2326 if (!overflowed && (n >> 4) != retval) {
2327 warn("Integer overflow in hex number");
2328 overflowed = TRUE;
2329 }
4e35701f 2330 retval = n | ((tmp - hexdigit) & 15);
fe14fcc3
LW
2331 s++;
2332 }
2333 *retlen = s - start;
2334 return retval;
2335}
760ac839 2336
11343788 2337#ifdef USE_THREADS
12ca11f6
MB
2338#ifdef FAKE_THREADS
2339/* Very simplistic scheduler for now */
2340void
2341schedule(void)
2342{
c7848ba1 2343 thr = thr->i.next_run;
12ca11f6
MB
2344}
2345
2346void
2347perl_cond_init(cp)
2348perl_cond *cp;
2349{
2350 *cp = 0;
2351}
2352
2353void
2354perl_cond_signal(cp)
2355perl_cond *cp;
2356{
51dd5992 2357 perl_os_thread t;
12ca11f6
MB
2358 perl_cond cond = *cp;
2359
2360 if (!cond)
2361 return;
2362 t = cond->thread;
2363 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB
2364 t->i.next_run = thr->i.next_run;
2365 thr->i.next_run->i.prev_run = t;
2366 t->i.prev_run = thr;
2367 thr->i.next_run = t;
2368 thr->i.wait_queue = 0;
12ca11f6
MB
2369 /* Remove from the wait queue */
2370 *cp = cond->next;
2371 Safefree(cond);
2372}
2373
2374void
2375perl_cond_broadcast(cp)
2376perl_cond *cp;
2377{
51dd5992 2378 perl_os_thread t;
12ca11f6
MB
2379 perl_cond cond, cond_next;
2380
2381 for (cond = *cp; cond; cond = cond_next) {
2382 t = cond->thread;
2383 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB
2384 t->i.next_run = thr->i.next_run;
2385 thr->i.next_run->i.prev_run = t;
2386 t->i.prev_run = thr;
2387 thr->i.next_run = t;
2388 thr->i.wait_queue = 0;
12ca11f6
MB
2389 /* Remove from the wait queue */
2390 cond_next = cond->next;
2391 Safefree(cond);
2392 }
2393 *cp = 0;
2394}
2395
2396void
2397perl_cond_wait(cp)
2398perl_cond *cp;
2399{
2400 perl_cond cond;
2401
c7848ba1 2402 if (thr->i.next_run == thr)
12ca11f6
MB
2403 croak("panic: perl_cond_wait called by last runnable thread");
2404
0f15f207 2405 New(666, cond, 1, struct perl_wait_queue);
12ca11f6
MB
2406 cond->thread = thr;
2407 cond->next = *cp;
2408 *cp = cond;
c7848ba1 2409 thr->i.wait_queue = cond;
12ca11f6 2410 /* Remove ourselves from runnable queue */
c7848ba1
MB
2411 thr->i.next_run->i.prev_run = thr->i.prev_run;
2412 thr->i.prev_run->i.next_run = thr->i.next_run;
12ca11f6
MB
2413}
2414#endif /* FAKE_THREADS */
2415
11343788 2416#ifdef OLD_PTHREADS_API
52e1cb5e 2417struct perl_thread *
11343788
MB
2418getTHR _((void))
2419{
2420 pthread_addr_t t;
2421
2422 if (pthread_getspecific(thr_key, &t))
2423 croak("panic: pthread_getspecific");
52e1cb5e 2424 return (struct perl_thread *) t;
11343788
MB
2425}
2426#endif /* OLD_PTHREADS_API */
f93b4edd
MB
2427
2428MAGIC *
8ac85365 2429condpair_magic(SV *sv)
f93b4edd
MB
2430{
2431 MAGIC *mg;
2432
2433 SvUPGRADE(sv, SVt_PVMG);
2434 mg = mg_find(sv, 'm');
2435 if (!mg) {
2436 condpair_t *cp;
2437
2438 New(53, cp, 1, condpair_t);
2439 MUTEX_INIT(&cp->mutex);
2440 COND_INIT(&cp->owner_cond);
2441 COND_INIT(&cp->cond);
2442 cp->owner = 0;
940cb80d 2443 LOCK_SV_MUTEX;
f93b4edd
MB
2444 mg = mg_find(sv, 'm');
2445 if (mg) {
2446 /* someone else beat us to initialising it */
940cb80d 2447 UNLOCK_SV_MUTEX;
f93b4edd
MB
2448 MUTEX_DESTROY(&cp->mutex);
2449 COND_DESTROY(&cp->owner_cond);
2450 COND_DESTROY(&cp->cond);
2451 Safefree(cp);
2452 }
2453 else {
2454 sv_magic(sv, Nullsv, 'm', 0, 0);
2455 mg = SvMAGIC(sv);
2456 mg->mg_ptr = (char *)cp;
2457 mg->mg_len = sizeof(cp);
940cb80d 2458 UNLOCK_SV_MUTEX;
bc1f4c86 2459 DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
c7848ba1 2460 "%p: condpair_magic %p\n", thr, sv));)
f93b4edd
MB
2461 }
2462 }
2463 return mg;
2464}
a863c7d1
MB
2465
2466/*
199100c8
MB
2467 * Make a new perl thread structure using t as a prototype. Some of the
2468 * fields for the new thread are copied from the prototype thread, t,
2469 * so t should not be running in perl at the time this function is
2470 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
2471 * thread calling new_struct_thread) clearly satisfies this constraint.
a863c7d1 2472 */
52e1cb5e
JH
2473struct perl_thread *
2474new_struct_thread(struct perl_thread *t)
a863c7d1 2475{
52e1cb5e 2476 struct perl_thread *thr;
a863c7d1 2477 SV *sv;
199100c8
MB
2478 SV **svp;
2479 I32 i;
2480
2481 sv = newSVpv("", 0);
52e1cb5e
JH
2482 SvGROW(sv, sizeof(struct perl_thread) + 1);
2483 SvCUR_set(sv, sizeof(struct perl_thread));
199100c8 2484 thr = (Thread) SvPVX(sv);
199100c8 2485 /* debug */
52e1cb5e 2486 memset(thr, 0xab, sizeof(struct perl_thread));
199100c8
MB
2487 markstack = 0;
2488 scopestack = 0;
2489 savestack = 0;
2490 retstack = 0;
2491 dirty = 0;
2492 localizing = 0;
2493 /* end debug */
2494
2495 thr->oursv = sv;
d55594ae 2496 init_stacks(ARGS);
a863c7d1 2497
a863c7d1 2498 curcop = &compiling;
199100c8 2499 thr->cvcache = newHV();
54b9620d 2500 thr->threadsv = newAV();
a863c7d1 2501 thr->specific = newAV();
38a03e6e
MB
2502 thr->errsv = newSVpv("", 0);
2503 thr->errhv = newHV();
a863c7d1
MB
2504 thr->flags = THRf_R_JOINABLE;
2505 MUTEX_INIT(&thr->mutex);
199100c8
MB
2506
2507 curcop = t->Tcurcop; /* XXX As good a guess as any? */
2508 defstash = t->Tdefstash; /* XXX maybe these should */
2509 curstash = t->Tcurstash; /* always be set to main? */
d55594ae
GS
2510
2511
2512 /* top_env needs to be non-zero. It points to an area
2513 in which longjmp() stuff is stored, as C callstack
2514 info there at least is thread specific this has to
2515 be per-thread. Otherwise a 'die' in a thread gives
2516 that thread the C stack of last thread to do an eval {}!
2517 See comments in scope.h
2518 Initialize top entry (as in perl.c for main thread)
2519 */
2520 start_env.je_prev = NULL;
2521 start_env.je_ret = -1;
2522 start_env.je_mustcatch = TRUE;
2523 top_env = &start_env;
2524
199100c8
MB
2525 in_eval = FALSE;
2526 restartop = 0;
2527
2528 tainted = t->Ttainted;
2529 curpm = t->Tcurpm; /* XXX No PMOP ref count */
2530 nrs = newSVsv(t->Tnrs);
2531 rs = newSVsv(t->Trs);
2532 last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv);
2533 ofslen = t->Tofslen;
2534 ofs = savepvn(t->Tofs, ofslen);
2535 defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
2536 chopset = t->Tchopset;
2537 formtarget = newSVsv(t->Tformtarget);
2538 bodytarget = newSVsv(t->Tbodytarget);
2539 toptarget = newSVsv(t->Ttoptarget);
2540
54b9620d
MB
2541 /* Initialise all per-thread SVs that the template thread used */
2542 svp = AvARRAY(t->threadsv);
93965878 2543 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
199100c8
MB
2544 if (*svp && *svp != &sv_undef) {
2545 SV *sv = newSVsv(*svp);
54b9620d
MB
2546 av_store(thr->threadsv, i, sv);
2547 sv_magic(sv, 0, 0, &threadsv_names[i], 1);
199100c8 2548 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
54b9620d 2549 "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
199100c8
MB
2550 }
2551 }
940cb80d 2552 thr->threadsvp = AvARRAY(thr->threadsv);
199100c8 2553
a863c7d1
MB
2554 MUTEX_LOCK(&threads_mutex);
2555 nthreads++;
199100c8
MB
2556 thr->tid = ++threadnum;
2557 thr->next = t->next;
2558 thr->prev = t;
2559 t->next = thr;
2560 thr->next->prev = thr;
a863c7d1
MB
2561 MUTEX_UNLOCK(&threads_mutex);
2562
2563#ifdef HAVE_THREAD_INTERN
2564 init_thread_intern(thr);
a863c7d1 2565#endif /* HAVE_THREAD_INTERN */
a863c7d1
MB
2566 return thr;
2567}
11343788 2568#endif /* USE_THREADS */
760ac839
LW
2569
2570#ifdef HUGE_VAL
2571/*
2572 * This hack is to force load of "huge" support from libm.a
2573 * So it is in perl for (say) POSIX to use.
2574 * Needed for SunOS with Sun's 'acc' for example.
2575 */
2576double
8ac85365 2577Perl_huge(void)
760ac839
LW
2578{
2579 return HUGE_VAL;
2580}
2581#endif
4e35701f 2582
22239a37
NIS
2583#ifdef PERL_GLOBAL_STRUCT
2584struct perl_vars *
2585Perl_GetVars(void)
2586{
2587 return &Perl_Vars;
2588}
31fb1209
NIS
2589#endif
2590
2591char **
2592get_op_names(void)
2593{
2594 return op_name;
2595}
2596
2597char **
2598get_op_descs(void)
2599{
2600 return op_desc;
2601}