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