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