This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.003_06: toke.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
f0c5b223
TB
407/* Initialize locale (and the fold[] array).*/
408int
1050c9ca 409perl_init_i18nl10n(printwarn)
f0c5b223
TB
410 int printwarn;
411{
412 int ok = 1;
413 /* returns
414 * 1 = set ok or not applicable,
415 * 0 = fallback to C locale,
416 * -1 = fallback to C locale failed
417 */
418#if defined(HAS_SETLOCALE) && defined(LC_CTYPE)
419 char * lang = getenv("LANG");
420 char * lc_all = getenv("LC_ALL");
421 char * lc_ctype = getenv("LC_CTYPE");
422 int i;
423
424 if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) {
20cec16a
PP
425 char *doit;
426
427 if (printwarn > 1 ||
428 printwarn && (!(doit = getenv("PERL_BADLANG")) || atoi(doit))) {
760ac839
LW
429 PerlIO_printf(PerlIO_stderr(), "warning: setlocale(LC_CTYPE, \"\") failed.\n");
430 PerlIO_printf(PerlIO_stderr(),
f0c5b223
TB
431 "warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n",
432 lc_all ? lc_all : "(null)",
433 lc_ctype ? lc_ctype : "(null)",
434 lang ? lang : "(null)"
435 );
760ac839 436 PerlIO_printf(PerlIO_stderr(), "warning: falling back to the \"C\" locale.\n");
f0c5b223
TB
437 }
438 ok = 0;
439 if (setlocale(LC_CTYPE, "C") == NULL)
440 ok = -1;
441 }
442
443 for (i = 0; i < 256; i++) {
444 if (isUPPER(i)) fold[i] = toLOWER(i);
445 else if (isLOWER(i)) fold[i] = toUPPER(i);
446 else fold[i] = i;
447 }
448#endif
449 return ok;
450}
451
378cc40b 452void
79072805
LW
453fbm_compile(sv, iflag)
454SV *sv;
455I32 iflag;
378cc40b 456{
a687059c
LW
457 register unsigned char *s;
458 register unsigned char *table;
79072805
LW
459 register U32 i;
460 register U32 len = SvCUR(sv);
461 I32 rarest = 0;
462 U32 frequency = 256;
463
748a9306
LW
464 if (len > 255)
465 return; /* can't have offsets that big */
79072805 466 Sv_Grow(sv,len+258);
463ee0b2 467 table = (unsigned char*)(SvPVX(sv) + len + 1);
a687059c
LW
468 s = table - 2;
469 for (i = 0; i < 256; i++) {
378cc40b
LW
470 table[i] = len;
471 }
472 i = 0;
463ee0b2 473 while (s >= (unsigned char*)(SvPVX(sv)))
a687059c
LW
474 {
475 if (table[*s] == len) {
476#ifndef pdp11
477 if (iflag)
478 table[*s] = table[fold[*s]] = i;
479#else
480 if (iflag) {
79072805 481 I32 j;
a687059c
LW
482 j = fold[*s];
483 table[j] = i;
484 table[*s] = i;
485 }
486#endif /* pdp11 */
487 else
488 table[*s] = i;
489 }
378cc40b
LW
490 s--,i++;
491 }
79072805 492 sv_upgrade(sv, SVt_PVBM);
a0d0e21e 493 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
79072805 494 SvVALID_on(sv);
378cc40b 495
463ee0b2 496 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
a687059c 497 if (iflag) {
79072805
LW
498 register U32 tmp, foldtmp;
499 SvCASEFOLD_on(sv);
a687059c
LW
500 for (i = 0; i < len; i++) {
501 tmp=freq[s[i]];
502 foldtmp=freq[fold[s[i]]];
503 if (tmp < frequency && foldtmp < frequency) {
504 rarest = i;
505 /* choose most frequent among the two */
506 frequency = (tmp > foldtmp) ? tmp : foldtmp;
507 }
508 }
509 }
510 else {
511 for (i = 0; i < len; i++) {
512 if (freq[s[i]] < frequency) {
513 rarest = i;
514 frequency = freq[s[i]];
515 }
378cc40b
LW
516 }
517 }
79072805
LW
518 BmRARE(sv) = s[rarest];
519 BmPREVIOUS(sv) = rarest;
760ac839 520 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
378cc40b
LW
521}
522
378cc40b 523char *
79072805 524fbm_instr(big, bigend, littlestr)
a687059c
LW
525unsigned char *big;
526register unsigned char *bigend;
79072805 527SV *littlestr;
378cc40b 528{
a687059c 529 register unsigned char *s;
79072805
LW
530 register I32 tmp;
531 register I32 littlelen;
a687059c
LW
532 register unsigned char *little;
533 register unsigned char *table;
534 register unsigned char *olds;
535 register unsigned char *oldlittle;
378cc40b 536
79072805 537 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
a0d0e21e
LW
538 STRLEN len;
539 char *l = SvPV(littlestr,len);
540 if (!len)
d48672a2 541 return (char*)big;
a0d0e21e 542 return ninstr((char*)big,(char*)bigend, l, l + len);
d48672a2 543 }
378cc40b 544
79072805
LW
545 littlelen = SvCUR(littlestr);
546 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
0f85fab0
LW
547 if (littlelen > bigend - big)
548 return Nullch;
463ee0b2 549 little = (unsigned char*)SvPVX(littlestr);
79072805 550 if (SvCASEFOLD(littlestr)) { /* oops, fake it */
a687059c
LW
551 big = bigend - littlelen; /* just start near end */
552 if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
553 big--;
378cc40b
LW
554 }
555 else {
a687059c 556 s = bigend - littlelen;
bd4080b3 557 if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
a687059c 558 return (char*)s; /* how sweet it is */
34de22dd
LW
559 else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
560 && s > big) {
a687059c 561 s--;
bd4080b3 562 if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
a687059c
LW
563 return (char*)s;
564 }
565 return Nullch;
566 }
567 }
463ee0b2 568 table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
62b28dd9
LW
569 if (--littlelen >= bigend - big)
570 return Nullch;
571 s = big + littlelen;
a687059c 572 oldlittle = little = table - 2;
79072805 573 if (SvCASEFOLD(littlestr)) { /* case insensitive? */
20188a90 574 if (s < bigend) {
a687059c 575 top1:
de3bb511 576 /*SUPPRESS 560*/
a687059c 577 if (tmp = table[*s]) {
62b28dd9
LW
578#ifdef POINTERRIGOR
579 if (bigend - s > tmp) {
580 s += tmp;
581 goto top1;
582 }
583#else
584 if ((s += tmp) < bigend)
585 goto top1;
586#endif
587 return Nullch;
a687059c
LW
588 }
589 else {
590 tmp = littlelen; /* less expensive than calling strncmp() */
591 olds = s;
592 while (tmp--) {
593 if (*--s == *--little || fold[*s] == *little)
594 continue;
595 s = olds + 1; /* here we pay the price for failure */
596 little = oldlittle;
597 if (s < bigend) /* fake up continue to outer loop */
598 goto top1;
599 return Nullch;
600 }
a687059c 601 return (char *)s;
a687059c
LW
602 }
603 }
604 }
605 else {
20188a90 606 if (s < bigend) {
a687059c 607 top2:
de3bb511 608 /*SUPPRESS 560*/
a687059c 609 if (tmp = table[*s]) {
62b28dd9
LW
610#ifdef POINTERRIGOR
611 if (bigend - s > tmp) {
612 s += tmp;
613 goto top2;
614 }
615#else
616 if ((s += tmp) < bigend)
617 goto top2;
618#endif
619 return Nullch;
a687059c
LW
620 }
621 else {
622 tmp = littlelen; /* less expensive than calling strncmp() */
623 olds = s;
624 while (tmp--) {
625 if (*--s == *--little)
626 continue;
627 s = olds + 1; /* here we pay the price for failure */
628 little = oldlittle;
629 if (s < bigend) /* fake up continue to outer loop */
630 goto top2;
631 return Nullch;
632 }
a687059c 633 return (char *)s;
378cc40b 634 }
378cc40b
LW
635 }
636 }
637 return Nullch;
638}
639
640char *
641screaminstr(bigstr, littlestr)
79072805
LW
642SV *bigstr;
643SV *littlestr;
378cc40b 644{
a687059c
LW
645 register unsigned char *s, *x;
646 register unsigned char *big;
79072805
LW
647 register I32 pos;
648 register I32 previous;
649 register I32 first;
a687059c
LW
650 register unsigned char *little;
651 register unsigned char *bigend;
652 register unsigned char *littleend;
378cc40b 653
79072805 654 if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
378cc40b 655 return Nullch;
463ee0b2 656 little = (unsigned char *)(SvPVX(littlestr));
79072805 657 littleend = little + SvCUR(littlestr);
378cc40b 658 first = *little++;
79072805 659 previous = BmPREVIOUS(littlestr);
463ee0b2 660 big = (unsigned char *)(SvPVX(bigstr));
79072805 661 bigend = big + SvCUR(bigstr);
378cc40b
LW
662 while (pos < previous) {
663 if (!(pos += screamnext[pos]))
664 return Nullch;
665 }
de3bb511 666#ifdef POINTERRIGOR
79072805 667 if (SvCASEFOLD(littlestr)) { /* case insignificant? */
a687059c 668 do {
988174c1
LW
669 if (big[pos-previous] != first && big[pos-previous] != fold[first])
670 continue;
de3bb511
LW
671 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
672 if (x >= bigend)
673 return Nullch;
674 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
675 s--;
676 break;
677 }
678 }
679 if (s == littleend)
de3bb511 680 return (char *)(big+pos-previous);
de3bb511 681 } while (
de3bb511 682 pos += screamnext[pos] /* does this goof up anywhere? */
de3bb511
LW
683 );
684 }
685 else {
686 do {
988174c1
LW
687 if (big[pos-previous] != first)
688 continue;
de3bb511
LW
689 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
690 if (x >= bigend)
691 return Nullch;
692 if (*s++ != *x++) {
693 s--;
694 break;
695 }
696 }
697 if (s == littleend)
de3bb511 698 return (char *)(big+pos-previous);
79072805 699 } while ( pos += screamnext[pos] );
de3bb511
LW
700 }
701#else /* !POINTERRIGOR */
702 big -= previous;
79072805 703 if (SvCASEFOLD(littlestr)) { /* case insignificant? */
de3bb511 704 do {
988174c1
LW
705 if (big[pos] != first && big[pos] != fold[first])
706 continue;
a687059c
LW
707 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
708 if (x >= bigend)
709 return Nullch;
710 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
711 s--;
712 break;
713 }
714 }
715 if (s == littleend)
a687059c 716 return (char *)(big+pos);
a687059c 717 } while (
a687059c 718 pos += screamnext[pos] /* does this goof up anywhere? */
a687059c
LW
719 );
720 }
721 else {
722 do {
988174c1
LW
723 if (big[pos] != first)
724 continue;
a687059c
LW
725 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
726 if (x >= bigend)
727 return Nullch;
728 if (*s++ != *x++) {
729 s--;
730 break;
731 }
378cc40b 732 }
a687059c 733 if (s == littleend)
a687059c 734 return (char *)(big+pos);
a687059c 735 } while (
a687059c 736 pos += screamnext[pos]
a687059c
LW
737 );
738 }
de3bb511 739#endif /* POINTERRIGOR */
8d063cd8
LW
740 return Nullch;
741}
742
79072805
LW
743I32
744ibcmp(a,b,len)
a0d0e21e
LW
745register U8 *a;
746register U8 *b;
79072805
LW
747register I32 len;
748{
749 while (len--) {
750 if (*a == *b) {
751 a++,b++;
752 continue;
753 }
754 if (fold[*a++] == *b++)
755 continue;
756 return 1;
757 }
758 return 0;
759}
760
8d063cd8
LW
761/* copy a string to a safe spot */
762
763char *
a0d0e21e 764savepv(sv)
79072805 765char *sv;
8d063cd8 766{
a687059c 767 register char *newaddr;
8d063cd8 768
79072805
LW
769 New(902,newaddr,strlen(sv)+1,char);
770 (void)strcpy(newaddr,sv);
8d063cd8
LW
771 return newaddr;
772}
773
a687059c
LW
774/* same thing but with a known length */
775
776char *
a0d0e21e 777savepvn(sv, len)
79072805
LW
778char *sv;
779register I32 len;
a687059c
LW
780{
781 register char *newaddr;
782
783 New(903,newaddr,len+1,char);
79072805 784 Copy(sv,newaddr,len,char); /* might not be null terminated */
a687059c
LW
785 newaddr[len] = '\0'; /* is now */
786 return newaddr;
787}
788
a0d0e21e 789#if !defined(I_STDARG) && !defined(I_VARARGS)
8d063cd8 790
8990e307
LW
791/*
792 * Fallback on the old hackers way of doing varargs
793 */
8d063cd8 794
378cc40b 795/*VARARGS1*/
7c0587c8 796char *
378cc40b
LW
797mess(pat,a1,a2,a3,a4)
798char *pat;
a687059c 799long a1, a2, a3, a4;
378cc40b
LW
800{
801 char *s;
f0c5b223 802 char *s_start;
79072805
LW
803 I32 usermess = strEQ(pat,"%s");
804 SV *tmpstr;
378cc40b 805
f0c5b223 806 s = s_start = buf;
de3bb511 807 if (usermess) {
8990e307 808 tmpstr = sv_newmortal();
79072805 809 sv_setpv(tmpstr, (char*)a1);
463ee0b2 810 *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
de3bb511
LW
811 }
812 else {
813 (void)sprintf(s,pat,a1,a2,a3,a4);
814 s += strlen(s);
815 }
816
378cc40b 817 if (s[-1] != '\n') {
2304df62
AD
818 if (dirty)
819 strcpy(s, " during global destruction.\n");
820 else {
821 if (curcop->cop_line) {
822 (void)sprintf(s," at %s line %ld",
823 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
824 s += strlen(s);
825 }
a0d0e21e
LW
826 if (GvIO(last_in_gv) &&
827 IoLINES(GvIOp(last_in_gv)) ) {
2304df62
AD
828 (void)sprintf(s,", <%s> %s %ld",
829 last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
830 strEQ(rs,"\n") ? "line" : "chunk",
a0d0e21e 831 (long)IoLINES(GvIOp(last_in_gv)));
2304df62
AD
832 s += strlen(s);
833 }
834 (void)strcpy(s,".\n");
f0c5b223 835 s += 2;
378cc40b 836 }
de3bb511 837 if (usermess)
79072805 838 sv_catpv(tmpstr,buf+1);
378cc40b 839 }
f0c5b223
TB
840
841 if (s - s_start >= sizeof(buf)) { /* Ooops! */
842 if (usermess)
760ac839 843 PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
f0c5b223 844 else
760ac839
LW
845 PerlIO_puts(PerlIO_stderr(), buf);
846 PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n");
f0c5b223
TB
847 my_exit(1);
848 }
de3bb511 849 if (usermess)
463ee0b2 850 return SvPVX(tmpstr);
de3bb511
LW
851 else
852 return buf;
378cc40b
LW
853}
854
8d063cd8 855/*VARARGS1*/
463ee0b2 856void croak(pat,a1,a2,a3,a4)
8d063cd8 857char *pat;
a687059c 858long a1, a2, a3, a4;
8d063cd8 859{
9f68db38 860 char *tmps;
de3bb511 861 char *message;
748a9306
LW
862 HV *stash;
863 GV *gv;
864 CV *cv;
8d063cd8 865
de3bb511 866 message = mess(pat,a1,a2,a3,a4);
20cec16a
PP
867 if (diehook) {
868 SV *olddiehook = diehook;
869 diehook = Nullsv; /* sv_2cv might call croak() */
870 cv = sv_2cv(olddiehook, &stash, &gv, 0);
871 diehook = olddiehook;
872 if (cv && !CvDEPTH(cv)) {
873 dSP;
874
875 PUSHMARK(sp);
876 EXTEND(sp, 1);
877 PUSHs(sv_2mortal(newSVpv(message,0)));
878 PUTBACK;
879 perl_call_sv((SV*)cv, G_DISCARD);
880 }
748a9306 881 }
a0d0e21e
LW
882 if (in_eval) {
883 restartop = die_where(message);
a5f75d66 884 Siglongjmp(top_env, 3);
a0d0e21e 885 }
760ac839
LW
886 PerlIO_puts(PerlIO_stderr(),message);
887 (void)PerlIO_flush(PerlIO_stderr());
38cd9116
PP
888 if (e_tmpname) {
889 if (e_fp) {
760ac839 890 PerlIO_close(e_fp);
38cd9116
PP
891 e_fp = Nullfp;
892 }
a687059c 893 (void)UNLINK(e_tmpname);
38cd9116
PP
894 Safefree(e_tmpname);
895 e_tmpname = Nullch;
f0c5b223 896 }
748a9306
LW
897 statusvalue = SHIFTSTATUS(statusvalue);
898#ifdef VMS
899 my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
900#else
901 my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
902#endif
378cc40b
LW
903}
904
905/*VARARGS1*/
7c0587c8 906void warn(pat,a1,a2,a3,a4)
378cc40b 907char *pat;
a687059c 908long a1, a2, a3, a4;
378cc40b 909{
de3bb511 910 char *message;
748a9306
LW
911 SV *sv;
912 HV *stash;
913 GV *gv;
914 CV *cv;
de3bb511
LW
915
916 message = mess(pat,a1,a2,a3,a4);
20cec16a
PP
917 if (warnhook) {
918 SV *oldwarnhook = warnhook;
919 warnhook = Nullsv; /* sv_2cv might end up calling warn() */
920 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
921 warnhook = oldwarnhook;
922 if (cv && !CvDEPTH(cv)) {
923 dSP;
924
925 PUSHMARK(sp);
926 EXTEND(sp, 1);
927 PUSHs(sv_2mortal(newSVpv(message,0)));
928 PUTBACK;
929 perl_call_sv((SV*)cv, G_DISCARD);
930 return;
931 }
748a9306 932 }
20cec16a 933 PerlIO_puts(PerlIO_stderr(),message);
a687059c 934#ifdef LEAKTEST
20cec16a 935 DEBUG_L(xstat());
a687059c 936#endif
20cec16a 937 (void)PerlIO_flush(PerlIO_stderr());
8d063cd8 938}
8990e307 939
a0d0e21e 940#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
8990e307 941
a0d0e21e 942#ifdef I_STDARG
8990e307 943char *
2304df62 944mess(char *pat, va_list *args)
a687059c
LW
945#else
946/*VARARGS0*/
de3bb511 947char *
8990e307 948mess(pat, args)
a687059c 949 char *pat;
2304df62 950 va_list *args;
8990e307
LW
951#endif
952{
a687059c 953 char *s;
f0c5b223 954 char *s_start;
79072805
LW
955 SV *tmpstr;
956 I32 usermess;
d48672a2 957#ifndef HAS_VPRINTF
85e6fe83 958#ifdef USE_CHAR_VSPRINTF
a687059c
LW
959 char *vsprintf();
960#else
79072805 961 I32 vsprintf();
a687059c 962#endif
d48672a2 963#endif
a687059c 964
f0c5b223 965 s = s_start = buf;
de3bb511
LW
966 usermess = strEQ(pat, "%s");
967 if (usermess) {
8990e307 968 tmpstr = sv_newmortal();
2304df62 969 sv_setpv(tmpstr, va_arg(*args, char *));
463ee0b2 970 *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
de3bb511
LW
971 }
972 else {
2304df62 973 (void) vsprintf(s,pat,*args);
de3bb511
LW
974 s += strlen(s);
975 }
2304df62 976 va_end(*args);
a687059c 977
a687059c 978 if (s[-1] != '\n') {
2304df62
AD
979 if (dirty)
980 strcpy(s, " during global destruction.\n");
981 else {
982 if (curcop->cop_line) {
983 (void)sprintf(s," at %s line %ld",
984 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
985 s += strlen(s);
986 }
c07a80fd
PP
987 if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
988 bool line_mode = (RsSIMPLE(rs) &&
989 SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
2304df62
AD
990 (void)sprintf(s,", <%s> %s %ld",
991 last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
c07a80fd 992 line_mode ? "line" : "chunk",
a0d0e21e 993 (long)IoLINES(GvIOp(last_in_gv)));
2304df62
AD
994 s += strlen(s);
995 }
996 (void)strcpy(s,".\n");
f0c5b223 997 s += 2;
a687059c 998 }
de3bb511 999 if (usermess)
79072805 1000 sv_catpv(tmpstr,buf+1);
a687059c 1001 }
de3bb511 1002
f0c5b223
TB
1003 if (s - s_start >= sizeof(buf)) { /* Ooops! */
1004 if (usermess)
760ac839 1005 PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
f0c5b223 1006 else
760ac839
LW
1007 PerlIO_puts(PerlIO_stderr(), buf);
1008 PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
f0c5b223
TB
1009 my_exit(1);
1010 }
de3bb511 1011 if (usermess)
463ee0b2 1012 return SvPVX(tmpstr);
de3bb511
LW
1013 else
1014 return buf;
a687059c
LW
1015}
1016
ecfc5424 1017#ifdef I_STDARG
79072805 1018void
8990e307 1019croak(char* pat, ...)
463ee0b2 1020#else
8990e307
LW
1021/*VARARGS0*/
1022void
1023croak(pat, va_alist)
1024 char *pat;
1025 va_dcl
463ee0b2 1026#endif
a687059c
LW
1027{
1028 va_list args;
de3bb511 1029 char *message;
748a9306
LW
1030 HV *stash;
1031 GV *gv;
1032 CV *cv;
a687059c 1033
a0d0e21e 1034#ifdef I_STDARG
8990e307
LW
1035 va_start(args, pat);
1036#else
a687059c 1037 va_start(args);
8990e307 1038#endif
2304df62 1039 message = mess(pat, &args);
a687059c 1040 va_end(args);
20cec16a
PP
1041 if (diehook) {
1042 SV *olddiehook = diehook;
1043 diehook = Nullsv; /* sv_2cv might call croak() */
1044 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1045 diehook = olddiehook;
1046 if (cv && !CvDEPTH(cv)) {
1047 dSP;
1048
1049 PUSHMARK(sp);
1050 EXTEND(sp, 1);
1051 PUSHs(sv_2mortal(newSVpv(message,0)));
1052 PUTBACK;
1053 perl_call_sv((SV*)cv, G_DISCARD);
1054 }
748a9306 1055 }
a0d0e21e
LW
1056 if (in_eval) {
1057 restartop = die_where(message);
a5f75d66 1058 Siglongjmp(top_env, 3);
a0d0e21e 1059 }
760ac839
LW
1060 PerlIO_puts(PerlIO_stderr(),message);
1061 (void)PerlIO_flush(PerlIO_stderr());
38cd9116
PP
1062 if (e_tmpname) {
1063 if (e_fp) {
760ac839 1064 PerlIO_close(e_fp);
38cd9116
PP
1065 e_fp = Nullfp;
1066 }
a687059c 1067 (void)UNLINK(e_tmpname);
38cd9116
PP
1068 Safefree(e_tmpname);
1069 e_tmpname = Nullch;
f0c5b223 1070 }
748a9306
LW
1071 statusvalue = SHIFTSTATUS(statusvalue);
1072#ifdef VMS
1073 my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
1074#else
1075 my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1076#endif
a687059c
LW
1077}
1078
8990e307 1079void
ecfc5424 1080#ifdef I_STDARG
8990e307 1081warn(char* pat,...)
463ee0b2 1082#else
8990e307
LW
1083/*VARARGS0*/
1084warn(pat,va_alist)
1085 char *pat;
1086 va_dcl
463ee0b2 1087#endif
a687059c
LW
1088{
1089 va_list args;
de3bb511 1090 char *message;
748a9306
LW
1091 HV *stash;
1092 GV *gv;
1093 CV *cv;
a687059c 1094
a0d0e21e 1095#ifdef I_STDARG
8990e307
LW
1096 va_start(args, pat);
1097#else
a687059c 1098 va_start(args);
8990e307 1099#endif
2304df62 1100 message = mess(pat, &args);
a687059c
LW
1101 va_end(args);
1102
20cec16a
PP
1103 if (warnhook) {
1104 SV *oldwarnhook = warnhook;
1105 warnhook = Nullsv; /* sv_2cv might end up calling warn() */
1106 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1107 warnhook = oldwarnhook;
1108 if (cv && !CvDEPTH(cv)) {
1109 dSP;
1110
1111 PUSHMARK(sp);
1112 EXTEND(sp, 1);
1113 PUSHs(sv_2mortal(newSVpv(message,0)));
1114 PUTBACK;
1115 perl_call_sv((SV*)cv, G_DISCARD);
1116 return;
1117 }
748a9306 1118 }
20cec16a 1119 PerlIO_puts(PerlIO_stderr(),message);
a687059c 1120#ifdef LEAKTEST
20cec16a 1121 DEBUG_L(xstat());
a687059c 1122#endif
20cec16a 1123 (void)PerlIO_flush(PerlIO_stderr());
a687059c 1124}
a0d0e21e 1125#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
8d063cd8 1126
a0d0e21e 1127#ifndef VMS /* VMS' my_setenv() is in VMS.c */
8d063cd8 1128void
7c0587c8 1129my_setenv(nam,val)
8d063cd8
LW
1130char *nam, *val;
1131{
79072805 1132 register I32 i=setenv_getix(nam); /* where does it go? */
8d063cd8 1133
fe14fcc3 1134 if (environ == origenviron) { /* need we copy environment? */
79072805
LW
1135 I32 j;
1136 I32 max;
fe14fcc3
LW
1137 char **tmpenv;
1138
de3bb511 1139 /*SUPPRESS 530*/
fe14fcc3
LW
1140 for (max = i; environ[max]; max++) ;
1141 New(901,tmpenv, max+2, char*);
1142 for (j=0; j<max; j++) /* copy environment */
a0d0e21e 1143 tmpenv[j] = savepv(environ[j]);
fe14fcc3
LW
1144 tmpenv[max] = Nullch;
1145 environ = tmpenv; /* tell exec where it is now */
1146 }
a687059c
LW
1147 if (!val) {
1148 while (environ[i]) {
1149 environ[i] = environ[i+1];
1150 i++;
1151 }
1152 return;
1153 }
8d063cd8 1154 if (!environ[i]) { /* does not exist yet */
fe14fcc3 1155 Renew(environ, i+2, char*); /* just expand it a bit */
8d063cd8
LW
1156 environ[i+1] = Nullch; /* make sure it's null terminated */
1157 }
fe14fcc3
LW
1158 else
1159 Safefree(environ[i]);
a687059c 1160 New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
62b28dd9 1161#ifndef MSDOS
a687059c 1162 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
62b28dd9
LW
1163#else
1164 /* MS-DOS requires environment variable names to be in uppercase */
fe14fcc3
LW
1165 /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1166 * some utilities and applications may break because they only look
1167 * for upper case strings. (Fixed strupr() bug here.)]
1168 */
1169 strcpy(environ[i],nam); strupr(environ[i]);
62b28dd9
LW
1170 (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1171#endif /* MSDOS */
8d063cd8
LW
1172}
1173
79072805
LW
1174I32
1175setenv_getix(nam)
8d063cd8
LW
1176char *nam;
1177{
79072805 1178 register I32 i, len = strlen(nam);
8d063cd8
LW
1179
1180 for (i = 0; environ[i]; i++) {
1181 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1182 break; /* strnEQ must come first to avoid */
1183 } /* potential SEGV's */
1184 return i;
1185}
a0d0e21e 1186#endif /* !VMS */
378cc40b 1187
16d20bd9 1188#ifdef UNLINK_ALL_VERSIONS
79072805 1189I32
378cc40b
LW
1190unlnk(f) /* unlink all versions of a file */
1191char *f;
1192{
79072805 1193 I32 i;
378cc40b
LW
1194
1195 for (i = 0; unlink(f) >= 0; i++) ;
1196 return i ? 0 : -1;
1197}
1198#endif
1199
85e6fe83 1200#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
378cc40b 1201char *
7c0587c8 1202my_bcopy(from,to,len)
378cc40b
LW
1203register char *from;
1204register char *to;
79072805 1205register I32 len;
378cc40b
LW
1206{
1207 char *retval = to;
1208
7c0587c8
LW
1209 if (from - to >= 0) {
1210 while (len--)
1211 *to++ = *from++;
1212 }
1213 else {
1214 to += len;
1215 from += len;
1216 while (len--)
faf8582f 1217 *(--to) = *(--from);
7c0587c8 1218 }
378cc40b
LW
1219 return retval;
1220}
ffed7fef 1221#endif
378cc40b 1222
7c0587c8 1223#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1224char *
7c0587c8 1225my_bzero(loc,len)
378cc40b 1226register char *loc;
79072805 1227register I32 len;
378cc40b
LW
1228{
1229 char *retval = loc;
1230
1231 while (len--)
1232 *loc++ = 0;
1233 return retval;
1234}
1235#endif
7c0587c8
LW
1236
1237#ifndef HAS_MEMCMP
79072805 1238I32
7c0587c8
LW
1239my_memcmp(s1,s2,len)
1240register unsigned char *s1;
1241register unsigned char *s2;
79072805 1242register I32 len;
7c0587c8 1243{
79072805 1244 register I32 tmp;
7c0587c8
LW
1245
1246 while (len--) {
1247 if (tmp = *s1++ - *s2++)
1248 return tmp;
1249 }
1250 return 0;
1251}
1252#endif /* HAS_MEMCMP */
a687059c 1253
4633a7c4 1254#if defined(I_STDARG) || defined(I_VARARGS)
fe14fcc3 1255#ifndef HAS_VPRINTF
a687059c 1256
85e6fe83 1257#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1258char *
1259#else
1260int
1261#endif
1262vsprintf(dest, pat, args)
1263char *dest, *pat, *args;
1264{
1265 FILE fakebuf;
1266
1267 fakebuf._ptr = dest;
1268 fakebuf._cnt = 32767;
35c8bce7
LW
1269#ifndef _IOSTRG
1270#define _IOSTRG 0
1271#endif
a687059c
LW
1272 fakebuf._flag = _IOWRT|_IOSTRG;
1273 _doprnt(pat, args, &fakebuf); /* what a kludge */
1274 (void)putc('\0', &fakebuf);
85e6fe83 1275#ifdef USE_CHAR_VSPRINTF
a687059c
LW
1276 return(dest);
1277#else
1278 return 0; /* perl doesn't use return value */
1279#endif
1280}
1281
fe14fcc3 1282#endif /* HAS_VPRINTF */
4633a7c4 1283#endif /* I_VARARGS || I_STDARGS */
a687059c
LW
1284
1285#ifdef MYSWAP
ffed7fef 1286#if BYTEORDER != 0x4321
a687059c 1287short
748a9306 1288#ifndef CAN_PROTOTYPE
a687059c
LW
1289my_swap(s)
1290short s;
748a9306
LW
1291#else
1292my_swap(short s)
1293#endif
a687059c
LW
1294{
1295#if (BYTEORDER & 1) == 0
1296 short result;
1297
1298 result = ((s & 255) << 8) + ((s >> 8) & 255);
1299 return result;
1300#else
1301 return s;
1302#endif
1303}
1304
1305long
748a9306
LW
1306#ifndef CAN_PROTOTYPE
1307my_htonl(l)
a687059c 1308register long l;
748a9306
LW
1309#else
1310my_htonl(long l)
1311#endif
a687059c
LW
1312{
1313 union {
1314 long result;
ffed7fef 1315 char c[sizeof(long)];
a687059c
LW
1316 } u;
1317
ffed7fef 1318#if BYTEORDER == 0x1234
a687059c
LW
1319 u.c[0] = (l >> 24) & 255;
1320 u.c[1] = (l >> 16) & 255;
1321 u.c[2] = (l >> 8) & 255;
1322 u.c[3] = l & 255;
1323 return u.result;
1324#else
ffed7fef 1325#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
463ee0b2 1326 croak("Unknown BYTEORDER\n");
a687059c 1327#else
79072805
LW
1328 register I32 o;
1329 register I32 s;
a687059c 1330
ffed7fef
LW
1331 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1332 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW
1333 }
1334 return u.result;
1335#endif
1336#endif
1337}
1338
1339long
748a9306
LW
1340#ifndef CAN_PROTOTYPE
1341my_ntohl(l)
a687059c 1342register long l;
748a9306
LW
1343#else
1344my_ntohl(long l)
1345#endif
a687059c
LW
1346{
1347 union {
1348 long l;
ffed7fef 1349 char c[sizeof(long)];
a687059c
LW
1350 } u;
1351
ffed7fef 1352#if BYTEORDER == 0x1234
a687059c
LW
1353 u.c[0] = (l >> 24) & 255;
1354 u.c[1] = (l >> 16) & 255;
1355 u.c[2] = (l >> 8) & 255;
1356 u.c[3] = l & 255;
1357 return u.l;
1358#else
ffed7fef 1359#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
463ee0b2 1360 croak("Unknown BYTEORDER\n");
a687059c 1361#else
79072805
LW
1362 register I32 o;
1363 register I32 s;
a687059c
LW
1364
1365 u.l = l;
1366 l = 0;
ffed7fef
LW
1367 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1368 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW
1369 }
1370 return l;
1371#endif
1372#endif
1373}
1374
ffed7fef 1375#endif /* BYTEORDER != 0x4321 */
988174c1
LW
1376#endif /* MYSWAP */
1377
1378/*
1379 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1380 * If these functions are defined,
1381 * the BYTEORDER is neither 0x1234 nor 0x4321.
1382 * However, this is not assumed.
1383 * -DWS
1384 */
1385
1386#define HTOV(name,type) \
1387 type \
1388 name (n) \
1389 register type n; \
1390 { \
1391 union { \
1392 type value; \
1393 char c[sizeof(type)]; \
1394 } u; \
79072805
LW
1395 register I32 i; \
1396 register I32 s; \
988174c1
LW
1397 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1398 u.c[i] = (n >> s) & 0xFF; \
1399 } \
1400 return u.value; \
1401 }
1402
1403#define VTOH(name,type) \
1404 type \
1405 name (n) \
1406 register type n; \
1407 { \
1408 union { \
1409 type value; \
1410 char c[sizeof(type)]; \
1411 } u; \
79072805
LW
1412 register I32 i; \
1413 register I32 s; \
988174c1
LW
1414 u.value = n; \
1415 n = 0; \
1416 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1417 n += (u.c[i] & 0xFF) << s; \
1418 } \
1419 return n; \
1420 }
1421
1422#if defined(HAS_HTOVS) && !defined(htovs)
1423HTOV(htovs,short)
1424#endif
1425#if defined(HAS_HTOVL) && !defined(htovl)
1426HTOV(htovl,long)
1427#endif
1428#if defined(HAS_VTOHS) && !defined(vtohs)
1429VTOH(vtohs,short)
1430#endif
1431#if defined(HAS_VTOHL) && !defined(vtohl)
1432VTOH(vtohl,long)
1433#endif
a687059c 1434
1050c9ca 1435#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in
f0c5b223 1436 VMS.c, same with OS/2. */
760ac839 1437PerlIO *
79072805 1438my_popen(cmd,mode)
a687059c
LW
1439char *cmd;
1440char *mode;
1441{
1442 int p[2];
79072805
LW
1443 register I32 this, that;
1444 register I32 pid;
1445 SV *sv;
1446 I32 doexec = strNE(cmd,"-");
a687059c
LW
1447
1448 if (pipe(p) < 0)
1449 return Nullfp;
1450 this = (*mode == 'w');
1451 that = !this;
463ee0b2
LW
1452 if (tainting) {
1453 if (doexec) {
1454 taint_env();
1455 taint_proper("Insecure %s%s", "EXEC");
1456 }
d48672a2 1457 }
a687059c
LW
1458 while ((pid = (doexec?vfork():fork())) < 0) {
1459 if (errno != EAGAIN) {
1460 close(p[this]);
1461 if (!doexec)
463ee0b2 1462 croak("Can't fork");
a687059c
LW
1463 return Nullfp;
1464 }
1465 sleep(5);
1466 }
1467 if (pid == 0) {
79072805
LW
1468 GV* tmpgv;
1469
a687059c
LW
1470#define THIS that
1471#define THAT this
1472 close(p[THAT]);
1473 if (p[THIS] != (*mode == 'r')) {
1474 dup2(p[THIS], *mode == 'r');
1475 close(p[THIS]);
1476 }
1477 if (doexec) {
a0d0e21e 1478#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW
1479 int fd;
1480
1481#ifndef NOFILE
1482#define NOFILE 20
1483#endif
d48672a2 1484 for (fd = maxsysfd + 1; fd < NOFILE; fd++)
ae986130
LW
1485 close(fd);
1486#endif
a687059c
LW
1487 do_exec(cmd); /* may or may not use the shell */
1488 _exit(1);
1489 }
de3bb511 1490 /*SUPPRESS 560*/
85e6fe83 1491 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
79072805 1492 sv_setiv(GvSV(tmpgv),(I32)getpid());
9f68db38 1493 forkprocess = 0;
463ee0b2 1494 hv_clear(pidstatus); /* we have no children */
a687059c
LW
1495 return Nullfp;
1496#undef THIS
1497#undef THAT
1498 }
62b28dd9 1499 do_execfree(); /* free any memory malloced by child on vfork */
a687059c 1500 close(p[that]);
62b28dd9
LW
1501 if (p[that] < p[this]) {
1502 dup2(p[this], p[that]);
1503 close(p[this]);
1504 p[this] = p[that];
1505 }
79072805 1506 sv = *av_fetch(fdpid,p[this],TRUE);
a0d0e21e 1507 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 1508 SvIVX(sv) = pid;
a687059c 1509 forkprocess = pid;
760ac839 1510 return PerlIO_fdopen(p[this], mode);
a687059c 1511}
7c0587c8 1512#else
f0c5b223 1513#if defined(atarist)
7c0587c8 1514FILE *popen();
760ac839 1515PerlIO *
79072805 1516my_popen(cmd,mode)
7c0587c8
LW
1517char *cmd;
1518char *mode;
1519{
760ac839
LW
1520 /* Needs work for PerlIO ! */
1521 return popen(PerlIO_exportFILE(cmd), mode);
7c0587c8
LW
1522}
1523#endif
1524
1525#endif /* !DOSISH */
a687059c 1526
748a9306 1527#ifdef DUMP_FDS
79072805 1528dump_fds(s)
ae986130
LW
1529char *s;
1530{
1531 int fd;
1532 struct stat tmpstatbuf;
1533
760ac839 1534 PerlIO_printf(PerlIO_stderr(),"%s", s);
ae986130 1535 for (fd = 0; fd < 32; fd++) {
a0d0e21e 1536 if (Fstat(fd,&tmpstatbuf) >= 0)
760ac839 1537 PerlIO_printf(PerlIO_stderr()," %d",fd);
ae986130 1538 }
760ac839 1539 PerlIO_printf(PerlIO_stderr(),"\n");
ae986130
LW
1540}
1541#endif
1542
fe14fcc3 1543#ifndef HAS_DUP2
fec02dd3 1544int
a687059c
LW
1545dup2(oldfd,newfd)
1546int oldfd;
1547int newfd;
1548{
a0d0e21e 1549#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD
1550 if (oldfd == newfd)
1551 return oldfd;
62b28dd9 1552 close(newfd);
fec02dd3 1553 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 1554#else
d48672a2 1555 int fdtmp[256];
79072805 1556 I32 fdx = 0;
ae986130
LW
1557 int fd;
1558
fe14fcc3 1559 if (oldfd == newfd)
fec02dd3 1560 return oldfd;
a687059c 1561 close(newfd);
fec02dd3 1562 while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
ae986130
LW
1563 fdtmp[fdx++] = fd;
1564 while (fdx > 0)
1565 close(fdtmp[--fdx]);
fec02dd3 1566 return fd;
62b28dd9 1567#endif
a687059c
LW
1568}
1569#endif
1570
1050c9ca 1571#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */
79072805
LW
1572I32
1573my_pclose(ptr)
760ac839 1574PerlIO *ptr;
a687059c 1575{
ecfc5424 1576 Signal_t (*hstat)(), (*istat)(), (*qstat)();
a687059c 1577 int status;
a0d0e21e 1578 SV **svp;
20188a90 1579 int pid;
a687059c 1580
760ac839 1581 svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
748a9306 1582 pid = (int)SvIVX(*svp);
a0d0e21e
LW
1583 SvREFCNT_dec(*svp);
1584 *svp = &sv_undef;
760ac839 1585 PerlIO_close(ptr);
7c0587c8
LW
1586#ifdef UTS
1587 if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
1588#endif
a687059c
LW
1589 hstat = signal(SIGHUP, SIG_IGN);
1590 istat = signal(SIGINT, SIG_IGN);
1591 qstat = signal(SIGQUIT, SIG_IGN);
748a9306
LW
1592 do {
1593 pid = wait4pid(pid, &status, 0);
1594 } while (pid == -1 && errno == EINTR);
20188a90
LW
1595 signal(SIGHUP, hstat);
1596 signal(SIGINT, istat);
1597 signal(SIGQUIT, qstat);
1598 return(pid < 0 ? pid : status);
1599}
4633a7c4
LW
1600#endif /* !DOSISH */
1601
1602#if !defined(DOSISH) || defined(OS2)
79072805 1603I32
20188a90
LW
1604wait4pid(pid,statusp,flags)
1605int pid;
1606int *statusp;
1607int flags;
1608{
79072805
LW
1609 SV *sv;
1610 SV** svp;
20188a90
LW
1611 char spid[16];
1612
1613 if (!pid)
1614 return -1;
20188a90
LW
1615 if (pid > 0) {
1616 sprintf(spid, "%d", pid);
79072805
LW
1617 svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
1618 if (svp && *svp != &sv_undef) {
463ee0b2 1619 *statusp = SvIVX(*svp);
748a9306 1620 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW
1621 return pid;
1622 }
1623 }
1624 else {
79072805 1625 HE *entry;
20188a90 1626
79072805
LW
1627 hv_iterinit(pidstatus);
1628 if (entry = hv_iternext(pidstatus)) {
a0d0e21e 1629 pid = atoi(hv_iterkey(entry,(I32*)statusp));
79072805 1630 sv = hv_iterval(pidstatus,entry);
463ee0b2 1631 *statusp = SvIVX(sv);
20188a90 1632 sprintf(spid, "%d", pid);
748a9306 1633 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
20188a90
LW
1634 return pid;
1635 }
1636 }
79072805
LW
1637#ifdef HAS_WAITPID
1638 return waitpid(pid,statusp,flags);
1639#else
a0d0e21e
LW
1640#ifdef HAS_WAIT4
1641 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1642#else
1643 {
1644 I32 result;
1645 if (flags)
1646 croak("Can't do waitpid with flags");
1647 else {
1648 while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
1649 pidgone(result,*statusp);
1650 if (result < 0)
1651 *statusp = -1;
1652 }
1653 return result;
a687059c
LW
1654 }
1655#endif
20188a90 1656#endif
a687059c 1657}
7c0587c8 1658#endif /* !DOSISH */
a687059c 1659
7c0587c8 1660void
de3bb511 1661/*SUPPRESS 590*/
a687059c
LW
1662pidgone(pid,status)
1663int pid;
1664int status;
1665{
79072805 1666 register SV *sv;
20188a90 1667 char spid[16];
a687059c 1668
20188a90 1669 sprintf(spid, "%d", pid);
79072805 1670 sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 1671 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 1672 SvIVX(sv) = status;
20188a90 1673 return;
a687059c
LW
1674}
1675
1050c9ca 1676#if defined(atarist) || (defined(OS2) && !defined(HAS_FORK))
7c0587c8 1677int pclose();
79072805
LW
1678I32
1679my_pclose(ptr)
760ac839 1680PerlIO *ptr;
a687059c 1681{
760ac839
LW
1682 /* Needs work for PerlIO ! */
1683 FILE *f = PerlIO_findFILE(ptr);
1684 I32 result = pclose(f);
1685 PerlIO_releaseFILE(ptr,f);
1686 return result;
a687059c 1687}
7c0587c8 1688#endif
9f68db38
LW
1689
1690void
1691repeatcpy(to,from,len,count)
1692register char *to;
1693register char *from;
79072805
LW
1694I32 len;
1695register I32 count;
9f68db38 1696{
79072805 1697 register I32 todo;
9f68db38
LW
1698 register char *frombase = from;
1699
1700 if (len == 1) {
1701 todo = *from;
1702 while (count-- > 0)
1703 *to++ = todo;
1704 return;
1705 }
1706 while (count-- > 0) {
1707 for (todo = len; todo > 0; todo--) {
1708 *to++ = *from++;
1709 }
1710 from = frombase;
1711 }
1712}
0f85fab0
LW
1713
1714#ifndef CASTNEGFLOAT
463ee0b2 1715U32
79072805 1716cast_ulong(f)
0f85fab0
LW
1717double f;
1718{
1719 long along;
1720
27e2fb84 1721#if CASTFLAGS & 2
34de22dd
LW
1722# define BIGDOUBLE 2147483648.0
1723 if (f >= BIGDOUBLE)
1724 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
1725#endif
0f85fab0
LW
1726 if (f >= 0.0)
1727 return (unsigned long)f;
1728 along = (long)f;
1729 return (unsigned long)along;
1730}
ed6116ce
LW
1731# undef BIGDOUBLE
1732#endif
1733
1734#ifndef CASTI32
5d94fbed 1735
5d94fbed
AD
1736/* Unfortunately, on some systems the cast_uv() function doesn't
1737 work with the system-supplied definition of ULONG_MAX. The
1738 comparison (f >= ULONG_MAX) always comes out true. It must be a
1739 problem with the compiler constant folding.
1740
1741 In any case, this workaround should be fine on any two's complement
1742 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
1743 ccflags.
1744 --Andy Dougherty <doughera@lafcol.lafayette.edu>
1745*/
1eb770ff
PP
1746
1747/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
1748 of LONG_(MIN/MAX).
1749 -- Kenneth Albanowski <kjahds@kjahds.com>
1750*/
1751
20cec16a
PP
1752#ifndef MY_UV_MAX
1753# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
5d94fbed
AD
1754#endif
1755
ed6116ce
LW
1756I32
1757cast_i32(f)
1758double f;
1759{
20cec16a
PP
1760 if (f >= I32_MAX)
1761 return (I32) I32_MAX;
1762 if (f <= I32_MIN)
1763 return (I32) I32_MIN;
ed6116ce
LW
1764 return (I32) f;
1765}
a0d0e21e
LW
1766
1767IV
1768cast_iv(f)
1769double f;
1770{
20cec16a
PP
1771 if (f >= IV_MAX)
1772 return (IV) IV_MAX;
1773 if (f <= IV_MIN)
1774 return (IV) IV_MIN;
a0d0e21e
LW
1775 return (IV) f;
1776}
5d94fbed
AD
1777
1778UV
1779cast_uv(f)
1780double f;
1781{
20cec16a
PP
1782 if (f >= MY_UV_MAX)
1783 return (UV) MY_UV_MAX;
5d94fbed
AD
1784 return (UV) f;
1785}
1786
0f85fab0 1787#endif
62b28dd9 1788
fe14fcc3 1789#ifndef HAS_RENAME
79072805 1790I32
62b28dd9
LW
1791same_dirent(a,b)
1792char *a;
1793char *b;
1794{
93a17b20
LW
1795 char *fa = strrchr(a,'/');
1796 char *fb = strrchr(b,'/');
62b28dd9
LW
1797 struct stat tmpstatbuf1;
1798 struct stat tmpstatbuf2;
1799#ifndef MAXPATHLEN
1800#define MAXPATHLEN 1024
1801#endif
1802 char tmpbuf[MAXPATHLEN+1];
1803
1804 if (fa)
1805 fa++;
1806 else
1807 fa = a;
1808 if (fb)
1809 fb++;
1810 else
1811 fb = b;
1812 if (strNE(a,b))
1813 return FALSE;
1814 if (fa == a)
6eb13c3b 1815 strcpy(tmpbuf,".");
62b28dd9
LW
1816 else
1817 strncpy(tmpbuf, a, fa - a);
a0d0e21e 1818 if (Stat(tmpbuf, &tmpstatbuf1) < 0)
62b28dd9
LW
1819 return FALSE;
1820 if (fb == b)
6eb13c3b 1821 strcpy(tmpbuf,".");
62b28dd9
LW
1822 else
1823 strncpy(tmpbuf, b, fb - b);
a0d0e21e 1824 if (Stat(tmpbuf, &tmpstatbuf2) < 0)
62b28dd9
LW
1825 return FALSE;
1826 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
1827 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
1828}
fe14fcc3
LW
1829#endif /* !HAS_RENAME */
1830
1831unsigned long
79072805 1832scan_oct(start, len, retlen)
fe14fcc3 1833char *start;
79072805
LW
1834I32 len;
1835I32 *retlen;
fe14fcc3
LW
1836{
1837 register char *s = start;
1838 register unsigned long retval = 0;
1839
748a9306 1840 while (len && *s >= '0' && *s <= '7') {
fe14fcc3
LW
1841 retval <<= 3;
1842 retval |= *s++ - '0';
748a9306 1843 len--;
fe14fcc3 1844 }
748a9306
LW
1845 if (dowarn && len && (*s == '8' || *s == '9'))
1846 warn("Illegal octal digit ignored");
fe14fcc3
LW
1847 *retlen = s - start;
1848 return retval;
1849}
1850
1851unsigned long
79072805 1852scan_hex(start, len, retlen)
fe14fcc3 1853char *start;
79072805
LW
1854I32 len;
1855I32 *retlen;
fe14fcc3
LW
1856{
1857 register char *s = start;
1858 register unsigned long retval = 0;
1859 char *tmp;
1860
93a17b20 1861 while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
fe14fcc3
LW
1862 retval <<= 4;
1863 retval |= (tmp - hexdigit) & 15;
1864 s++;
1865 }
1866 *retlen = s - start;
1867 return retval;
1868}
760ac839
LW
1869
1870
1871#ifdef HUGE_VAL
1872/*
1873 * This hack is to force load of "huge" support from libm.a
1874 * So it is in perl for (say) POSIX to use.
1875 * Needed for SunOS with Sun's 'acc' for example.
1876 */
1877double
1878Perl_huge()
1879{
1880 return HUGE_VAL;
1881}
1882#endif