This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix type mismatches in x2p's safe{alloc,realloc,free}.
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
a0d0e21e 3 * Copyright (c) 1991-1994, 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"
62b28dd9 17
6eb13c3b 18#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
a687059c 19#include <signal.h>
62b28dd9 20#endif
a687059c 21
bd4080b3 22/* XXX If this causes problems, set i_unistd=undef in the hint file. */
85e6fe83 23#ifdef I_UNISTD
8990e307
LW
24# include <unistd.h>
25#endif
26
a687059c
LW
27#ifdef I_VFORK
28# include <vfork.h>
29#endif
30
94b6baf5
AD
31/* Put this after #includes because fork and vfork prototypes may
32 conflict.
33*/
34#ifndef HAS_VFORK
35# define vfork fork
36#endif
37
fe14fcc3
LW
38#ifdef I_FCNTL
39# include <fcntl.h>
40#endif
41#ifdef I_SYS_FILE
42# include <sys/file.h>
43#endif
44
8d063cd8 45#define FLUSH
8d063cd8 46
a0d0e21e
LW
47#ifdef LEAKTEST
48static void xstat _((void));
49#endif
50
55497cff 51#ifndef MYMALLOC
de3bb511 52
8d063cd8
LW
53/* paranoid version of malloc */
54
a687059c
LW
55/* NOTE: Do not call the next three routines directly. Use the macros
56 * in handy.h, so that we can easily redefine everything to do tracking of
57 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 58 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW
59 */
60
bd4080b3 61Malloc_t
8d063cd8
LW
62safemalloc(size)
63MEM_SIZE size;
64{
bd4080b3 65 Malloc_t ptr;
55497cff 66#ifdef HAS_64K_LIMIT
62b28dd9 67 if (size > 0xffff) {
760ac839 68 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
79072805 69 my_exit(1);
62b28dd9 70 }
55497cff 71#endif /* HAS_64K_LIMIT */
34de22dd
LW
72#ifdef DEBUGGING
73 if ((long)size < 0)
463ee0b2 74 croak("panic: malloc");
34de22dd 75#endif
8d063cd8 76 ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
79072805 77#if !(defined(I286) || defined(atarist))
760ac839 78 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
79072805 79#else
760ac839 80 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
8d063cd8
LW
81#endif
82 if (ptr != Nullch)
83 return ptr;
7c0587c8
LW
84 else if (nomemok)
85 return Nullch;
8d063cd8 86 else {
760ac839 87 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
79072805 88 my_exit(1);
8d063cd8
LW
89 }
90 /*NOTREACHED*/
91}
92
93/* paranoid version of realloc */
94
bd4080b3 95Malloc_t
8d063cd8 96saferealloc(where,size)
bd4080b3 97Malloc_t where;
8d063cd8
LW
98MEM_SIZE size;
99{
bd4080b3 100 Malloc_t ptr;
ecfc5424 101#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
bd4080b3 102 Malloc_t realloc();
ecfc5424 103#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 104
55497cff 105#ifdef HAS_64K_LIMIT
62b28dd9 106 if (size > 0xffff) {
760ac839 107 PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH;
79072805 108 my_exit(1);
62b28dd9 109 }
55497cff 110#endif /* HAS_64K_LIMIT */
378cc40b 111 if (!where)
463ee0b2 112 croak("Null realloc");
34de22dd
LW
113#ifdef DEBUGGING
114 if ((long)size < 0)
463ee0b2 115 croak("panic: realloc");
34de22dd 116#endif
8d063cd8 117 ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
79072805
LW
118
119#if !(defined(I286) || defined(atarist))
120 DEBUG_m( {
760ac839
LW
121 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++);
122 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
79072805
LW
123 } )
124#else
125 DEBUG_m( {
760ac839
LW
126 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++);
127 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
79072805 128 } )
8d063cd8 129#endif
79072805 130
8d063cd8
LW
131 if (ptr != Nullch)
132 return ptr;
7c0587c8
LW
133 else if (nomemok)
134 return Nullch;
8d063cd8 135 else {
760ac839 136 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
79072805 137 my_exit(1);
8d063cd8
LW
138 }
139 /*NOTREACHED*/
140}
141
142/* safe version of free */
143
a687059c 144void
8d063cd8 145safefree(where)
bd4080b3 146Malloc_t where;
8d063cd8 147{
79072805 148#if !(defined(I286) || defined(atarist))
760ac839 149 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++));
79072805 150#else
760ac839 151 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++));
8d063cd8 152#endif
378cc40b 153 if (where) {
de3bb511 154 /*SUPPRESS 701*/
378cc40b
LW
155 free(where);
156 }
8d063cd8
LW
157}
158
1050c9ca
PP
159/* safe version of calloc */
160
bd4080b3 161Malloc_t
1050c9ca
PP
162safecalloc(count, size)
163MEM_SIZE count;
164MEM_SIZE size;
165{
bd4080b3 166 Malloc_t ptr;
1050c9ca 167
55497cff 168#ifdef HAS_64K_LIMIT
1050c9ca 169 if (size * count > 0xffff) {
760ac839 170 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH;
1050c9ca
PP
171 my_exit(1);
172 }
55497cff 173#endif /* HAS_64K_LIMIT */
1050c9ca
PP
174#ifdef DEBUGGING
175 if ((long)size < 0 || (long)count < 0)
176 croak("panic: calloc");
177#endif
178#if !(defined(I286) || defined(atarist))
760ac839 179 DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
1050c9ca 180#else
760ac839 181 DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
1050c9ca
PP
182#endif
183 size *= count;
184 ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
185 if (ptr != Nullch) {
186 memset((void*)ptr, 0, size);
187 return ptr;
188 }
189 else if (nomemok)
190 return Nullch;
191 else {
760ac839 192 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
1050c9ca
PP
193 my_exit(1);
194 }
195 /*NOTREACHED*/
196}
197
55497cff 198#endif /* !MYMALLOC */
de3bb511 199
a687059c
LW
200#ifdef LEAKTEST
201
202#define ALIGN sizeof(long)
8d063cd8 203
bd4080b3 204Malloc_t
a687059c 205safexmalloc(x,size)
79072805 206I32 x;
a687059c 207MEM_SIZE size;
8d063cd8 208{
bd4080b3 209 register Malloc_t where;
8d063cd8 210
a687059c
LW
211 where = safemalloc(size + ALIGN);
212 xcount[x]++;
213 where[0] = x % 100;
214 where[1] = x / 100;
215 return where + ALIGN;
8d063cd8 216}
8d063cd8 217
bd4080b3 218Malloc_t
a687059c 219safexrealloc(where,size)
bd4080b3 220Malloc_t where;
a687059c
LW
221MEM_SIZE size;
222{
bd4080b3 223 register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
a0d0e21e 224 return new + ALIGN;
a687059c
LW
225}
226
227void
228safexfree(where)
bd4080b3 229Malloc_t where;
a687059c 230{
79072805 231 I32 x;
a687059c
LW
232
233 if (!where)
234 return;
235 where -= ALIGN;
236 x = where[0] + 100 * where[1];
237 xcount[x]--;
238 safefree(where);
239}
240
bd4080b3 241Malloc_t
1050c9ca
PP
242safexcalloc(x,count,size)
243I32 x;
244MEM_SIZE count;
245MEM_SIZE size;
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
a687059c 258xstat()
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 *
a687059c 275cpytill(to,from,fromend,delim,retlen)
62b28dd9
LW
276register char *to;
277register char *from;
a687059c 278register char *fromend;
a0d0e21e 279register int delim;
79072805 280I32 *retlen;
8d063cd8 281{
a687059c
LW
282 char *origto = to;
283
284 for (; from < fromend; from++,to++) {
378cc40b
LW
285 if (*from == '\\') {
286 if (from[1] == delim)
287 from++;
288 else if (from[1] == '\\')
289 *to++ = *from++;
290 }
8d063cd8
LW
291 else if (*from == delim)
292 break;
293 *to = *from;
294 }
295 *to = '\0';
a687059c 296 *retlen = to - origto;
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 *
304instr(big, little)
378cc40b
LW
305register char *big;
306register char *little;
307{
308 register char *s, *x;
79072805 309 register I32 first;
378cc40b 310
a687059c
LW
311 if (!little)
312 return big;
313 first = *little++;
378cc40b
LW
314 if (!first)
315 return big;
316 while (*big) {
317 if (*big++ != first)
318 continue;
319 for (x=big,s=little; *s; /**/ ) {
320 if (!*x)
321 return Nullch;
322 if (*s++ != *x++) {
323 s--;
324 break;
325 }
326 }
327 if (!*s)
328 return big-1;
329 }
330 return Nullch;
331}
8d063cd8 332
a687059c
LW
333/* same as instr but allow embedded nulls */
334
335char *
336ninstr(big, bigend, little, lend)
337register char *big;
338register char *bigend;
339char *little;
340char *lend;
8d063cd8 341{
a687059c 342 register char *s, *x;
79072805 343 register I32 first = *little;
a687059c 344 register char *littleend = lend;
378cc40b 345
a0d0e21e 346 if (!first && little >= littleend)
a687059c 347 return big;
de3bb511
LW
348 if (bigend - big < littleend - little)
349 return Nullch;
a687059c
LW
350 bigend -= littleend - little++;
351 while (big <= bigend) {
352 if (*big++ != first)
353 continue;
354 for (x=big,s=little; s < littleend; /**/ ) {
355 if (*s++ != *x++) {
356 s--;
357 break;
358 }
359 }
360 if (s >= littleend)
361 return big-1;
378cc40b 362 }
a687059c
LW
363 return Nullch;
364}
365
366/* reverse of the above--find last substring */
367
368char *
369rninstr(big, bigend, little, lend)
370register char *big;
371char *bigend;
372char *little;
373char *lend;
374{
375 register char *bigbeg;
376 register char *s, *x;
79072805 377 register I32 first = *little;
a687059c
LW
378 register char *littleend = lend;
379
a0d0e21e 380 if (!first && little >= littleend)
a687059c
LW
381 return bigend;
382 bigbeg = big;
383 big = bigend - (littleend - little++);
384 while (big >= bigbeg) {
385 if (*big-- != first)
386 continue;
387 for (x=big+2,s=little; s < littleend; /**/ ) {
388 if (*s++ != *x++) {
389 s--;
390 break;
391 }
392 }
393 if (s >= littleend)
394 return big+1;
378cc40b 395 }
a687059c 396 return Nullch;
378cc40b 397}
a687059c 398
ef7eada9 399/* Initialize the fold[] array. */
55497cff 400void
ef7eada9
JH
401perl_init_fold()
402{
403 int i;
404
405 for (i = 0; i < 256; i++) {
406 if (isUPPER(i)) fold[i] = toLOWER(i);
407 else if (isLOWER(i)) fold[i] = toUPPER(i);
408 else fold[i] = i;
409 }
410}
411
f0c5b223
TB
412/* Initialize locale (and the fold[] array).*/
413int
1050c9ca 414perl_init_i18nl10n(printwarn)
f0c5b223
TB
415 int printwarn;
416{
417 int ok = 1;
418 /* returns
419 * 1 = set ok or not applicable,
420 * 0 = fallback to C locale,
421 * -1 = fallback to C locale failed
422 */
ef7eada9 423#if defined(HAS_SETLOCALE)
f0c5b223
TB
424 char * lc_all = getenv("LC_ALL");
425 char * lc_ctype = getenv("LC_CTYPE");
ef7eada9
JH
426 char * lc_collate = getenv("LC_COLLATE");
427 char * lang = getenv("LANG");
428 int setlocale_failure = 0;
429
430#define SETLOCALE_LC_CTYPE 0x01
431#define SETLOCALE_LC_COLLATE 0x02
432
433#ifdef LC_CTYPE
434 if (setlocale(LC_CTYPE, "") == 0)
435 setlocale_failure |= SETLOCALE_LC_CTYPE;
436#endif
f0c5b223 437
ef7eada9
JH
438#ifdef LC_COLLATE
439 if (setlocale(LC_COLLATE, "") == 0)
440 setlocale_failure |= SETLOCALE_LC_COLLATE;
441 else
442 lc_collate_active = 1;
443#endif
444
445 if (setlocale_failure && (lc_all || lang)) {
446 char *perl_badlang;
20cec16a
PP
447
448 if (printwarn > 1 ||
ef7eada9
JH
449 printwarn &&
450 (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) {
451
452 PerlIO_printf(PerlIO_stderr(),
453 "perl: warning: Setting locale failed for the categories:\n\t");
454#ifdef LC_CTYPE
455 if (setlocale_failure & SETLOCALE_LC_CTYPE)
456 PerlIO_printf(PerlIO_stderr(),
457 "LC_CTYPE ");
458#endif
459#ifdef LC_COLLATE
460 if (setlocale_failure & SETLOCALE_LC_COLLATE)
760ac839 461 PerlIO_printf(PerlIO_stderr(),
ef7eada9
JH
462 "LC_COLLATE ");
463#endif
464 PerlIO_printf(PerlIO_stderr(),
465 "\n");
466
467 PerlIO_printf(PerlIO_stderr(),
468 "perl: warning: Please check that your locale settings:\n");
469
470 PerlIO_printf(PerlIO_stderr(),
471 "\tLC_ALL = %c%s%c,\n",
472 lc_all ? '"' : '(',
473 lc_all ? lc_all : "unset",
474 lc_all ? '"' : ')'
f0c5b223 475 );
ef7eada9
JH
476#ifdef LC_CTYPE
477 if (setlocale_failure & SETLOCALE_LC_CTYPE)
478 PerlIO_printf(PerlIO_stderr(),
479 "\tLC_CTYPE = %c%s%c,\n",
480 lc_ctype ? '"' : '(',
481 lc_ctype ? lc_ctype : "unset",
482 lc_ctype ? '"' : ')'
483 );
484#endif
485#ifdef LC_COLLATE
486 if (setlocale_failure & SETLOCALE_LC_COLLATE)
487 PerlIO_printf(PerlIO_stderr(),
488 "\tLC_COLLATE = %c%s%c,\n",
489 lc_collate ? '"' : '(',
490 lc_collate ? lc_collate : "unset",
491 lc_collate ? '"' : ')'
492 );
493#endif
494 PerlIO_printf(PerlIO_stderr(),
495 "\tLANG = %c%s%c\n",
496 lang ? '"' : ')',
497 lang ? lang : "unset",
498 lang ? '"' : ')'
499 );
500
501 PerlIO_printf(PerlIO_stderr(),
502 " are supported and installed on your system.\n");
503
f0c5b223 504 ok = 0;
ef7eada9
JH
505
506 }
507#ifdef LC_ALL
508 if (setlocale_failure) {
509 PerlIO_printf(PerlIO_stderr(),
510 "perl: warning: Falling back to the \"C\" locale.\n");
511 if (setlocale(LC_ALL, "C") == NULL) {
f0c5b223 512 ok = -1;
ef7eada9
JH
513 PerlIO_printf(PerlIO_stderr(),
514 "perl: warning: Failed to fall back to the \"C\" locale.\n");
f0c5b223 515 }
f0c5b223 516 }
ef7eada9
JH
517#else
518 PerlIO_printf(PerlIO_stderr(),
519 "perl: warning: Cannot fall back to the \"C\" locale.\n");
f0c5b223 520#endif
ef7eada9
JH
521 }
522
523 if (setlocale_failure & SETLOCALE_LC_CTYPE == 0)
524 perl_init_fold();
525
526#endif /* #if defined(HAS_SETLOCALE) */
527
f0c5b223
TB
528 return ok;
529}
530
ef7eada9
JH
531char *
532mem_collxfrm(m, n, nx) /* mem_collxfrm() does strxfrm() for (data,size) */
533 const char *m; /* "strings", that is, transforms normal eight-bit */
534 const Size_t n; /* data into a format that can be memcmp()ed to get */
535 Size_t * nx; /* 'the right' result for each locale. */
536{ /* Uses strxfrm() but handles embedded NULs. */
537 char * mx = 0;
538
539#ifdef HAS_STRXFRM
540 Size_t ma;
541
542 /* the expansion factor of 16 has been seen with strxfrm() */
543 ma = (lc_collate_active ? 16 : 1) * n + 1;
544
545#define RENEW_mx() \
546 do { \
547 ma = 2 * ma + 1; \
548 Renew(mx, ma, char); \
549 if (mx == 0) \
550 goto out; \
551 } while (0)
552
553 New(171, mx, ma, char);
554
555 if (mx) {
556 Size_t xc, dx;
557 int xok;
558
559 for (*nx = 0, xc = 0; xc < n; ) {
560 if (m[xc] == 0)
561 do {
562 if (*nx == ma)
563 RENEW_mx();
564 mx[*nx++] = m[xc++];
565 } while (xc < n && m[xc] == 0);
566 else {
567 do {
568 dx = strxfrm(mx + *nx, m + xc, ma - *nx);
569 if (dx + *nx > ma) {
570 RENEW_mx();
571 xok = 0;
572 } else
573 xok = 1;
574 } while (!xok);
575 xc += strlen(mx + *nx);
576 *nx += dx;
577 }
578 }
579 }
580
581out:
582
583#endif /* HAS_STRXFRM */
584
585 return mx;
586}
587
378cc40b 588void
79072805
LW
589fbm_compile(sv, iflag)
590SV *sv;
591I32 iflag;
378cc40b 592{
a687059c
LW
593 register unsigned char *s;
594 register unsigned char *table;
79072805
LW
595 register U32 i;
596 register U32 len = SvCUR(sv);
597 I32 rarest = 0;
598 U32 frequency = 256;
599
748a9306
LW
600 if (len > 255)
601 return; /* can't have offsets that big */
79072805 602 Sv_Grow(sv,len+258);
463ee0b2 603 table = (unsigned char*)(SvPVX(sv) + len + 1);
a687059c
LW
604 s = table - 2;
605 for (i = 0; i < 256; i++) {
378cc40b
LW
606 table[i] = len;
607 }
608 i = 0;
463ee0b2 609 while (s >= (unsigned char*)(SvPVX(sv)))
a687059c
LW
610 {
611 if (table[*s] == len) {
612#ifndef pdp11
613 if (iflag)
614 table[*s] = table[fold[*s]] = i;
615#else
616 if (iflag) {
79072805 617 I32 j;
a687059c
LW
618 j = fold[*s];
619 table[j] = i;
620 table[*s] = i;
621 }
622#endif /* pdp11 */
623 else
624 table[*s] = i;
625 }
378cc40b
LW
626 s--,i++;
627 }
79072805 628 sv_upgrade(sv, SVt_PVBM);
a0d0e21e 629 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
79072805 630 SvVALID_on(sv);
378cc40b 631
463ee0b2 632 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
a687059c 633 if (iflag) {
79072805
LW
634 register U32 tmp, foldtmp;
635 SvCASEFOLD_on(sv);
a687059c
LW
636 for (i = 0; i < len; i++) {
637 tmp=freq[s[i]];
638 foldtmp=freq[fold[s[i]]];
639 if (tmp < frequency && foldtmp < frequency) {
640 rarest = i;
641 /* choose most frequent among the two */
642 frequency = (tmp > foldtmp) ? tmp : foldtmp;
643 }
644 }
645 }
646 else {
647 for (i = 0; i < len; i++) {
648 if (freq[s[i]] < frequency) {
649 rarest = i;
650 frequency = freq[s[i]];
651 }
378cc40b
LW
652 }
653 }
79072805
LW
654 BmRARE(sv) = s[rarest];
655 BmPREVIOUS(sv) = rarest;
760ac839 656 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
378cc40b
LW
657}
658
378cc40b 659char *
79072805 660fbm_instr(big, bigend, littlestr)
a687059c
LW
661unsigned char *big;
662register unsigned char *bigend;
79072805 663SV *littlestr;
378cc40b 664{
a687059c 665 register unsigned char *s;
79072805
LW
666 register I32 tmp;
667 register I32 littlelen;
a687059c
LW
668 register unsigned char *little;
669 register unsigned char *table;
670 register unsigned char *olds;
671 register unsigned char *oldlittle;
378cc40b 672
79072805 673 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
a0d0e21e
LW
674 STRLEN len;
675 char *l = SvPV(littlestr,len);
676 if (!len)
d48672a2 677 return (char*)big;
a0d0e21e 678 return ninstr((char*)big,(char*)bigend, l, l + len);
d48672a2 679 }
378cc40b 680
79072805
LW
681 littlelen = SvCUR(littlestr);
682 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
0f85fab0
LW
683 if (littlelen > bigend - big)
684 return Nullch;
463ee0b2 685 little = (unsigned char*)SvPVX(littlestr);
79072805 686 if (SvCASEFOLD(littlestr)) { /* oops, fake it */
a687059c
LW
687 big = bigend - littlelen; /* just start near end */
688 if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
689 big--;
378cc40b
LW
690 }
691 else {
a687059c 692 s = bigend - littlelen;
bd4080b3 693 if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
a687059c 694 return (char*)s; /* how sweet it is */
34de22dd
LW
695 else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
696 && s > big) {
a687059c 697 s--;
bd4080b3 698 if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
a687059c
LW
699 return (char*)s;
700 }
701 return Nullch;
702 }
703 }
463ee0b2 704 table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
62b28dd9
LW
705 if (--littlelen >= bigend - big)
706 return Nullch;
707 s = big + littlelen;
a687059c 708 oldlittle = little = table - 2;
79072805 709 if (SvCASEFOLD(littlestr)) { /* case insensitive? */
20188a90 710 if (s < bigend) {
a687059c 711 top1:
de3bb511 712 /*SUPPRESS 560*/
a687059c 713 if (tmp = table[*s]) {
62b28dd9
LW
714#ifdef POINTERRIGOR
715 if (bigend - s > tmp) {
716 s += tmp;
717 goto top1;
718 }
719#else
720 if ((s += tmp) < bigend)
721 goto top1;
722#endif
723 return Nullch;
a687059c
LW
724 }
725 else {
726 tmp = littlelen; /* less expensive than calling strncmp() */
727 olds = s;
728 while (tmp--) {
729 if (*--s == *--little || fold[*s] == *little)
730 continue;
731 s = olds + 1; /* here we pay the price for failure */
732 little = oldlittle;
733 if (s < bigend) /* fake up continue to outer loop */
734 goto top1;
735 return Nullch;
736 }
a687059c 737 return (char *)s;
a687059c
LW
738 }
739 }
740 }
741 else {
20188a90 742 if (s < bigend) {
a687059c 743 top2:
de3bb511 744 /*SUPPRESS 560*/
a687059c 745 if (tmp = table[*s]) {
62b28dd9
LW
746#ifdef POINTERRIGOR
747 if (bigend - s > tmp) {
748 s += tmp;
749 goto top2;
750 }
751#else
752 if ((s += tmp) < bigend)
753 goto top2;
754#endif
755 return Nullch;
a687059c
LW
756 }
757 else {
758 tmp = littlelen; /* less expensive than calling strncmp() */
759 olds = s;
760 while (tmp--) {
761 if (*--s == *--little)
762 continue;
763 s = olds + 1; /* here we pay the price for failure */
764 little = oldlittle;
765 if (s < bigend) /* fake up continue to outer loop */
766 goto top2;
767 return Nullch;
768 }
a687059c 769 return (char *)s;
378cc40b 770 }
378cc40b
LW
771 }
772 }
773 return Nullch;
774}
775
776char *
777screaminstr(bigstr, littlestr)
79072805
LW
778SV *bigstr;
779SV *littlestr;
378cc40b 780{
a687059c
LW
781 register unsigned char *s, *x;
782 register unsigned char *big;
79072805
LW
783 register I32 pos;
784 register I32 previous;
785 register I32 first;
a687059c
LW
786 register unsigned char *little;
787 register unsigned char *bigend;
788 register unsigned char *littleend;
378cc40b 789
79072805 790 if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
378cc40b 791 return Nullch;
463ee0b2 792 little = (unsigned char *)(SvPVX(littlestr));
79072805 793 littleend = little + SvCUR(littlestr);
378cc40b 794 first = *little++;
79072805 795 previous = BmPREVIOUS(littlestr);
463ee0b2 796 big = (unsigned char *)(SvPVX(bigstr));
79072805 797 bigend = big + SvCUR(bigstr);
378cc40b
LW
798 while (pos < previous) {
799 if (!(pos += screamnext[pos]))
800 return Nullch;
801 }
de3bb511 802#ifdef POINTERRIGOR
79072805 803 if (SvCASEFOLD(littlestr)) { /* case insignificant? */
a687059c 804 do {
988174c1
LW
805 if (big[pos-previous] != first && big[pos-previous] != fold[first])
806 continue;
de3bb511
LW
807 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
808 if (x >= bigend)
809 return Nullch;
810 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
811 s--;
812 break;
813 }
814 }
815 if (s == littleend)
de3bb511 816 return (char *)(big+pos-previous);
de3bb511 817 } while (
de3bb511 818 pos += screamnext[pos] /* does this goof up anywhere? */
de3bb511
LW
819 );
820 }
821 else {
822 do {
988174c1
LW
823 if (big[pos-previous] != first)
824 continue;
de3bb511
LW
825 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
826 if (x >= bigend)
827 return Nullch;
828 if (*s++ != *x++) {
829 s--;
830 break;
831 }
832 }
833 if (s == littleend)
de3bb511 834 return (char *)(big+pos-previous);
79072805 835 } while ( pos += screamnext[pos] );
de3bb511
LW
836 }
837#else /* !POINTERRIGOR */
838 big -= previous;
79072805 839 if (SvCASEFOLD(littlestr)) { /* case insignificant? */
de3bb511 840 do {
988174c1
LW
841 if (big[pos] != first && big[pos] != fold[first])
842 continue;
a687059c
LW
843 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
844 if (x >= bigend)
845 return Nullch;
846 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
847 s--;
848 break;
849 }
850 }
851 if (s == littleend)
a687059c 852 return (char *)(big+pos);
a687059c 853 } while (
a687059c 854 pos += screamnext[pos] /* does this goof up anywhere? */
a687059c
LW
855 );
856 }
857 else {
858 do {
988174c1
LW
859 if (big[pos] != first)
860 continue;
a687059c
LW
861 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
862 if (x >= bigend)
863 return Nullch;
864 if (*s++ != *x++) {
865 s--;
866 break;
867 }
378cc40b 868 }
a687059c 869 if (s == littleend)
a687059c 870 return (char *)(big+pos);
a687059c 871 } while (
a687059c 872 pos += screamnext[pos]
a687059c
LW
873 );
874 }
de3bb511 875#endif /* POINTERRIGOR */
8d063cd8
LW
876 return Nullch;
877}
878
79072805
LW
879I32
880ibcmp(a,b,len)
a0d0e21e
LW
881register U8 *a;
882register U8 *b;
79072805
LW
883register I32 len;
884{
885 while (len--) {
886 if (*a == *b) {
887 a++,b++;
888 continue;
889 }
890 if (fold[*a++] == *b++)
891 continue;
892 return 1;
893 }
894 return 0;
895}
896
8d063cd8
LW
897/* copy a string to a safe spot */
898
899char *
a0d0e21e 900savepv(sv)
79072805 901char *sv;
8d063cd8 902{
a687059c 903 register char *newaddr;
8d063cd8 904
79072805
LW
905 New(902,newaddr,strlen(sv)+1,char);
906 (void)strcpy(newaddr,sv);
8d063cd8
LW
907 return newaddr;
908}
909
a687059c
LW
910/* same thing but with a known length */
911
912char *
a0d0e21e 913savepvn(sv, len)
79072805
LW
914char *sv;
915register I32 len;
a687059c
LW
916{
917 register char *newaddr;
918
919 New(903,newaddr,len+1,char);
79072805 920 Copy(sv,newaddr,len,char); /* might not be null terminated */
a687059c
LW
921 newaddr[len] = '\0'; /* is now */
922 return newaddr;
923}
924
a0d0e21e 925#if !defined(I_STDARG) && !defined(I_VARARGS)
8d063cd8 926
8990e307
LW
927/*
928 * Fallback on the old hackers way of doing varargs
929 */
8d063cd8 930
378cc40b 931/*VARARGS1*/
7c0587c8 932char *
378cc40b
LW
933mess(pat,a1,a2,a3,a4)
934char *pat;
a687059c 935long a1, a2, a3, a4;
378cc40b
LW
936{
937 char *s;
f0c5b223 938 char *s_start;
79072805
LW
939 I32 usermess = strEQ(pat,"%s");
940 SV *tmpstr;
378cc40b 941
f0c5b223 942 s = s_start = buf;
de3bb511 943 if (usermess) {
8990e307 944 tmpstr = sv_newmortal();
79072805 945 sv_setpv(tmpstr, (char*)a1);
463ee0b2 946 *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
de3bb511
LW
947 }
948 else {
949 (void)sprintf(s,pat,a1,a2,a3,a4);
950 s += strlen(s);
951 }
952
378cc40b 953 if (s[-1] != '\n') {
2304df62
AD
954 if (dirty)
955 strcpy(s, " during global destruction.\n");
956 else {
957 if (curcop->cop_line) {
958 (void)sprintf(s," at %s line %ld",
959 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
960 s += strlen(s);
961 }
a0d0e21e
LW
962 if (GvIO(last_in_gv) &&
963 IoLINES(GvIOp(last_in_gv)) ) {
2304df62
AD
964 (void)sprintf(s,", <%s> %s %ld",
965 last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
966 strEQ(rs,"\n") ? "line" : "chunk",
a0d0e21e 967 (long)IoLINES(GvIOp(last_in_gv)));
2304df62
AD
968 s += strlen(s);
969 }
970 (void)strcpy(s,".\n");
f0c5b223 971 s += 2;
378cc40b 972 }
de3bb511 973 if (usermess)
79072805 974 sv_catpv(tmpstr,buf+1);
378cc40b 975 }
f0c5b223
TB
976
977 if (s - s_start >= sizeof(buf)) { /* Ooops! */
978 if (usermess)
760ac839 979 PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
f0c5b223 980 else
760ac839
LW
981 PerlIO_puts(PerlIO_stderr(), buf);
982 PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n");
f0c5b223
TB
983 my_exit(1);
984 }
de3bb511 985 if (usermess)
463ee0b2 986 return SvPVX(tmpstr);
de3bb511
LW
987 else
988 return buf;
378cc40b
LW
989}
990
8d063cd8 991/*VARARGS1*/
463ee0b2 992void croak(pat,a1,a2,a3,a4)
8d063cd8 993char *pat;
a687059c 994long a1, a2, a3, a4;
8d063cd8 995{
9f68db38 996 char *tmps;
de3bb511 997 char *message;
748a9306
LW
998 HV *stash;
999 GV *gv;
1000 CV *cv;
8d063cd8 1001
de3bb511 1002 message = mess(pat,a1,a2,a3,a4);
20cec16a
PP
1003 if (diehook) {
1004 SV *olddiehook = diehook;
1005 diehook = Nullsv; /* sv_2cv might call croak() */
1006 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1007 diehook = olddiehook;
1008 if (cv && !CvDEPTH(cv)) {
1009 dSP;
1010
1011 PUSHMARK(sp);
1012 EXTEND(sp, 1);
1013 PUSHs(sv_2mortal(newSVpv(message,0)));
1014 PUTBACK;
1015 perl_call_sv((SV*)cv, G_DISCARD);
1016 }
748a9306 1017 }
a0d0e21e
LW
1018 if (in_eval) {
1019 restartop = die_where(message);
a5f75d66 1020 Siglongjmp(top_env, 3);
a0d0e21e 1021 }
760ac839
LW
1022 PerlIO_puts(PerlIO_stderr(),message);
1023 (void)PerlIO_flush(PerlIO_stderr());
38cd9116
PP
1024 if (e_tmpname) {
1025 if (e_fp) {
760ac839 1026 PerlIO_close(e_fp);
38cd9116
PP
1027 e_fp = Nullfp;
1028 }
a687059c 1029 (void)UNLINK(e_tmpname);
38cd9116
PP
1030 Safefree(e_tmpname);
1031 e_tmpname = Nullch;
f0c5b223 1032 }
748a9306
LW
1033 statusvalue = SHIFTSTATUS(statusvalue);
1034#ifdef VMS
1035 my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
1036#else
1037 my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1038#endif
378cc40b
LW
1039}
1040
1041/*VARARGS1*/
7c0587c8 1042void warn(pat,a1,a2,a3,a4)
378cc40b 1043char *pat;
a687059c 1044long a1, a2, a3, a4;
378cc40b 1045{
de3bb511 1046 char *message;
748a9306
LW
1047 SV *sv;
1048 HV *stash;
1049 GV *gv;
1050 CV *cv;
de3bb511
LW
1051
1052 message = mess(pat,a1,a2,a3,a4);
20cec16a
PP
1053 if (warnhook) {
1054 SV *oldwarnhook = warnhook;
1055 warnhook = Nullsv; /* sv_2cv might end up calling warn() */
1056 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1057 warnhook = oldwarnhook;
1058 if (cv && !CvDEPTH(cv)) {
1059 dSP;
1060
1061 PUSHMARK(sp);
1062 EXTEND(sp, 1);
1063 PUSHs(sv_2mortal(newSVpv(message,0)));
1064 PUTBACK;
1065 perl_call_sv((SV*)cv, G_DISCARD);
1066 return;
1067 }
748a9306 1068 }
20cec16a 1069 PerlIO_puts(PerlIO_stderr(),message);
a687059c 1070#ifdef LEAKTEST
20cec16a 1071 DEBUG_L(xstat());
a687059c 1072#endif
20cec16a 1073 (void)PerlIO_flush(PerlIO_stderr());
8d063cd8 1074}
8990e307 1075
a0d0e21e 1076#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
8990e307 1077
a0d0e21e 1078#ifdef I_STDARG
8990e307 1079char *
2304df62 1080mess(char *pat, va_list *args)
a687059c
LW
1081#else
1082/*VARARGS0*/
de3bb511 1083char *
8990e307 1084mess(pat, args)
a687059c 1085 char *pat;
2304df62 1086 va_list *args;
8990e307
LW
1087#endif
1088{
a687059c 1089 char *s;
f0c5b223 1090 char *s_start;
79072805
LW
1091 SV *tmpstr;
1092 I32 usermess;
d48672a2 1093#ifndef HAS_VPRINTF
85e6fe83 1094#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1095 char *vsprintf();
1096#else
79072805 1097 I32 vsprintf();
a687059c 1098#endif
d48672a2 1099#endif
a687059c 1100
f0c5b223 1101 s = s_start = buf;
de3bb511
LW
1102 usermess = strEQ(pat, "%s");
1103 if (usermess) {
8990e307 1104 tmpstr = sv_newmortal();
2304df62 1105 sv_setpv(tmpstr, va_arg(*args, char *));
463ee0b2 1106 *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
de3bb511
LW
1107 }
1108 else {
2304df62 1109 (void) vsprintf(s,pat,*args);
de3bb511
LW
1110 s += strlen(s);
1111 }
2304df62 1112 va_end(*args);
a687059c 1113
a687059c 1114 if (s[-1] != '\n') {
2304df62
AD
1115 if (dirty)
1116 strcpy(s, " during global destruction.\n");
1117 else {
1118 if (curcop->cop_line) {
1119 (void)sprintf(s," at %s line %ld",
1120 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
1121 s += strlen(s);
1122 }
c07a80fd
PP
1123 if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
1124 bool line_mode = (RsSIMPLE(rs) &&
1125 SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
2304df62
AD
1126 (void)sprintf(s,", <%s> %s %ld",
1127 last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
c07a80fd 1128 line_mode ? "line" : "chunk",
a0d0e21e 1129 (long)IoLINES(GvIOp(last_in_gv)));
2304df62
AD
1130 s += strlen(s);
1131 }
1132 (void)strcpy(s,".\n");
f0c5b223 1133 s += 2;
a687059c 1134 }
de3bb511 1135 if (usermess)
79072805 1136 sv_catpv(tmpstr,buf+1);
a687059c 1137 }
de3bb511 1138
f0c5b223
TB
1139 if (s - s_start >= sizeof(buf)) { /* Ooops! */
1140 if (usermess)
760ac839 1141 PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
f0c5b223 1142 else
760ac839
LW
1143 PerlIO_puts(PerlIO_stderr(), buf);
1144 PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
f0c5b223
TB
1145 my_exit(1);
1146 }
de3bb511 1147 if (usermess)
463ee0b2 1148 return SvPVX(tmpstr);
de3bb511
LW
1149 else
1150 return buf;
a687059c
LW
1151}
1152
ecfc5424 1153#ifdef I_STDARG
79072805 1154void
8990e307 1155croak(char* pat, ...)
463ee0b2 1156#else
8990e307
LW
1157/*VARARGS0*/
1158void
1159croak(pat, va_alist)
1160 char *pat;
1161 va_dcl
463ee0b2 1162#endif
a687059c
LW
1163{
1164 va_list args;
de3bb511 1165 char *message;
748a9306
LW
1166 HV *stash;
1167 GV *gv;
1168 CV *cv;
a687059c 1169
a0d0e21e 1170#ifdef I_STDARG
8990e307
LW
1171 va_start(args, pat);
1172#else
a687059c 1173 va_start(args);
8990e307 1174#endif
2304df62 1175 message = mess(pat, &args);
a687059c 1176 va_end(args);
20cec16a
PP
1177 if (diehook) {
1178 SV *olddiehook = diehook;
1179 diehook = Nullsv; /* sv_2cv might call croak() */
1180 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1181 diehook = olddiehook;
1182 if (cv && !CvDEPTH(cv)) {
1183 dSP;
1184
1185 PUSHMARK(sp);
1186 EXTEND(sp, 1);
1187 PUSHs(sv_2mortal(newSVpv(message,0)));
1188 PUTBACK;
1189 perl_call_sv((SV*)cv, G_DISCARD);
1190 }
748a9306 1191 }
a0d0e21e
LW
1192 if (in_eval) {
1193 restartop = die_where(message);
a5f75d66 1194 Siglongjmp(top_env, 3);
a0d0e21e 1195 }
760ac839
LW
1196 PerlIO_puts(PerlIO_stderr(),message);
1197 (void)PerlIO_flush(PerlIO_stderr());
38cd9116
PP
1198 if (e_tmpname) {
1199 if (e_fp) {
760ac839 1200 PerlIO_close(e_fp);
38cd9116
PP
1201 e_fp = Nullfp;
1202 }
a687059c 1203 (void)UNLINK(e_tmpname);
38cd9116
PP
1204 Safefree(e_tmpname);
1205 e_tmpname = Nullch;
f0c5b223 1206 }
748a9306
LW
1207 statusvalue = SHIFTSTATUS(statusvalue);
1208#ifdef VMS
1209 my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
1210#else
1211 my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1212#endif
a687059c
LW
1213}
1214
8990e307 1215void
ecfc5424 1216#ifdef I_STDARG
8990e307 1217warn(char* pat,...)
463ee0b2 1218#else
8990e307
LW
1219/*VARARGS0*/
1220warn(pat,va_alist)
1221 char *pat;
1222 va_dcl
463ee0b2 1223#endif
a687059c
LW
1224{
1225 va_list args;
de3bb511 1226 char *message;
748a9306
LW
1227 HV *stash;
1228 GV *gv;
1229 CV *cv;
a687059c 1230
a0d0e21e 1231#ifdef I_STDARG
8990e307
LW
1232 va_start(args, pat);
1233#else
a687059c 1234 va_start(args);
8990e307 1235#endif
2304df62 1236 message = mess(pat, &args);
a687059c
LW
1237 va_end(args);
1238
20cec16a
PP
1239 if (warnhook) {
1240 SV *oldwarnhook = warnhook;
1241 warnhook = Nullsv; /* sv_2cv might end up calling warn() */
1242 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1243 warnhook = oldwarnhook;
1244 if (cv && !CvDEPTH(cv)) {
1245 dSP;
1246
1247 PUSHMARK(sp);
1248 EXTEND(sp, 1);
1249 PUSHs(sv_2mortal(newSVpv(message,0)));
1250 PUTBACK;
1251 perl_call_sv((SV*)cv, G_DISCARD);
1252 return;
1253 }
748a9306 1254 }
20cec16a 1255 PerlIO_puts(PerlIO_stderr(),message);
a687059c 1256#ifdef LEAKTEST
20cec16a 1257 DEBUG_L(xstat());
a687059c 1258#endif
20cec16a 1259 (void)PerlIO_flush(PerlIO_stderr());
a687059c 1260}
a0d0e21e 1261#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
8d063cd8 1262
a0d0e21e 1263#ifndef VMS /* VMS' my_setenv() is in VMS.c */
8d063cd8 1264void
7c0587c8 1265my_setenv(nam,val)
8d063cd8
LW
1266char *nam, *val;
1267{
79072805 1268 register I32 i=setenv_getix(nam); /* where does it go? */
8d063cd8 1269
fe14fcc3 1270 if (environ == origenviron) { /* need we copy environment? */
79072805
LW
1271 I32 j;
1272 I32 max;
fe14fcc3
LW
1273 char **tmpenv;
1274
de3bb511 1275 /*SUPPRESS 530*/
fe14fcc3
LW
1276 for (max = i; environ[max]; max++) ;
1277 New(901,tmpenv, max+2, char*);
1278 for (j=0; j<max; j++) /* copy environment */
a0d0e21e 1279 tmpenv[j] = savepv(environ[j]);
fe14fcc3
LW
1280 tmpenv[max] = Nullch;
1281 environ = tmpenv; /* tell exec where it is now */
1282 }
a687059c
LW
1283 if (!val) {
1284 while (environ[i]) {
1285 environ[i] = environ[i+1];
1286 i++;
1287 }
1288 return;
1289 }
8d063cd8 1290 if (!environ[i]) { /* does not exist yet */
fe14fcc3 1291 Renew(environ, i+2, char*); /* just expand it a bit */
8d063cd8
LW
1292 environ[i+1] = Nullch; /* make sure it's null terminated */
1293 }
fe14fcc3
LW
1294 else
1295 Safefree(environ[i]);
a687059c 1296 New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
62b28dd9 1297#ifndef MSDOS
a687059c 1298 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
62b28dd9
LW
1299#else
1300 /* MS-DOS requires environment variable names to be in uppercase */
fe14fcc3
LW
1301 /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1302 * some utilities and applications may break because they only look
1303 * for upper case strings. (Fixed strupr() bug here.)]
1304 */
1305 strcpy(environ[i],nam); strupr(environ[i]);
62b28dd9
LW
1306 (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1307#endif /* MSDOS */
8d063cd8
LW
1308}
1309
79072805
LW
1310I32
1311setenv_getix(nam)
8d063cd8
LW
1312char *nam;
1313{
79072805 1314 register I32 i, len = strlen(nam);
8d063cd8
LW
1315
1316 for (i = 0; environ[i]; i++) {
1317 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1318 break; /* strnEQ must come first to avoid */
1319 } /* potential SEGV's */
1320 return i;
1321}
a0d0e21e 1322#endif /* !VMS */
378cc40b 1323
16d20bd9 1324#ifdef UNLINK_ALL_VERSIONS
79072805 1325I32
378cc40b
LW
1326unlnk(f) /* unlink all versions of a file */
1327char *f;
1328{
79072805 1329 I32 i;
378cc40b
LW
1330
1331 for (i = 0; unlink(f) >= 0; i++) ;
1332 return i ? 0 : -1;
1333}
1334#endif
1335
85e6fe83 1336#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
378cc40b 1337char *
7c0587c8 1338my_bcopy(from,to,len)
378cc40b
LW
1339register char *from;
1340register char *to;
79072805 1341register I32 len;
378cc40b
LW
1342{
1343 char *retval = to;
1344
7c0587c8
LW
1345 if (from - to >= 0) {
1346 while (len--)
1347 *to++ = *from++;
1348 }
1349 else {
1350 to += len;
1351 from += len;
1352 while (len--)
faf8582f 1353 *(--to) = *(--from);
7c0587c8 1354 }
378cc40b
LW
1355 return retval;
1356}
ffed7fef 1357#endif
378cc40b 1358
7c0587c8 1359#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1360char *
7c0587c8 1361my_bzero(loc,len)
378cc40b 1362register char *loc;
79072805 1363register I32 len;
378cc40b
LW
1364{
1365 char *retval = loc;
1366
1367 while (len--)
1368 *loc++ = 0;
1369 return retval;
1370}
1371#endif
7c0587c8
LW
1372
1373#ifndef HAS_MEMCMP
79072805 1374I32
7c0587c8
LW
1375my_memcmp(s1,s2,len)
1376register unsigned char *s1;
1377register unsigned char *s2;
79072805 1378register I32 len;
7c0587c8 1379{
79072805 1380 register I32 tmp;
7c0587c8
LW
1381
1382 while (len--) {
1383 if (tmp = *s1++ - *s2++)
1384 return tmp;
1385 }
1386 return 0;
1387}
1388#endif /* HAS_MEMCMP */
a687059c 1389
4633a7c4 1390#if defined(I_STDARG) || defined(I_VARARGS)
fe14fcc3 1391#ifndef HAS_VPRINTF
a687059c 1392
85e6fe83 1393#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1394char *
1395#else
1396int
1397#endif
1398vsprintf(dest, pat, args)
1399char *dest, *pat, *args;
1400{
1401 FILE fakebuf;
1402
1403 fakebuf._ptr = dest;
1404 fakebuf._cnt = 32767;
35c8bce7
LW
1405#ifndef _IOSTRG
1406#define _IOSTRG 0
1407#endif
a687059c
LW
1408 fakebuf._flag = _IOWRT|_IOSTRG;
1409 _doprnt(pat, args, &fakebuf); /* what a kludge */
1410 (void)putc('\0', &fakebuf);
85e6fe83 1411#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1412 return(dest);
1413#else
1414 return 0; /* perl doesn't use return value */
1415#endif
1416}
1417
fe14fcc3 1418#endif /* HAS_VPRINTF */
4633a7c4 1419#endif /* I_VARARGS || I_STDARGS */
a687059c
LW
1420
1421#ifdef MYSWAP
ffed7fef 1422#if BYTEORDER != 0x4321
a687059c 1423short
748a9306 1424#ifndef CAN_PROTOTYPE
a687059c
LW
1425my_swap(s)
1426short s;
748a9306
LW
1427#else
1428my_swap(short s)
1429#endif
a687059c
LW
1430{
1431#if (BYTEORDER & 1) == 0
1432 short result;
1433
1434 result = ((s & 255) << 8) + ((s >> 8) & 255);
1435 return result;
1436#else
1437 return s;
1438#endif
1439}
1440
1441long
748a9306
LW
1442#ifndef CAN_PROTOTYPE
1443my_htonl(l)
a687059c 1444register long l;
748a9306
LW
1445#else
1446my_htonl(long l)
1447#endif
a687059c
LW
1448{
1449 union {
1450 long result;
ffed7fef 1451 char c[sizeof(long)];
a687059c
LW
1452 } u;
1453
ffed7fef 1454#if BYTEORDER == 0x1234
a687059c
LW
1455 u.c[0] = (l >> 24) & 255;
1456 u.c[1] = (l >> 16) & 255;
1457 u.c[2] = (l >> 8) & 255;
1458 u.c[3] = l & 255;
1459 return u.result;
1460#else
ffed7fef 1461#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
463ee0b2 1462 croak("Unknown BYTEORDER\n");
a687059c 1463#else
79072805
LW
1464 register I32 o;
1465 register I32 s;
a687059c 1466
ffed7fef
LW
1467 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1468 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW
1469 }
1470 return u.result;
1471#endif
1472#endif
1473}
1474
1475long
748a9306
LW
1476#ifndef CAN_PROTOTYPE
1477my_ntohl(l)
a687059c 1478register long l;
748a9306
LW
1479#else
1480my_ntohl(long l)
1481#endif
a687059c
LW
1482{
1483 union {
1484 long l;
ffed7fef 1485 char c[sizeof(long)];
a687059c
LW
1486 } u;
1487
ffed7fef 1488#if BYTEORDER == 0x1234
a687059c
LW
1489 u.c[0] = (l >> 24) & 255;
1490 u.c[1] = (l >> 16) & 255;
1491 u.c[2] = (l >> 8) & 255;
1492 u.c[3] = l & 255;
1493 return u.l;
1494#else
ffed7fef 1495#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
463ee0b2 1496 croak("Unknown BYTEORDER\n");
a687059c 1497#else
79072805
LW
1498 register I32 o;
1499 register I32 s;
a687059c
LW
1500
1501 u.l = l;
1502 l = 0;
ffed7fef
LW
1503 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1504 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW
1505 }
1506 return l;
1507#endif
1508#endif
1509}
1510
ffed7fef 1511#endif /* BYTEORDER != 0x4321 */
988174c1
LW
1512#endif /* MYSWAP */
1513
1514/*
1515 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1516 * If these functions are defined,
1517 * the BYTEORDER is neither 0x1234 nor 0x4321.
1518 * However, this is not assumed.
1519 * -DWS
1520 */
1521
1522#define HTOV(name,type) \
1523 type \
1524 name (n) \
1525 register type n; \
1526 { \
1527 union { \
1528 type value; \
1529 char c[sizeof(type)]; \
1530 } u; \
79072805
LW
1531 register I32 i; \
1532 register I32 s; \
988174c1
LW
1533 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1534 u.c[i] = (n >> s) & 0xFF; \
1535 } \
1536 return u.value; \
1537 }
1538
1539#define VTOH(name,type) \
1540 type \
1541 name (n) \
1542 register type n; \
1543 { \
1544 union { \
1545 type value; \
1546 char c[sizeof(type)]; \
1547 } u; \
79072805
LW
1548 register I32 i; \
1549 register I32 s; \
988174c1
LW
1550 u.value = n; \
1551 n = 0; \
1552 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1553 n += (u.c[i] & 0xFF) << s; \
1554 } \
1555 return n; \
1556 }
1557
1558#if defined(HAS_HTOVS) && !defined(htovs)
1559HTOV(htovs,short)
1560#endif
1561#if defined(HAS_HTOVL) && !defined(htovl)
1562HTOV(htovl,long)
1563#endif
1564#if defined(HAS_VTOHS) && !defined(vtohs)
1565VTOH(vtohs,short)
1566#endif
1567#if defined(HAS_VTOHL) && !defined(vtohl)
1568VTOH(vtohl,long)
1569#endif
a687059c 1570
55497cff
PP
1571#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \
1572 && !defined(VMS) /* VMS' my_popen() is in VMS.c, same with OS/2. */
760ac839 1573PerlIO *
79072805 1574my_popen(cmd,mode)
a687059c
LW
1575char *cmd;
1576char *mode;
1577{
1578 int p[2];
79072805
LW
1579 register I32 this, that;
1580 register I32 pid;
1581 SV *sv;
55497cff
PP
1582 I32 doexec =
1583#ifdef AMIGAOS
1584 1;
1585#else
1586 strNE(cmd,"-");
1587#endif
a687059c 1588
ddcf38b7
IZ
1589#ifdef OS2
1590 if (doexec) {
1591 return my_syspopen(cmd,mode);
1592 }
1593#endif
a687059c
LW
1594 if (pipe(p) < 0)
1595 return Nullfp;
1596 this = (*mode == 'w');
1597 that = !this;
463ee0b2
LW
1598 if (tainting) {
1599 if (doexec) {
1600 taint_env();
1601 taint_proper("Insecure %s%s", "EXEC");
1602 }
d48672a2 1603 }
a687059c
LW
1604 while ((pid = (doexec?vfork():fork())) < 0) {
1605 if (errno != EAGAIN) {
1606 close(p[this]);
1607 if (!doexec)
463ee0b2 1608 croak("Can't fork");
a687059c
LW
1609 return Nullfp;
1610 }
1611 sleep(5);
1612 }
1613 if (pid == 0) {
79072805
LW
1614 GV* tmpgv;
1615
a687059c
LW
1616#define THIS that
1617#define THAT this
1618 close(p[THAT]);
1619 if (p[THIS] != (*mode == 'r')) {
1620 dup2(p[THIS], *mode == 'r');
1621 close(p[THIS]);
1622 }
1623 if (doexec) {
a0d0e21e 1624#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
1625 int fd;
1626
1627#ifndef NOFILE
1628#define NOFILE 20
1629#endif
d48672a2 1630 for (fd = maxsysfd + 1; fd < NOFILE; fd++)
ae986130
LW
1631 close(fd);
1632#endif
a687059c
LW
1633 do_exec(cmd); /* may or may not use the shell */
1634 _exit(1);
1635 }
de3bb511 1636 /*SUPPRESS 560*/
85e6fe83 1637 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
79072805 1638 sv_setiv(GvSV(tmpgv),(I32)getpid());
9f68db38 1639 forkprocess = 0;
463ee0b2 1640 hv_clear(pidstatus); /* we have no children */
a687059c
LW
1641 return Nullfp;
1642#undef THIS
1643#undef THAT
1644 }
62b28dd9 1645 do_execfree(); /* free any memory malloced by child on vfork */
a687059c 1646 close(p[that]);
62b28dd9
LW
1647 if (p[that] < p[this]) {
1648 dup2(p[this], p[that]);
1649 close(p[this]);
1650 p[this] = p[that];
1651 }
79072805 1652 sv = *av_fetch(fdpid,p[this],TRUE);
a0d0e21e 1653 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 1654 SvIVX(sv) = pid;
a687059c 1655 forkprocess = pid;
760ac839 1656 return PerlIO_fdopen(p[this], mode);
a687059c 1657}
7c0587c8 1658#else
55497cff 1659#if defined(atarist) || defined(DJGPP)
7c0587c8 1660FILE *popen();
760ac839 1661PerlIO *
79072805 1662my_popen(cmd,mode)
7c0587c8
LW
1663char *cmd;
1664char *mode;
1665{
760ac839 1666 /* Needs work for PerlIO ! */
55497cff
PP
1667 /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
1668 return popen(PerlIO_exportFILE(cmd, 0), mode);
7c0587c8
LW
1669}
1670#endif
1671
1672#endif /* !DOSISH */
a687059c 1673
748a9306 1674#ifdef DUMP_FDS
79072805 1675dump_fds(s)
ae986130
LW
1676char *s;
1677{
1678 int fd;
1679 struct stat tmpstatbuf;
1680
760ac839 1681 PerlIO_printf(PerlIO_stderr(),"%s", s);
ae986130 1682 for (fd = 0; fd < 32; fd++) {
a0d0e21e 1683 if (Fstat(fd,&tmpstatbuf) >= 0)
760ac839 1684 PerlIO_printf(PerlIO_stderr()," %d",fd);
ae986130 1685 }
760ac839 1686 PerlIO_printf(PerlIO_stderr(),"\n");
ae986130
LW
1687}
1688#endif
1689
fe14fcc3 1690#ifndef HAS_DUP2
fec02dd3 1691int
a687059c
LW
1692dup2(oldfd,newfd)
1693int oldfd;
1694int newfd;
1695{
a0d0e21e 1696#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
1697 if (oldfd == newfd)
1698 return oldfd;
62b28dd9 1699 close(newfd);
fec02dd3 1700 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 1701#else
d48672a2 1702 int fdtmp[256];
79072805 1703 I32 fdx = 0;
ae986130
LW
1704 int fd;
1705
fe14fcc3 1706 if (oldfd == newfd)
fec02dd3 1707 return oldfd;
a687059c 1708 close(newfd);
fec02dd3 1709 while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
ae986130
LW
1710 fdtmp[fdx++] = fd;
1711 while (fdx > 0)
1712 close(fdtmp[--fdx]);
fec02dd3 1713 return fd;
62b28dd9 1714#endif
a687059c
LW
1715}
1716#endif
1717
55497cff
PP
1718#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \
1719 && !defined(VMS) /* VMS' my_popen() is in VMS.c */
79072805
LW
1720I32
1721my_pclose(ptr)
760ac839 1722PerlIO *ptr;
a687059c 1723{
ecfc5424 1724 Signal_t (*hstat)(), (*istat)(), (*qstat)();
a687059c 1725 int status;
a0d0e21e 1726 SV **svp;
20188a90 1727 int pid;
a687059c 1728
760ac839 1729 svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
748a9306 1730 pid = (int)SvIVX(*svp);
a0d0e21e
LW
1731 SvREFCNT_dec(*svp);
1732 *svp = &sv_undef;
ddcf38b7
IZ
1733#ifdef OS2
1734 if (pid == -1) { /* Opened by popen. */
1735 return my_syspclose(ptr);
1736 }
1737#endif
760ac839 1738 PerlIO_close(ptr);
7c0587c8
LW
1739#ifdef UTS
1740 if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
1741#endif
a687059c
LW
1742 hstat = signal(SIGHUP, SIG_IGN);
1743 istat = signal(SIGINT, SIG_IGN);
1744 qstat = signal(SIGQUIT, SIG_IGN);
748a9306
LW
1745 do {
1746 pid = wait4pid(pid, &status, 0);
1747 } while (pid == -1 && errno == EINTR);
20188a90
LW
1748 signal(SIGHUP, hstat);
1749 signal(SIGINT, istat);
1750 signal(SIGQUIT, qstat);
1751 return(pid < 0 ? pid : status);
1752}
4633a7c4
LW
1753#endif /* !DOSISH */
1754
1755#if !defined(DOSISH) || defined(OS2)
79072805 1756I32
20188a90
LW
1757wait4pid(pid,statusp,flags)
1758int pid;
1759int *statusp;
1760int flags;
1761{
79072805
LW
1762 SV *sv;
1763 SV** svp;
20188a90
LW
1764 char spid[16];
1765
1766 if (!pid)
1767 return -1;
20188a90
LW
1768 if (pid > 0) {
1769 sprintf(spid, "%d", pid);
79072805
LW
1770 svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
1771 if (svp && *svp != &sv_undef) {
463ee0b2 1772 *statusp = SvIVX(*svp);
748a9306 1773 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW
1774 return pid;
1775 }
1776 }
1777 else {
79072805 1778 HE *entry;
20188a90 1779
79072805
LW
1780 hv_iterinit(pidstatus);
1781 if (entry = hv_iternext(pidstatus)) {
a0d0e21e 1782 pid = atoi(hv_iterkey(entry,(I32*)statusp));
79072805 1783 sv = hv_iterval(pidstatus,entry);
463ee0b2 1784 *statusp = SvIVX(sv);
20188a90 1785 sprintf(spid, "%d", pid);
748a9306 1786 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW
1787 return pid;
1788 }
1789 }
79072805
LW
1790#ifdef HAS_WAITPID
1791 return waitpid(pid,statusp,flags);
1792#else
a0d0e21e
LW
1793#ifdef HAS_WAIT4
1794 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1795#else
1796 {
1797 I32 result;
1798 if (flags)
1799 croak("Can't do waitpid with flags");
1800 else {
1801 while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
1802 pidgone(result,*statusp);
1803 if (result < 0)
1804 *statusp = -1;
1805 }
1806 return result;
a687059c
LW
1807 }
1808#endif
20188a90 1809#endif
a687059c 1810}
7c0587c8 1811#endif /* !DOSISH */
a687059c 1812
7c0587c8 1813void
de3bb511 1814/*SUPPRESS 590*/
a687059c
LW
1815pidgone(pid,status)
1816int pid;
1817int status;
1818{
79072805 1819 register SV *sv;
20188a90 1820 char spid[16];
a687059c 1821
20188a90 1822 sprintf(spid, "%d", pid);
79072805 1823 sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 1824 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 1825 SvIVX(sv) = status;
20188a90 1826 return;
a687059c
LW
1827}
1828
55497cff 1829#if defined(atarist) || defined(OS2) || defined(DJGPP)
7c0587c8 1830int pclose();
ddcf38b7
IZ
1831#ifdef HAS_FORK
1832int /* Cannot prototype with I32
1833 in os2ish.h. */
1834my_syspclose(ptr)
1835#else
79072805
LW
1836I32
1837my_pclose(ptr)
ddcf38b7 1838#endif
760ac839 1839PerlIO *ptr;
a687059c 1840{
760ac839
LW
1841 /* Needs work for PerlIO ! */
1842 FILE *f = PerlIO_findFILE(ptr);
1843 I32 result = pclose(f);
1844 PerlIO_releaseFILE(ptr,f);
1845 return result;
a687059c 1846}
7c0587c8 1847#endif
9f68db38
LW
1848
1849void
1850repeatcpy(to,from,len,count)
1851register char *to;
1852register char *from;
79072805
LW
1853I32 len;
1854register I32 count;
9f68db38 1855{
79072805 1856 register I32 todo;
9f68db38
LW
1857 register char *frombase = from;
1858
1859 if (len == 1) {
1860 todo = *from;
1861 while (count-- > 0)
1862 *to++ = todo;
1863 return;
1864 }
1865 while (count-- > 0) {
1866 for (todo = len; todo > 0; todo--) {
1867 *to++ = *from++;
1868 }
1869 from = frombase;
1870 }
1871}
0f85fab0
LW
1872
1873#ifndef CASTNEGFLOAT
463ee0b2 1874U32
79072805 1875cast_ulong(f)
0f85fab0
LW
1876double f;
1877{
1878 long along;
1879
27e2fb84 1880#if CASTFLAGS & 2
34de22dd
LW
1881# define BIGDOUBLE 2147483648.0
1882 if (f >= BIGDOUBLE)
1883 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
1884#endif
0f85fab0
LW
1885 if (f >= 0.0)
1886 return (unsigned long)f;
1887 along = (long)f;
1888 return (unsigned long)along;
1889}
ed6116ce
LW
1890# undef BIGDOUBLE
1891#endif
1892
1893#ifndef CASTI32
5d94fbed 1894
5d94fbed
AD
1895/* Unfortunately, on some systems the cast_uv() function doesn't
1896 work with the system-supplied definition of ULONG_MAX. The
1897 comparison (f >= ULONG_MAX) always comes out true. It must be a
1898 problem with the compiler constant folding.
1899
1900 In any case, this workaround should be fine on any two's complement
1901 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
1902 ccflags.
1903 --Andy Dougherty <doughera@lafcol.lafayette.edu>
1904*/
1eb770ff
PP
1905
1906/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
1907 of LONG_(MIN/MAX).
1908 -- Kenneth Albanowski <kjahds@kjahds.com>
1909*/
1910
20cec16a
PP
1911#ifndef MY_UV_MAX
1912# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
5d94fbed
AD
1913#endif
1914
ed6116ce
LW
1915I32
1916cast_i32(f)
1917double f;
1918{
20cec16a
PP
1919 if (f >= I32_MAX)
1920 return (I32) I32_MAX;
1921 if (f <= I32_MIN)
1922 return (I32) I32_MIN;
ed6116ce
LW
1923 return (I32) f;
1924}
a0d0e21e
LW
1925
1926IV
1927cast_iv(f)
1928double f;
1929{
20cec16a
PP
1930 if (f >= IV_MAX)
1931 return (IV) IV_MAX;
1932 if (f <= IV_MIN)
1933 return (IV) IV_MIN;
a0d0e21e
LW
1934 return (IV) f;
1935}
5d94fbed
AD
1936
1937UV
1938cast_uv(f)
1939double f;
1940{
20cec16a
PP
1941 if (f >= MY_UV_MAX)
1942 return (UV) MY_UV_MAX;
5d94fbed
AD
1943 return (UV) f;
1944}
1945
0f85fab0 1946#endif
62b28dd9 1947
fe14fcc3 1948#ifndef HAS_RENAME
79072805 1949I32
62b28dd9
LW
1950same_dirent(a,b)
1951char *a;
1952char *b;
1953{
93a17b20
LW
1954 char *fa = strrchr(a,'/');
1955 char *fb = strrchr(b,'/');
62b28dd9
LW
1956 struct stat tmpstatbuf1;
1957 struct stat tmpstatbuf2;
1958#ifndef MAXPATHLEN
1959#define MAXPATHLEN 1024
1960#endif
1961 char tmpbuf[MAXPATHLEN+1];
1962
1963 if (fa)
1964 fa++;
1965 else
1966 fa = a;
1967 if (fb)
1968 fb++;
1969 else
1970 fb = b;
1971 if (strNE(a,b))
1972 return FALSE;
1973 if (fa == a)
6eb13c3b 1974 strcpy(tmpbuf,".");
62b28dd9
LW
1975 else
1976 strncpy(tmpbuf, a, fa - a);
a0d0e21e 1977 if (Stat(tmpbuf, &tmpstatbuf1) < 0)
62b28dd9
LW
1978 return FALSE;
1979 if (fb == b)
6eb13c3b 1980 strcpy(tmpbuf,".");
62b28dd9
LW
1981 else
1982 strncpy(tmpbuf, b, fb - b);
a0d0e21e 1983 if (Stat(tmpbuf, &tmpstatbuf2) < 0)
62b28dd9
LW
1984 return FALSE;
1985 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
1986 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
1987}
fe14fcc3
LW
1988#endif /* !HAS_RENAME */
1989
55497cff 1990UV
79072805 1991scan_oct(start, len, retlen)
fe14fcc3 1992char *start;
79072805
LW
1993I32 len;
1994I32 *retlen;
fe14fcc3
LW
1995{
1996 register char *s = start;
55497cff
PP
1997 register UV retval = 0;
1998 bool overflowed = FALSE;
fe14fcc3 1999
748a9306 2000 while (len && *s >= '0' && *s <= '7') {
55497cff
PP
2001 register UV n = retval << 3;
2002 if (!overflowed && (n >> 3) != retval) {
2003 warn("Integer overflow in octal number");
2004 overflowed = TRUE;
2005 }
2006 retval = n | (*s++ - '0');
748a9306 2007 len--;
fe14fcc3 2008 }
748a9306
LW
2009 if (dowarn && len && (*s == '8' || *s == '9'))
2010 warn("Illegal octal digit ignored");
fe14fcc3
LW
2011 *retlen = s - start;
2012 return retval;
2013}
2014
2015unsigned long
79072805 2016scan_hex(start, len, retlen)
fe14fcc3 2017char *start;
79072805
LW
2018I32 len;
2019I32 *retlen;
fe14fcc3
LW
2020{
2021 register char *s = start;
55497cff
PP
2022 register UV retval = 0;
2023 bool overflowed = FALSE;
fe14fcc3
LW
2024 char *tmp;
2025
93a17b20 2026 while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
55497cff
PP
2027 register UV n = retval << 4;
2028 if (!overflowed && (n >> 4) != retval) {
2029 warn("Integer overflow in hex number");
2030 overflowed = TRUE;
2031 }
2032 retval = n | (tmp - hexdigit) & 15;
fe14fcc3
LW
2033 s++;
2034 }
2035 *retlen = s - start;
2036 return retval;
2037}
760ac839
LW
2038
2039
2040#ifdef HUGE_VAL
2041/*
2042 * This hack is to force load of "huge" support from libm.a
2043 * So it is in perl for (say) POSIX to use.
2044 * Needed for SunOS with Sun's 'acc' for example.
2045 */
2046double
2047Perl_huge()
2048{
2049 return HUGE_VAL;
2050}
2051#endif