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