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