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