util.c

   1 /*    util.c
   2  *
   3  *    Copyright (c) 1991-1994, Larry Wall
   4  *
   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.
   7  *
   8  */
   9
  10 /*
  11  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  12  * not content."  --Gandalf
  13  */
  14
  15 #include "EXTERN.h"
  16 #include "perl.h"
  17
  18 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  19 #include <signal.h>
  20 #endif
  21
  22 /* Omit this -- it causes too much grief on mixed systems.
  23 #ifdef I_UNISTD
  24 #  include <unistd.h>
  25 #endif
  26 */
  27
  28 #ifdef I_VFORK
  29 #  include <vfork.h>
  30 #endif
  31
  32 #ifdef I_FCNTL
  33 #  include <fcntl.h>
  34 #endif
  35 #ifdef I_SYS_FILE
  36 #  include <sys/file.h>
  37 #endif
  38
  39 #define FLUSH
  40
  41 #ifdef LEAKTEST
  42 static void xstat _((void));
  43 #endif
  44
  45 #ifndef safemalloc
  46
  47 /* paranoid version of malloc */
  48
  49 /* NOTE:  Do not call the next three routines directly.  Use the macros
  50  * in handy.h, so that we can easily redefine everything to do tracking of
  51  * allocated hunks back to the original New to track down any memory leaks.
  52  */
  53
  54 char *
  55 safemalloc(size)
  56 #ifdef MSDOS
  57 unsigned long size;
  58 #else
  59 MEM_SIZE size;
  60 #endif /* MSDOS */
  61 {
  62     char  *ptr;
  63 #ifdef MSDOS
  64         if (size > 0xffff) {
  65                 fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH;
  66                 my_exit(1);
  67         }
  68 #endif /* MSDOS */
  69 #ifdef DEBUGGING
  70     if ((long)size < 0)
  71         croak("panic: malloc");
  72 #endif
  73     ptr = malloc(size?size:1);  /* malloc(0) is NASTY on our system */
  74 #if !(defined(I286) || defined(atarist))
  75     DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
  76 #else
  77     DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
  78 #endif
  79     if (ptr != Nullch)
  80         return ptr;
  81     else if (nomemok)
  82         return Nullch;
  83     else {
  84         fputs(no_mem,stderr) FLUSH;
  85         my_exit(1);
  86     }
  87     /*NOTREACHED*/
  88 }
  89
  90 /* paranoid version of realloc */
  91
  92 char *
  93 saferealloc(where,size)
  94 char *where;
  95 #ifndef MSDOS
  96 MEM_SIZE size;
  97 #else
  98 unsigned long size;
  99 #endif /* MSDOS */
 100 {
 101     char *ptr;
 102 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
 103     char *realloc();
 104 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 105
 106 #ifdef MSDOS
 107         if (size > 0xffff) {
 108                 fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH;
 109                 my_exit(1);
 110         }
 111 #endif /* MSDOS */
 112     if (!where)
 113         croak("Null realloc");
 114 #ifdef DEBUGGING
 115     if ((long)size < 0)
 116         croak("panic: realloc");
 117 #endif
 118     ptr = realloc(where,size?size:1);   /* realloc(0) is NASTY on our system */
 119
 120 #if !(defined(I286) || defined(atarist))
 121     DEBUG_m( {
 122         fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
 123         fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
 124     } )
 125 #else
 126     DEBUG_m( {
 127         fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
 128         fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
 129     } )
 130 #endif
 131
 132     if (ptr != Nullch)
 133         return ptr;
 134     else if (nomemok)
 135         return Nullch;
 136     else {
 137         fputs(no_mem,stderr) FLUSH;
 138         my_exit(1);
 139     }
 140     /*NOTREACHED*/
 141 }
 142
 143 /* safe version of free */
 144
 145 void
 146 safefree(where)
 147 char *where;
 148 {
 149 #if !(defined(I286) || defined(atarist))
 150     DEBUG_m( fprintf(stderr,"0x%x: (%05d) free\n",where,an++));
 151 #else
 152     DEBUG_m( fprintf(stderr,"0x%lx: (%05d) free\n",where,an++));
 153 #endif
 154     if (where) {
 155         /*SUPPRESS 701*/
 156         free(where);
 157     }
 158 }
 159
 160 #endif /* !safemalloc */
 161
 162 #ifdef LEAKTEST
 163
 164 #define ALIGN sizeof(long)
 165
 166 char *
 167 safexmalloc(x,size)
 168 I32 x;
 169 MEM_SIZE size;
 170 {
 171     register char *where;
 172
 173     where = safemalloc(size + ALIGN);
 174     xcount[x]++;
 175     where[0] = x % 100;
 176     where[1] = x / 100;
 177     return where + ALIGN;
 178 }
 179
 180 char *
 181 safexrealloc(where,size)
 182 char *where;
 183 MEM_SIZE size;
 184 {
 185     register char *new = saferealloc(where - ALIGN, size + ALIGN);
 186     return new + ALIGN;
 187 }
 188
 189 void
 190 safexfree(where)
 191 char *where;
 192 {
 193     I32 x;
 194
 195     if (!where)
 196         return;
 197     where -= ALIGN;
 198     x = where[0] + 100 * where[1];
 199     xcount[x]--;
 200     safefree(where);
 201 }
 202
 203 static void
 204 xstat()
 205 {
 206     register I32 i;
 207
 208     for (i = 0; i < MAXXCOUNT; i++) {
 209         if (xcount[i] > lastxcount[i]) {
 210             fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
 211             lastxcount[i] = xcount[i];
 212         }
 213     }
 214 }
 215
 216 #endif /* LEAKTEST */
 217
 218 /* copy a string up to some (non-backslashed) delimiter, if any */
 219
 220 char *
 221 cpytill(to,from,fromend,delim,retlen)
 222 register char *to;
 223 register char *from;
 224 register char *fromend;
 225 register int delim;
 226 I32 *retlen;
 227 {
 228     char *origto = to;
 229
 230     for (; from < fromend; from++,to++) {
 231         if (*from == '\\') {
 232             if (from[1] == delim)
 233                 from++;
 234             else if (from[1] == '\\')
 235                 *to++ = *from++;
 236         }
 237         else if (*from == delim)
 238             break;
 239         *to = *from;
 240     }
 241     *to = '\0';
 242     *retlen = to - origto;
 243     return from;
 244 }
 245
 246 /* return ptr to little string in big string, NULL if not found */
 247 /* This routine was donated by Corey Satten. */
 248
 249 char *
 250 instr(big, little)
 251 register char *big;
 252 register char *little;
 253 {
 254     register char *s, *x;
 255     register I32 first;
 256
 257     if (!little)
 258         return big;
 259     first = *little++;
 260     if (!first)
 261         return big;
 262     while (*big) {
 263         if (*big++ != first)
 264             continue;
 265         for (x=big,s=little; *s; /**/ ) {
 266             if (!*x)
 267                 return Nullch;
 268             if (*s++ != *x++) {
 269                 s--;
 270                 break;
 271             }
 272         }
 273         if (!*s)
 274             return big-1;
 275     }
 276     return Nullch;
 277 }
 278
 279 /* same as instr but allow embedded nulls */
 280
 281 char *
 282 ninstr(big, bigend, little, lend)
 283 register char *big;
 284 register char *bigend;
 285 char *little;
 286 char *lend;
 287 {
 288     register char *s, *x;
 289     register I32 first = *little;
 290     register char *littleend = lend;
 291
 292     if (!first && little >= littleend)
 293         return big;
 294     if (bigend - big < littleend - little)
 295         return Nullch;
 296     bigend -= littleend - little++;
 297     while (big <= bigend) {
 298         if (*big++ != first)
 299             continue;
 300         for (x=big,s=little; s < littleend; /**/ ) {
 301             if (*s++ != *x++) {
 302                 s--;
 303                 break;
 304             }
 305         }
 306         if (s >= littleend)
 307             return big-1;
 308     }
 309     return Nullch;
 310 }
 311
 312 /* reverse of the above--find last substring */
 313
 314 char *
 315 rninstr(big, bigend, little, lend)
 316 register char *big;
 317 char *bigend;
 318 char *little;
 319 char *lend;
 320 {
 321     register char *bigbeg;
 322     register char *s, *x;
 323     register I32 first = *little;
 324     register char *littleend = lend;
 325
 326     if (!first && little >= littleend)
 327         return bigend;
 328     bigbeg = big;
 329     big = bigend - (littleend - little++);
 330     while (big >= bigbeg) {
 331         if (*big-- != first)
 332             continue;
 333         for (x=big+2,s=little; s < littleend; /**/ ) {
 334             if (*s++ != *x++) {
 335                 s--;
 336                 break;
 337             }
 338         }
 339         if (s >= littleend)
 340             return big+1;
 341     }
 342     return Nullch;
 343 }
 344
 345 void
 346 fbm_compile(sv, iflag)
 347 SV *sv;
 348 I32 iflag;
 349 {
 350     register unsigned char *s;
 351     register unsigned char *table;
 352     register U32 i;
 353     register U32 len = SvCUR(sv);
 354     I32 rarest = 0;
 355     U32 frequency = 256;
 356
 357     Sv_Grow(sv,len+258);
 358     table = (unsigned char*)(SvPVX(sv) + len + 1);
 359     s = table - 2;
 360     for (i = 0; i < 256; i++) {
 361         table[i] = len;
 362     }
 363     i = 0;
 364     while (s >= (unsigned char*)(SvPVX(sv)))
 365     {
 366         if (table[*s] == len) {
 367 #ifndef pdp11
 368             if (iflag)
 369                 table[*s] = table[fold[*s]] = i;
 370 #else
 371             if (iflag) {
 372                 I32 j;
 373                 j = fold[*s];
 374                 table[j] = i;
 375                 table[*s] = i;
 376             }
 377 #endif /* pdp11 */
 378             else
 379                 table[*s] = i;
 380         }
 381         s--,i++;
 382     }
 383     sv_upgrade(sv, SVt_PVBM);
 384     sv_magic(sv, Nullsv, 'B', Nullch, 0);                       /* deep magic */
 385     SvVALID_on(sv);
 386
 387     s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
 388     if (iflag) {
 389         register U32 tmp, foldtmp;
 390         SvCASEFOLD_on(sv);
 391         for (i = 0; i < len; i++) {
 392             tmp=freq[s[i]];
 393             foldtmp=freq[fold[s[i]]];
 394             if (tmp < frequency && foldtmp < frequency) {
 395                 rarest = i;
 396                 /* choose most frequent among the two */
 397                 frequency = (tmp > foldtmp) ? tmp : foldtmp;
 398             }
 399         }
 400     }
 401     else {
 402         for (i = 0; i < len; i++) {
 403             if (freq[s[i]] < frequency) {
 404                 rarest = i;
 405                 frequency = freq[s[i]];
 406             }
 407         }
 408     }
 409     BmRARE(sv) = s[rarest];
 410     BmPREVIOUS(sv) = rarest;
 411     DEBUG_r(fprintf(stderr,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
 412 }
 413
 414 char *
 415 fbm_instr(big, bigend, littlestr)
 416 unsigned char *big;
 417 register unsigned char *bigend;
 418 SV *littlestr;
 419 {
 420     register unsigned char *s;
 421     register I32 tmp;
 422     register I32 littlelen;
 423     register unsigned char *little;
 424     register unsigned char *table;
 425     register unsigned char *olds;
 426     register unsigned char *oldlittle;
 427
 428     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 429         STRLEN len;
 430         char *l = SvPV(littlestr,len);
 431         if (!len)
 432             return (char*)big;
 433         return ninstr((char*)big,(char*)bigend, l, l + len);
 434     }
 435
 436     littlelen = SvCUR(littlestr);
 437     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 438         if (littlelen > bigend - big)
 439             return Nullch;
 440         little = (unsigned char*)SvPVX(littlestr);
 441         if (SvCASEFOLD(littlestr)) {    /* oops, fake it */
 442             big = bigend - littlelen;           /* just start near end */
 443             if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
 444                 big--;
 445         }
 446         else {
 447             s = bigend - littlelen;
 448             if (*s == *little && bcmp(s,little,littlelen)==0)
 449                 return (char*)s;                /* how sweet it is */
 450             else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
 451               && s > big) {
 452                     s--;
 453                 if (*s == *little && bcmp(s,little,littlelen)==0)
 454                     return (char*)s;
 455             }
 456             return Nullch;
 457         }
 458     }
 459     table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
 460     if (--littlelen >= bigend - big)
 461         return Nullch;
 462     s = big + littlelen;
 463     oldlittle = little = table - 2;
 464     if (SvCASEFOLD(littlestr)) {        /* case insensitive? */
 465         if (s < bigend) {
 466           top1:
 467             /*SUPPRESS 560*/
 468             if (tmp = table[*s]) {
 469 #ifdef POINTERRIGOR
 470                 if (bigend - s > tmp) {
 471                     s += tmp;
 472                     goto top1;
 473                 }
 474 #else
 475                 if ((s += tmp) < bigend)
 476                     goto top1;
 477 #endif
 478                 return Nullch;
 479             }
 480             else {
 481                 tmp = littlelen;        /* less expensive than calling strncmp() */
 482                 olds = s;
 483                 while (tmp--) {
 484                     if (*--s == *--little || fold[*s] == *little)
 485                         continue;
 486                     s = olds + 1;       /* here we pay the price for failure */
 487                     little = oldlittle;
 488                     if (s < bigend)     /* fake up continue to outer loop */
 489                         goto top1;
 490                     return Nullch;
 491                 }
 492                 return (char *)s;
 493             }
 494         }
 495     }
 496     else {
 497         if (s < bigend) {
 498           top2:
 499             /*SUPPRESS 560*/
 500             if (tmp = table[*s]) {
 501 #ifdef POINTERRIGOR
 502                 if (bigend - s > tmp) {
 503                     s += tmp;
 504                     goto top2;
 505                 }
 506 #else
 507                 if ((s += tmp) < bigend)
 508                     goto top2;
 509 #endif
 510                 return Nullch;
 511             }
 512             else {
 513                 tmp = littlelen;        /* less expensive than calling strncmp() */
 514                 olds = s;
 515                 while (tmp--) {
 516                     if (*--s == *--little)
 517                         continue;
 518                     s = olds + 1;       /* here we pay the price for failure */
 519                     little = oldlittle;
 520                     if (s < bigend)     /* fake up continue to outer loop */
 521                         goto top2;
 522                     return Nullch;
 523                 }
 524                 return (char *)s;
 525             }
 526         }
 527     }
 528     return Nullch;
 529 }
 530
 531 char *
 532 screaminstr(bigstr, littlestr)
 533 SV *bigstr;
 534 SV *littlestr;
 535 {
 536     register unsigned char *s, *x;
 537     register unsigned char *big;
 538     register I32 pos;
 539     register I32 previous;
 540     register I32 first;
 541     register unsigned char *little;
 542     register unsigned char *bigend;
 543     register unsigned char *littleend;
 544
 545     if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
 546         return Nullch;
 547     little = (unsigned char *)(SvPVX(littlestr));
 548     littleend = little + SvCUR(littlestr);
 549     first = *little++;
 550     previous = BmPREVIOUS(littlestr);
 551     big = (unsigned char *)(SvPVX(bigstr));
 552     bigend = big + SvCUR(bigstr);
 553     while (pos < previous) {
 554         if (!(pos += screamnext[pos]))
 555             return Nullch;
 556     }
 557 #ifdef POINTERRIGOR
 558     if (SvCASEFOLD(littlestr)) {        /* case insignificant? */
 559         do {
 560             if (big[pos-previous] != first && big[pos-previous] != fold[first])
 561                 continue;
 562             for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
 563                 if (x >= bigend)
 564                     return Nullch;
 565                 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
 566                     s--;
 567                     break;
 568                 }
 569             }
 570             if (s == littleend)
 571                 return (char *)(big+pos-previous);
 572         } while (
 573                 pos += screamnext[pos]  /* does this goof up anywhere? */
 574             );
 575     }
 576     else {
 577         do {
 578             if (big[pos-previous] != first)
 579                 continue;
 580             for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
 581                 if (x >= bigend)
 582                     return Nullch;
 583                 if (*s++ != *x++) {
 584                     s--;
 585                     break;
 586                 }
 587             }
 588             if (s == littleend)
 589                 return (char *)(big+pos-previous);
 590         } while ( pos += screamnext[pos] );
 591     }
 592 #else /* !POINTERRIGOR */
 593     big -= previous;
 594     if (SvCASEFOLD(littlestr)) {        /* case insignificant? */
 595         do {
 596             if (big[pos] != first && big[pos] != fold[first])
 597                 continue;
 598             for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 599                 if (x >= bigend)
 600                     return Nullch;
 601                 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
 602                     s--;
 603                     break;
 604                 }
 605             }
 606             if (s == littleend)
 607                 return (char *)(big+pos);
 608         } while (
 609                 pos += screamnext[pos]  /* does this goof up anywhere? */
 610             );
 611     }
 612     else {
 613         do {
 614             if (big[pos] != first)
 615                 continue;
 616             for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 617                 if (x >= bigend)
 618                     return Nullch;
 619                 if (*s++ != *x++) {
 620                     s--;
 621                     break;
 622                 }
 623             }
 624             if (s == littleend)
 625                 return (char *)(big+pos);
 626         } while (
 627                 pos += screamnext[pos]
 628             );
 629     }
 630 #endif /* POINTERRIGOR */
 631     return Nullch;
 632 }
 633
 634 I32
 635 ibcmp(a,b,len)
 636 register U8 *a;
 637 register U8 *b;
 638 register I32 len;
 639 {
 640     while (len--) {
 641         if (*a == *b) {
 642             a++,b++;
 643             continue;
 644         }
 645         if (fold[*a++] == *b++)
 646             continue;
 647         return 1;
 648     }
 649     return 0;
 650 }
 651
 652 /* copy a string to a safe spot */
 653
 654 char *
 655 savepv(sv)
 656 char *sv;
 657 {
 658     register char *newaddr;
 659
 660     New(902,newaddr,strlen(sv)+1,char);
 661     (void)strcpy(newaddr,sv);
 662     return newaddr;
 663 }
 664
 665 /* same thing but with a known length */
 666
 667 char *
 668 savepvn(sv, len)
 669 char *sv;
 670 register I32 len;
 671 {
 672     register char *newaddr;
 673
 674     New(903,newaddr,len+1,char);
 675     Copy(sv,newaddr,len,char);          /* might not be null terminated */
 676     newaddr[len] = '\0';                /* is now */
 677     return newaddr;
 678 }
 679
 680 #if !defined(I_STDARG) && !defined(I_VARARGS)
 681
 682 /*
 683  * Fallback on the old hackers way of doing varargs
 684  */
 685
 686 /*VARARGS1*/
 687 char *
 688 mess(pat,a1,a2,a3,a4)
 689 char *pat;
 690 long a1, a2, a3, a4;
 691 {
 692     char *s;
 693     I32 usermess = strEQ(pat,"%s");
 694     SV *tmpstr;
 695
 696     s = buf;
 697     if (usermess) {
 698         tmpstr = sv_newmortal();
 699         sv_setpv(tmpstr, (char*)a1);
 700         *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
 701     }
 702     else {
 703         (void)sprintf(s,pat,a1,a2,a3,a4);
 704         s += strlen(s);
 705     }
 706
 707     if (s[-1] != '\n') {
 708         if (dirty)
 709             strcpy(s, " during global destruction.\n");
 710         else {
 711             if (curcop->cop_line) {
 712                 (void)sprintf(s," at %s line %ld",
 713                   SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
 714                 s += strlen(s);
 715             }
 716             if (GvIO(last_in_gv) &&
 717                 IoLINES(GvIOp(last_in_gv)) ) {
 718                 (void)sprintf(s,", <%s> %s %ld",
 719                   last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
 720                   strEQ(rs,"\n") ? "line" : "chunk",
 721                   (long)IoLINES(GvIOp(last_in_gv)));
 722                 s += strlen(s);
 723             }
 724             (void)strcpy(s,".\n");
 725         }
 726         if (usermess)
 727             sv_catpv(tmpstr,buf+1);
 728     }
 729     if (usermess)
 730         return SvPVX(tmpstr);
 731     else
 732         return buf;
 733 }
 734
 735 /*VARARGS1*/
 736 void croak(pat,a1,a2,a3,a4)
 737 char *pat;
 738 long a1, a2, a3, a4;
 739 {
 740     char *tmps;
 741     char *message;
 742
 743     message = mess(pat,a1,a2,a3,a4);
 744     if (in_eval) {
 745         restartop = die_where(message);
 746         longjmp(top_env, 3);
 747     }
 748     fputs(message,stderr);
 749     (void)fflush(stderr);
 750     if (e_fp)
 751         (void)UNLINK(e_tmpname);
 752     statusvalue >>= 8;
 753     my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
 754 }
 755
 756 /*VARARGS1*/
 757 void warn(pat,a1,a2,a3,a4)
 758 char *pat;
 759 long a1, a2, a3, a4;
 760 {
 761     char *message;
 762
 763     message = mess(pat,a1,a2,a3,a4);
 764     fputs(message,stderr);
 765 #ifdef LEAKTEST
 766     DEBUG_L(xstat());
 767 #endif
 768     (void)fflush(stderr);
 769 }
 770
 771 #else /* !defined(I_STDARG) && !defined(I_VARARGS) */
 772
 773 #ifdef I_STDARG
 774 char *
 775 mess(char *pat, va_list *args)
 776 #else
 777 /*VARARGS0*/
 778 char *
 779 mess(pat, args)
 780     char *pat;
 781     va_list *args;
 782 #endif
 783 {
 784     char *s;
 785     SV *tmpstr;
 786     I32 usermess;
 787 #ifndef HAS_VPRINTF
 788 #ifdef USE_CHAR_VSPRINTF
 789     char *vsprintf();
 790 #else
 791     I32 vsprintf();
 792 #endif
 793 #endif
 794
 795     s = buf;
 796     usermess = strEQ(pat, "%s");
 797     if (usermess) {
 798         tmpstr = sv_newmortal();
 799         sv_setpv(tmpstr, va_arg(*args, char *));
 800         *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
 801     }
 802     else {
 803         (void) vsprintf(s,pat,*args);
 804         s += strlen(s);
 805     }
 806     va_end(*args);
 807
 808     if (s[-1] != '\n') {
 809         if (dirty)
 810             strcpy(s, " during global destruction.\n");
 811         else {
 812             if (curcop->cop_line) {
 813                 (void)sprintf(s," at %s line %ld",
 814                   SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
 815                 s += strlen(s);
 816             }
 817             if (GvIO(last_in_gv) &&
 818                 IoLINES(GvIOp(last_in_gv)) ) {
 819                 (void)sprintf(s,", <%s> %s %ld",
 820                   last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
 821                   strEQ(rs,"\n") ? "line" : "chunk",
 822                   (long)IoLINES(GvIOp(last_in_gv)));
 823                 s += strlen(s);
 824             }
 825             (void)strcpy(s,".\n");
 826         }
 827         if (usermess)
 828             sv_catpv(tmpstr,buf+1);
 829     }
 830
 831     if (usermess)
 832         return SvPVX(tmpstr);
 833     else
 834         return buf;
 835 }
 836
 837 #ifdef I_STDARG
 838 void
 839 croak(char* pat, ...)
 840 #else
 841 /*VARARGS0*/
 842 void
 843 croak(pat, va_alist)
 844     char *pat;
 845     va_dcl
 846 #endif
 847 {
 848     va_list args;
 849     char *message;
 850
 851 #ifdef I_STDARG
 852     va_start(args, pat);
 853 #else
 854     va_start(args);
 855 #endif
 856     message = mess(pat, &args);
 857     va_end(args);
 858     if (in_eval) {
 859         restartop = die_where(message);
 860         longjmp(top_env, 3);
 861     }
 862     fputs(message,stderr);
 863     (void)fflush(stderr);
 864     if (e_fp)
 865         (void)UNLINK(e_tmpname);
 866     statusvalue >>= 8;
 867     my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
 868 }
 869
 870 void
 871 #ifdef I_STDARG
 872 warn(char* pat,...)
 873 #else
 874 /*VARARGS0*/
 875 warn(pat,va_alist)
 876     char *pat;
 877     va_dcl
 878 #endif
 879 {
 880     va_list args;
 881     char *message;
 882
 883 #ifdef I_STDARG
 884     va_start(args, pat);
 885 #else
 886     va_start(args);
 887 #endif
 888     message = mess(pat, &args);
 889     va_end(args);
 890
 891     fputs(message,stderr);
 892 #ifdef LEAKTEST
 893     DEBUG_L(xstat());
 894 #endif
 895     (void)fflush(stderr);
 896 }
 897 #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
 898
 899 #ifndef VMS  /* VMS' my_setenv() is in VMS.c */
 900 void
 901 my_setenv(nam,val)
 902 char *nam, *val;
 903 {
 904     register I32 i=setenv_getix(nam);           /* where does it go? */
 905
 906     if (environ == origenviron) {       /* need we copy environment? */
 907         I32 j;
 908         I32 max;
 909         char **tmpenv;
 910
 911         /*SUPPRESS 530*/
 912         for (max = i; environ[max]; max++) ;
 913         New(901,tmpenv, max+2, char*);
 914         for (j=0; j<max; j++)           /* copy environment */
 915             tmpenv[j] = savepv(environ[j]);
 916         tmpenv[max] = Nullch;
 917         environ = tmpenv;               /* tell exec where it is now */
 918     }
 919     if (!val) {
 920         while (environ[i]) {
 921             environ[i] = environ[i+1];
 922             i++;
 923         }
 924         return;
 925     }
 926     if (!environ[i]) {                  /* does not exist yet */
 927         Renew(environ, i+2, char*);     /* just expand it a bit */
 928         environ[i+1] = Nullch;  /* make sure it's null terminated */
 929     }
 930     else
 931         Safefree(environ[i]);
 932     New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
 933 #ifndef MSDOS
 934     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
 935 #else
 936     /* MS-DOS requires environment variable names to be in uppercase */
 937     /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
 938      * some utilities and applications may break because they only look
 939      * for upper case strings. (Fixed strupr() bug here.)]
 940      */
 941     strcpy(environ[i],nam); strupr(environ[i]);
 942     (void)sprintf(environ[i] + strlen(nam),"=%s",val);
 943 #endif /* MSDOS */
 944 }
 945
 946 I32
 947 setenv_getix(nam)
 948 char *nam;
 949 {
 950     register I32 i, len = strlen(nam);
 951
 952     for (i = 0; environ[i]; i++) {
 953         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
 954             break;                      /* strnEQ must come first to avoid */
 955     }                                   /* potential SEGV's */
 956     return i;
 957 }
 958 #endif /* !VMS */
 959
 960 #ifdef EUNICE
 961 I32
 962 unlnk(f)        /* unlink all versions of a file */
 963 char *f;
 964 {
 965     I32 i;
 966
 967     for (i = 0; unlink(f) >= 0; i++) ;
 968     return i ? 0 : -1;
 969 }
 970 #endif
 971
 972 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 973 char *
 974 my_bcopy(from,to,len)
 975 register char *from;
 976 register char *to;
 977 register I32 len;
 978 {
 979     char *retval = to;
 980
 981     if (from - to >= 0) {
 982         while (len--)
 983             *to++ = *from++;
 984     }
 985     else {
 986         to += len;
 987         from += len;
 988         while (len--)
 989             *(--to) = *(--from);
 990     }
 991     return retval;
 992 }
 993 #endif
 994
 995 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
 996 char *
 997 my_bzero(loc,len)
 998 register char *loc;
 999 register I32 len;
1000 {
1001     char *retval = loc;
1002
1003     while (len--)
1004         *loc++ = 0;
1005     return retval;
1006 }
1007 #endif
1008
1009 #ifndef HAS_MEMCMP
1010 I32
1011 my_memcmp(s1,s2,len)
1012 register unsigned char *s1;
1013 register unsigned char *s2;
1014 register I32 len;
1015 {
1016     register I32 tmp;
1017
1018     while (len--) {
1019         if (tmp = *s1++ - *s2++)
1020             return tmp;
1021     }
1022     return 0;
1023 }
1024 #endif /* HAS_MEMCMP */
1025
1026 #ifdef I_VARARGS
1027 #ifndef HAS_VPRINTF
1028
1029 #ifdef USE_CHAR_VSPRINTF
1030 char *
1031 #else
1032 int
1033 #endif
1034 vsprintf(dest, pat, args)
1035 char *dest, *pat, *args;
1036 {
1037     FILE fakebuf;
1038
1039     fakebuf._ptr = dest;
1040     fakebuf._cnt = 32767;
1041 #ifndef _IOSTRG
1042 #define _IOSTRG 0
1043 #endif
1044     fakebuf._flag = _IOWRT|_IOSTRG;
1045     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1046     (void)putc('\0', &fakebuf);
1047 #ifdef USE_CHAR_VSPRINTF
1048     return(dest);
1049 #else
1050     return 0;           /* perl doesn't use return value */
1051 #endif
1052 }
1053
1054 int
1055 vfprintf(fd, pat, args)
1056 FILE *fd;
1057 char *pat, *args;
1058 {
1059     _doprnt(pat, args, fd);
1060     return 0;           /* wrong, but perl doesn't use the return value */
1061 }
1062 #endif /* HAS_VPRINTF */
1063 #endif /* I_VARARGS */
1064
1065 /*
1066  * I think my_swap(), htonl() and ntohl() have never been used.
1067  * perl.h contains last-chance references to my_swap(), my_htonl()
1068  * and my_ntohl().  I presume these are the intended functions;
1069  * but htonl() and ntohl() have the wrong names.  There are no
1070  * functions my_htonl() and my_ntohl() defined anywhere.
1071  * -DWS
1072  */
1073 #ifdef MYSWAP
1074 #if BYTEORDER != 0x4321
1075 short
1076 my_swap(s)
1077 short s;
1078 {
1079 #if (BYTEORDER & 1) == 0
1080     short result;
1081
1082     result = ((s & 255) << 8) + ((s >> 8) & 255);
1083     return result;
1084 #else
1085     return s;
1086 #endif
1087 }
1088
1089 long
1090 htonl(l)
1091 register long l;
1092 {
1093     union {
1094         long result;
1095         char c[sizeof(long)];
1096     } u;
1097
1098 #if BYTEORDER == 0x1234
1099     u.c[0] = (l >> 24) & 255;
1100     u.c[1] = (l >> 16) & 255;
1101     u.c[2] = (l >> 8) & 255;
1102     u.c[3] = l & 255;
1103     return u.result;
1104 #else
1105 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1106     croak("Unknown BYTEORDER\n");
1107 #else
1108     register I32 o;
1109     register I32 s;
1110
1111     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1112         u.c[o & 0xf] = (l >> s) & 255;
1113     }
1114     return u.result;
1115 #endif
1116 #endif
1117 }
1118
1119 long
1120 ntohl(l)
1121 register long l;
1122 {
1123     union {
1124         long l;
1125         char c[sizeof(long)];
1126     } u;
1127
1128 #if BYTEORDER == 0x1234
1129     u.c[0] = (l >> 24) & 255;
1130     u.c[1] = (l >> 16) & 255;
1131     u.c[2] = (l >> 8) & 255;
1132     u.c[3] = l & 255;
1133     return u.l;
1134 #else
1135 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1136     croak("Unknown BYTEORDER\n");
1137 #else
1138     register I32 o;
1139     register I32 s;
1140
1141     u.l = l;
1142     l = 0;
1143     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1144         l |= (u.c[o & 0xf] & 255) << s;
1145     }
1146     return l;
1147 #endif
1148 #endif
1149 }
1150
1151 #endif /* BYTEORDER != 0x4321 */
1152 #endif /* MYSWAP */
1153
1154 /*
1155  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1156  * If these functions are defined,
1157  * the BYTEORDER is neither 0x1234 nor 0x4321.
1158  * However, this is not assumed.
1159  * -DWS
1160  */
1161
1162 #define HTOV(name,type)                                         \
1163         type                                                    \
1164         name (n)                                                \
1165         register type n;                                        \
1166         {                                                       \
1167             union {                                             \
1168                 type value;                                     \
1169                 char c[sizeof(type)];                           \
1170             } u;                                                \
1171             register I32 i;                                     \
1172             register I32 s;                                     \
1173             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1174                 u.c[i] = (n >> s) & 0xFF;                       \
1175             }                                                   \
1176             return u.value;                                     \
1177         }
1178
1179 #define VTOH(name,type)                                         \
1180         type                                                    \
1181         name (n)                                                \
1182         register type n;                                        \
1183         {                                                       \
1184             union {                                             \
1185                 type value;                                     \
1186                 char c[sizeof(type)];                           \
1187             } u;                                                \
1188             register I32 i;                                     \
1189             register I32 s;                                     \
1190             u.value = n;                                        \
1191             n = 0;                                              \
1192             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1193                 n += (u.c[i] & 0xFF) << s;                      \
1194             }                                                   \
1195             return n;                                           \
1196         }
1197
1198 #if defined(HAS_HTOVS) && !defined(htovs)
1199 HTOV(htovs,short)
1200 #endif
1201 #if defined(HAS_HTOVL) && !defined(htovl)
1202 HTOV(htovl,long)
1203 #endif
1204 #if defined(HAS_VTOHS) && !defined(vtohs)
1205 VTOH(vtohs,short)
1206 #endif
1207 #if defined(HAS_VTOHL) && !defined(vtohl)
1208 VTOH(vtohl,long)
1209 #endif
1210
1211 #if  !defined(DOSISH) && !defined(VMS)  /* VMS' my_popen() is in VMS.c */
1212 FILE *
1213 my_popen(cmd,mode)
1214 char    *cmd;
1215 char    *mode;
1216 {
1217     int p[2];
1218     register I32 this, that;
1219     register I32 pid;
1220     SV *sv;
1221     I32 doexec = strNE(cmd,"-");
1222
1223     if (pipe(p) < 0)
1224         return Nullfp;
1225     this = (*mode == 'w');
1226     that = !this;
1227     if (tainting) {
1228         if (doexec) {
1229             taint_env();
1230             taint_proper("Insecure %s%s", "EXEC");
1231         }
1232     }
1233     while ((pid = (doexec?vfork():fork())) < 0) {
1234         if (errno != EAGAIN) {
1235             close(p[this]);
1236             if (!doexec)
1237                 croak("Can't fork");
1238             return Nullfp;
1239         }
1240         sleep(5);
1241     }
1242     if (pid == 0) {
1243         GV* tmpgv;
1244
1245 #define THIS that
1246 #define THAT this
1247         close(p[THAT]);
1248         if (p[THIS] != (*mode == 'r')) {
1249             dup2(p[THIS], *mode == 'r');
1250             close(p[THIS]);
1251         }
1252         if (doexec) {
1253 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1254             int fd;
1255
1256 #ifndef NOFILE
1257 #define NOFILE 20
1258 #endif
1259             for (fd = maxsysfd + 1; fd < NOFILE; fd++)
1260                 close(fd);
1261 #endif
1262             do_exec(cmd);       /* may or may not use the shell */
1263             _exit(1);
1264         }
1265         /*SUPPRESS 560*/
1266         if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1267             sv_setiv(GvSV(tmpgv),(I32)getpid());
1268         forkprocess = 0;
1269         hv_clear(pidstatus);    /* we have no children */
1270         return Nullfp;
1271 #undef THIS
1272 #undef THAT
1273     }
1274     do_execfree();      /* free any memory malloced by child on vfork */
1275     close(p[that]);
1276     if (p[that] < p[this]) {
1277         dup2(p[this], p[that]);
1278         close(p[this]);
1279         p[this] = p[that];
1280     }
1281     sv = *av_fetch(fdpid,p[this],TRUE);
1282     (void)SvUPGRADE(sv,SVt_IV);
1283     SvIVX(sv) = pid;
1284     forkprocess = pid;
1285     return fdopen(p[this], mode);
1286 }
1287 #else
1288 #ifdef atarist
1289 FILE *popen();
1290 FILE *
1291 my_popen(cmd,mode)
1292 char    *cmd;
1293 char    *mode;
1294 {
1295     return popen(cmd, mode);
1296 }
1297 #endif
1298
1299 #endif /* !DOSISH */
1300
1301 #ifdef NOTDEF
1302 dump_fds(s)
1303 char *s;
1304 {
1305     int fd;
1306     struct stat tmpstatbuf;
1307
1308     fprintf(stderr,"%s", s);
1309     for (fd = 0; fd < 32; fd++) {
1310         if (Fstat(fd,&tmpstatbuf) >= 0)
1311             fprintf(stderr," %d",fd);
1312     }
1313     fprintf(stderr,"\n");
1314 }
1315 #endif
1316
1317 #ifndef HAS_DUP2
1318 dup2(oldfd,newfd)
1319 int oldfd;
1320 int newfd;
1321 {
1322 #if defined(HAS_FCNTL) && defined(F_DUPFD)
1323     close(newfd);
1324     fcntl(oldfd, F_DUPFD, newfd);
1325 #else
1326     int fdtmp[256];
1327     I32 fdx = 0;
1328     int fd;
1329
1330     if (oldfd == newfd)
1331         return 0;
1332     close(newfd);
1333     while ((fd = dup(oldfd)) != newfd)  /* good enough for low fd's */
1334         fdtmp[fdx++] = fd;
1335     while (fdx > 0)
1336         close(fdtmp[--fdx]);
1337 #endif
1338 }
1339 #endif
1340
1341 #ifndef DOSISH
1342 #ifndef VMS /* VMS' my_pclose() is in VMS.c */
1343 I32
1344 my_pclose(ptr)
1345 FILE *ptr;
1346 {
1347     Signal_t (*hstat)(), (*istat)(), (*qstat)();
1348     int status;
1349     SV **svp;
1350     int pid;
1351
1352     svp = av_fetch(fdpid,fileno(ptr),TRUE);
1353     pid = SvIVX(*svp);
1354     SvREFCNT_dec(*svp);
1355     *svp = &sv_undef;
1356     fclose(ptr);
1357 #ifdef UTS
1358     if(kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
1359 #endif
1360     hstat = signal(SIGHUP, SIG_IGN);
1361     istat = signal(SIGINT, SIG_IGN);
1362     qstat = signal(SIGQUIT, SIG_IGN);
1363     pid = wait4pid(pid, &status, 0);
1364     signal(SIGHUP, hstat);
1365     signal(SIGINT, istat);
1366     signal(SIGQUIT, qstat);
1367     return(pid < 0 ? pid : status);
1368 }
1369 #endif /* !VMS */
1370 I32
1371 wait4pid(pid,statusp,flags)
1372 int pid;
1373 int *statusp;
1374 int flags;
1375 {
1376     SV *sv;
1377     SV** svp;
1378     char spid[16];
1379
1380     if (!pid)
1381         return -1;
1382     if (pid > 0) {
1383         sprintf(spid, "%d", pid);
1384         svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
1385         if (svp && *svp != &sv_undef) {
1386             *statusp = SvIVX(*svp);
1387             hv_delete(pidstatus,spid,strlen(spid));
1388             return pid;
1389         }
1390     }
1391     else {
1392         HE *entry;
1393
1394         hv_iterinit(pidstatus);
1395         if (entry = hv_iternext(pidstatus)) {
1396             pid = atoi(hv_iterkey(entry,(I32*)statusp));
1397             sv = hv_iterval(pidstatus,entry);
1398             *statusp = SvIVX(sv);
1399             sprintf(spid, "%d", pid);
1400             hv_delete(pidstatus,spid,strlen(spid));
1401             return pid;
1402         }
1403     }
1404 #ifdef HAS_WAITPID
1405     return waitpid(pid,statusp,flags);
1406 #else
1407 #ifdef HAS_WAIT4
1408     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1409 #else
1410     {
1411         I32 result;
1412         if (flags)
1413             croak("Can't do waitpid with flags");
1414         else {
1415             while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
1416                 pidgone(result,*statusp);
1417             if (result < 0)
1418                 *statusp = -1;
1419         }
1420         return result;
1421     }
1422 #endif
1423 #endif
1424 }
1425 #endif /* !DOSISH */
1426
1427 void
1428 /*SUPPRESS 590*/
1429 pidgone(pid,status)
1430 int pid;
1431 int status;
1432 {
1433     register SV *sv;
1434     char spid[16];
1435
1436     sprintf(spid, "%d", pid);
1437     sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
1438     (void)SvUPGRADE(sv,SVt_IV);
1439     SvIVX(sv) = status;
1440     return;
1441 }
1442
1443 #ifdef atarist
1444 int pclose();
1445 I32
1446 my_pclose(ptr)
1447 FILE *ptr;
1448 {
1449     return pclose(ptr);
1450 }
1451 #endif
1452
1453 void
1454 repeatcpy(to,from,len,count)
1455 register char *to;
1456 register char *from;
1457 I32 len;
1458 register I32 count;
1459 {
1460     register I32 todo;
1461     register char *frombase = from;
1462
1463     if (len == 1) {
1464         todo = *from;
1465         while (count-- > 0)
1466             *to++ = todo;
1467         return;
1468     }
1469     while (count-- > 0) {
1470         for (todo = len; todo > 0; todo--) {
1471             *to++ = *from++;
1472         }
1473         from = frombase;
1474     }
1475 }
1476
1477 #ifndef CASTNEGFLOAT
1478 U32
1479 cast_ulong(f)
1480 double f;
1481 {
1482     long along;
1483
1484 #if CASTFLAGS & 2
1485 #   define BIGDOUBLE 2147483648.0
1486     if (f >= BIGDOUBLE)
1487         return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
1488 #endif
1489     if (f >= 0.0)
1490         return (unsigned long)f;
1491     along = (long)f;
1492     return (unsigned long)along;
1493 }
1494 # undef BIGDOUBLE
1495 #endif
1496
1497 #ifndef CASTI32
1498 I32
1499 cast_i32(f)
1500 double f;
1501 {
1502 #   define BIGDOUBLE 2147483648.0        /* Assume 32 bit int's ! */
1503 #   define BIGNEGDOUBLE (-2147483648.0)
1504     if (f >= BIGDOUBLE)
1505         return (I32)fmod(f, BIGDOUBLE);
1506     if (f <= BIGNEGDOUBLE)
1507         return (I32)fmod(f, BIGNEGDOUBLE);
1508     return (I32) f;
1509 }
1510 # undef BIGDOUBLE
1511 # undef BIGNEGDOUBLE
1512
1513 IV
1514 cast_iv(f)
1515 double f;
1516 {
1517     /* XXX  This should be fixed.  It assumes 32 bit IV's. */
1518 #   define BIGDOUBLE 2147483648.0        /* Assume 32 bit IV's ! */
1519 #   define BIGNEGDOUBLE (-2147483648.0)
1520     if (f >= BIGDOUBLE)
1521         return (IV)fmod(f, BIGDOUBLE);
1522     if (f <= BIGNEGDOUBLE)
1523         return (IV)fmod(f, BIGNEGDOUBLE);
1524     return (IV) f;
1525 }
1526 # undef BIGDOUBLE
1527 # undef BIGNEGDOUBLE
1528 #endif
1529
1530 #ifndef HAS_RENAME
1531 I32
1532 same_dirent(a,b)
1533 char *a;
1534 char *b;
1535 {
1536     char *fa = strrchr(a,'/');
1537     char *fb = strrchr(b,'/');
1538     struct stat tmpstatbuf1;
1539     struct stat tmpstatbuf2;
1540 #ifndef MAXPATHLEN
1541 #define MAXPATHLEN 1024
1542 #endif
1543     char tmpbuf[MAXPATHLEN+1];
1544
1545     if (fa)
1546         fa++;
1547     else
1548         fa = a;
1549     if (fb)
1550         fb++;
1551     else
1552         fb = b;
1553     if (strNE(a,b))
1554         return FALSE;
1555     if (fa == a)
1556         strcpy(tmpbuf,".");
1557     else
1558         strncpy(tmpbuf, a, fa - a);
1559     if (Stat(tmpbuf, &tmpstatbuf1) < 0)
1560         return FALSE;
1561     if (fb == b)
1562         strcpy(tmpbuf,".");
1563     else
1564         strncpy(tmpbuf, b, fb - b);
1565     if (Stat(tmpbuf, &tmpstatbuf2) < 0)
1566         return FALSE;
1567     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
1568            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
1569 }
1570 #endif /* !HAS_RENAME */
1571
1572 unsigned long
1573 scan_oct(start, len, retlen)
1574 char *start;
1575 I32 len;
1576 I32 *retlen;
1577 {
1578     register char *s = start;
1579     register unsigned long retval = 0;
1580
1581     while (len-- && *s >= '0' && *s <= '7') {
1582         retval <<= 3;
1583         retval |= *s++ - '0';
1584     }
1585     *retlen = s - start;
1586     return retval;
1587 }
1588
1589 unsigned long
1590 scan_hex(start, len, retlen)
1591 char *start;
1592 I32 len;
1593 I32 *retlen;
1594 {
1595     register char *s = start;
1596     register unsigned long retval = 0;
1597     char *tmp;
1598
1599     while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
1600         retval <<= 4;
1601         retval |= (tmp - hexdigit) & 15;
1602         s++;
1603     }
1604     *retlen = s - start;
1605     return retval;
1606 }
1607
1608 /* Amazingly enough, some systems (e.g. Dynix 3) don't have fmod.
1609    This is a slow, stupid, but working emulation.  (AD)
1610 */
1611 #ifdef USE_MY_FMOD
1612 double
1613 my_fmod(x, y)
1614 double x, y;
1615 {
1616     double i = 0.0;   /* Can't use int because it can overflow */
1617     if ((x == 0) || (y == 0))
1618        return 0;
1619     /* The sign of fmod is the same as the sign of x.  */
1620     if ( (x < 0 && y > 0) || (x > 0 && y < 0) )
1621         y = -y;
1622     if (x > 0) {
1623         while (x - i*y > y)
1624             i++;
1625     } else {
1626         while (x - i*y < y)
1627             i++;
1628     }
1629     return x - i * y;
1630 }
1631 #endif