doarg.c

   1 /* $RCSfile: doarg.c,v $$Revision: 4.0.1.7 $$Date: 92/06/11 21:07:11 $
   2  *
   3  *    Copyright (c) 1991, 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  * $Log:        doarg.c,v $
   9  * Revision 4.0.1.7  92/06/11  21:07:11  lwall
  10  * patch34: join with null list attempted negative allocation
  11  * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd  "
  12  *
  13  * Revision 4.0.1.6  92/06/08  12:34:30  lwall
  14  * patch20: removed implicit int declarations on funcions
  15  * patch20: pattern modifiers i and o didn't interact right
  16  * patch20: join() now pre-extends target string to avoid excessive copying
  17  * patch20: fixed confusion between a *var's real name and its effective name
  18  * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
  19  * patch20: usersub routines didn't reclaim temp values soon enough
  20  * patch20: ($<,$>) = ... didn't work on some architectures
  21  * patch20: added Atari ST portability
  22  *
  23  * Revision 4.0.1.5  91/11/11  16:31:58  lwall
  24  * patch19: added little-endian pack/unpack options
  25  *
  26  * Revision 4.0.1.4  91/11/05  16:35:06  lwall
  27  * patch11: /$foo/o optimizer could access deallocated data
  28  * patch11: minimum match length calculation in regexp is now cumulative
  29  * patch11: added some support for 64-bit integers
  30  * patch11: prepared for ctype implementations that don't define isascii()
  31  * patch11: sprintf() now supports any length of s field
  32  * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
  33  * patch11: defined(&$foo) and undef(&$foo) didn't work
  34  *
  35  * Revision 4.0.1.3  91/06/10  01:18:41  lwall
  36  * patch10: pack(hh,1) dumped core
  37  *
  38  * Revision 4.0.1.2  91/06/07  10:42:17  lwall
  39  * patch4: new copyright notice
  40  * patch4: // wouldn't use previous pattern if it started with a null character
  41  * patch4: //o and s///o now optimize themselves fully at runtime
  42  * patch4: added global modifier for pattern matches
  43  * patch4: undef @array disabled "@array" interpolation
  44  * patch4: chop("") was returning "\0" rather than ""
  45  * patch4: vector logical operations &, | and ^ sometimes returned null string
  46  * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
  47  *
  48  * Revision 4.0.1.1  91/04/11  17:40:14  lwall
  49  * patch1: fixed undefined environ problem
  50  * patch1: fixed debugger coredump on subroutines
  51  *
  52  * Revision 4.0  91/03/20  01:06:42  lwall
  53  * 4.0 baseline.
  54  *
  55  */
  56
  57 #include "EXTERN.h"
  58 #include "perl.h"
  59
  60 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  61 #include <signal.h>
  62 #endif
  63
  64 extern unsigned char fold[];
  65
  66 #ifdef BUGGY_MSC
  67  #pragma function(memcmp)
  68 #endif /* BUGGY_MSC */
  69
  70 static void doencodes();
  71
  72 int
  73 do_subst(str,arg,sp)
  74 STR *str;
  75 ARG *arg;
  76 int sp;
  77 {
  78     register SPAT *spat;
  79     SPAT *rspat;
  80     register STR *dstr;
  81     register char *s = str_get(str);
  82     char *strend = s + str->str_cur;
  83     register char *m;
  84     char *c;
  85     register char *d;
  86     int clen;
  87     int iters = 0;
  88     int maxiters = (strend - s) + 10;
  89     register int i;
  90     bool once;
  91     char *orig;
  92     int safebase;
  93
  94     rspat = spat = arg[2].arg_ptr.arg_spat;
  95     if (!spat || !s)
  96         fatal("panic: do_subst");
  97     else if (spat->spat_runtime) {
  98         nointrp = "|)";
  99         (void)eval(spat->spat_runtime,G_SCALAR,sp);
 100         m = str_get(dstr = stack->ary_array[sp+1]);
 101         nointrp = "";
 102         if (spat->spat_regexp) {
 103             regfree(spat->spat_regexp);
 104             spat->spat_regexp = Null(REGEXP*);  /* required if regcomp pukes */
 105         }
 106         spat->spat_regexp = regcomp(m,m+dstr->str_cur,
 107             spat->spat_flags & SPAT_FOLD);
 108         if (spat->spat_flags & SPAT_KEEP) {
 109             if (!(spat->spat_flags & SPAT_FOLD))
 110                 scanconst(spat, m, dstr->str_cur);
 111             arg_free(spat->spat_runtime);       /* it won't change, so */
 112             spat->spat_runtime = Nullarg;       /* no point compiling again */
 113             hoistmust(spat);
 114             if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
 115                 curcmd->c_flags &= ~CF_OPTIMIZE;
 116                 opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
 117             }
 118         }
 119     }
 120 #ifdef DEBUGGING
 121     if (debug & 8) {
 122         deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
 123     }
 124 #endif
 125     safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) &&
 126       !sawampersand);
 127     if (!spat->spat_regexp->prelen && lastspat)
 128         spat = lastspat;
 129     orig = m = s;
 130     if (hint) {
 131         if (hint < s || hint > strend)
 132             fatal("panic: hint in do_match");
 133         s = hint;
 134         hint = Nullch;
 135         if (spat->spat_regexp->regback >= 0) {
 136             s -= spat->spat_regexp->regback;
 137             if (s < m)
 138                 s = m;
 139         }
 140         else
 141             s = m;
 142     }
 143     else if (spat->spat_short) {
 144         if (spat->spat_flags & SPAT_SCANFIRST) {
 145             if (str->str_pok & SP_STUDIED) {
 146                 if (screamfirst[spat->spat_short->str_rare] < 0)
 147                     goto nope;
 148                 else if (!(s = screaminstr(str,spat->spat_short)))
 149                     goto nope;
 150             }
 151 #ifndef lint
 152             else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend,
 153               spat->spat_short)))
 154                 goto nope;
 155 #endif
 156             if (s && spat->spat_regexp->regback >= 0) {
 157                 ++spat->spat_short->str_u.str_useful;
 158                 s -= spat->spat_regexp->regback;
 159                 if (s < m)
 160                     s = m;
 161             }
 162             else
 163                 s = m;
 164         }
 165         else if (!multiline && (*spat->spat_short->str_ptr != *s ||
 166           bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
 167             goto nope;
 168         if (--spat->spat_short->str_u.str_useful < 0) {
 169             str_free(spat->spat_short);
 170             spat->spat_short = Nullstr; /* opt is being useless */
 171         }
 172     }
 173     once = !(rspat->spat_flags & SPAT_GLOBAL);
 174     if (rspat->spat_flags & SPAT_CONST) {       /* known replacement string? */
 175         if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
 176             dstr = rspat->spat_repl[1].arg_ptr.arg_str;
 177         else {                                  /* constant over loop, anyway */
 178             (void)eval(rspat->spat_repl,G_SCALAR,sp);
 179             dstr = stack->ary_array[sp+1];
 180         }
 181         c = str_get(dstr);
 182         clen = dstr->str_cur;
 183         if (clen <= spat->spat_regexp->minlen) {
 184                                         /* can do inplace substitution */
 185             if (regexec(spat->spat_regexp, s, strend, orig, 0,
 186               str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
 187                 if (spat->spat_regexp->subbase) /* oops, no we can't */
 188                     goto long_way;
 189                 d = s;
 190                 lastspat = spat;
 191                 str->str_pok = SP_VALID;        /* disable possible screamer */
 192                 if (once) {
 193                     m = spat->spat_regexp->startp[0];
 194                     d = spat->spat_regexp->endp[0];
 195                     s = orig;
 196                     if (m - s > strend - d) {   /* faster to shorten from end */
 197                         if (clen) {
 198                             Copy(c, m, clen, char);
 199                             m += clen;
 200                         }
 201                         i = strend - d;
 202                         if (i > 0) {
 203                             Move(d, m, i, char);
 204                             m += i;
 205                         }
 206                         *m = '\0';
 207                         str->str_cur = m - s;
 208                         STABSET(str);
 209                         str_numset(arg->arg_ptr.arg_str, 1.0);
 210                         stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 211                         str->str_nok = 0;
 212                         return sp;
 213                     }
 214                     /*SUPPRESS 560*/
 215                     else if (i = m - s) {       /* faster from front */
 216                         d -= clen;
 217                         m = d;
 218                         str_chop(str,d-i);
 219                         s += i;
 220                         while (i--)
 221                             *--d = *--s;
 222                         if (clen)
 223                             Copy(c, m, clen, char);
 224                         STABSET(str);
 225                         str_numset(arg->arg_ptr.arg_str, 1.0);
 226                         stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 227                         str->str_nok = 0;
 228                         return sp;
 229                     }
 230                     else if (clen) {
 231                         d -= clen;
 232                         str_chop(str,d);
 233                         Copy(c,d,clen,char);
 234                         STABSET(str);
 235                         str_numset(arg->arg_ptr.arg_str, 1.0);
 236                         stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 237                         str->str_nok = 0;
 238                         return sp;
 239                     }
 240                     else {
 241                         str_chop(str,d);
 242                         STABSET(str);
 243                         str_numset(arg->arg_ptr.arg_str, 1.0);
 244                         stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 245                         str->str_nok = 0;
 246                         return sp;
 247                     }
 248                     /* NOTREACHED */
 249                 }
 250                 do {
 251                     if (iters++ > maxiters)
 252                         fatal("Substitution loop");
 253                     m = spat->spat_regexp->startp[0];
 254                     /*SUPPRESS 560*/
 255                     if (i = m - s) {
 256                         if (s != d)
 257                             Move(s,d,i,char);
 258                         d += i;
 259                     }
 260                     if (clen) {
 261                         Copy(c,d,clen,char);
 262                         d += clen;
 263                     }
 264                     s = spat->spat_regexp->endp[0];
 265                 } while (regexec(spat->spat_regexp, s, strend, orig, s == m,
 266                     Nullstr, TRUE));    /* (don't match same null twice) */
 267                 if (s != d) {
 268                     i = strend - s;
 269                     str->str_cur = d - str->str_ptr + i;
 270                     Move(s,d,i+1,char);         /* include the Null */
 271                 }
 272                 STABSET(str);
 273                 str_numset(arg->arg_ptr.arg_str, (double)iters);
 274                 stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 275                 str->str_nok = 0;
 276                 return sp;
 277             }
 278             str_numset(arg->arg_ptr.arg_str, 0.0);
 279             stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 280             return sp;
 281         }
 282     }
 283     else
 284         c = Nullch;
 285     if (regexec(spat->spat_regexp, s, strend, orig, 0,
 286       str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
 287     long_way:
 288         dstr = Str_new(25,str_len(str));
 289         str_nset(dstr,m,s-m);
 290         if (spat->spat_regexp->subbase)
 291             curspat = spat;
 292         lastspat = spat;
 293         do {
 294             if (iters++ > maxiters)
 295                 fatal("Substitution loop");
 296             if (spat->spat_regexp->subbase
 297               && spat->spat_regexp->subbase != orig) {
 298                 m = s;
 299                 s = orig;
 300                 orig = spat->spat_regexp->subbase;
 301                 s = orig + (m - s);
 302                 strend = s + (strend - m);
 303             }
 304             m = spat->spat_regexp->startp[0];
 305             str_ncat(dstr,s,m-s);
 306             s = spat->spat_regexp->endp[0];
 307             if (c) {
 308                 if (clen)
 309                     str_ncat(dstr,c,clen);
 310             }
 311             else {
 312                 char *mysubbase = spat->spat_regexp->subbase;
 313
 314                 spat->spat_regexp->subbase = Nullch;    /* so recursion works */
 315                 (void)eval(rspat->spat_repl,G_SCALAR,sp);
 316                 str_scat(dstr,stack->ary_array[sp+1]);
 317                 if (spat->spat_regexp->subbase)
 318                     Safefree(spat->spat_regexp->subbase);
 319                 spat->spat_regexp->subbase = mysubbase;
 320             }
 321             if (once)
 322                 break;
 323         } while (regexec(spat->spat_regexp, s, strend, orig, s == m, Nullstr,
 324             safebase));
 325         str_ncat(dstr,s,strend - s);
 326         str_replace(str,dstr);
 327         STABSET(str);
 328         str_numset(arg->arg_ptr.arg_str, (double)iters);
 329         stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 330         str->str_nok = 0;
 331         return sp;
 332     }
 333     str_numset(arg->arg_ptr.arg_str, 0.0);
 334     stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 335     return sp;
 336
 337 nope:
 338     ++spat->spat_short->str_u.str_useful;
 339     str_numset(arg->arg_ptr.arg_str, 0.0);
 340     stack->ary_array[++sp] = arg->arg_ptr.arg_str;
 341     return sp;
 342 }
 343 #ifdef BUGGY_MSC
 344  #pragma intrinsic(memcmp)
 345 #endif /* BUGGY_MSC */
 346
 347 int
 348 do_trans(str,arg)
 349 STR *str;
 350 ARG *arg;
 351 {
 352     register short *tbl;
 353     register char *s;
 354     register int matches = 0;
 355     register int ch;
 356     register char *send;
 357     register char *d;
 358     register int squash = arg[2].arg_len & 1;
 359
 360     tbl = (short*) arg[2].arg_ptr.arg_cval;
 361     s = str_get(str);
 362     send = s + str->str_cur;
 363     if (!tbl || !s)
 364         fatal("panic: do_trans");
 365 #ifdef DEBUGGING
 366     if (debug & 8) {
 367         deb("2.TBL\n");
 368     }
 369 #endif
 370     if (!arg[2].arg_len) {
 371         while (s < send) {
 372             if ((ch = tbl[*s & 0377]) >= 0) {
 373                 matches++;
 374                 *s = ch;
 375             }
 376             s++;
 377         }
 378     }
 379     else {
 380         d = s;
 381         while (s < send) {
 382             if ((ch = tbl[*s & 0377]) >= 0) {
 383                 *d = ch;
 384                 if (matches++ && squash) {
 385                     if (d[-1] == *d)
 386                         matches--;
 387                     else
 388                         d++;
 389                 }
 390                 else
 391                     d++;
 392             }
 393             else if (ch == -1)          /* -1 is unmapped character */
 394                 *d++ = *s;              /* -2 is delete character */
 395             s++;
 396         }
 397         matches += send - d;    /* account for disappeared chars */
 398         *d = '\0';
 399         str->str_cur = d - str->str_ptr;
 400     }
 401     STABSET(str);
 402     return matches;
 403 }
 404
 405 void
 406 do_join(str,arglast)
 407 register STR *str;
 408 int *arglast;
 409 {
 410     register STR **st = stack->ary_array;
 411     int sp = arglast[1];
 412     register int items = arglast[2] - sp;
 413     register char *delim = str_get(st[sp]);
 414     register STRLEN len;
 415     int delimlen = st[sp]->str_cur;
 416
 417     st += sp + 1;
 418
 419     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
 420     if (str->str_len < len + items) {   /* current length is way too short */
 421         while (items-- > 0) {
 422             if (*st)
 423                 len += (*st)->str_cur;
 424             st++;
 425         }
 426         STR_GROW(str, len + 1);         /* so try to pre-extend */
 427
 428         items = arglast[2] - sp;
 429         st -= items;
 430     }
 431
 432     if (items-- > 0)
 433         str_sset(str, *st++);
 434     else
 435         str_set(str,"");
 436     len = delimlen;
 437     if (len) {
 438         for (; items > 0; items--,st++) {
 439             str_ncat(str,delim,len);
 440             str_scat(str,*st);
 441         }
 442     }
 443     else {
 444         for (; items > 0; items--,st++)
 445             str_scat(str,*st);
 446     }
 447     STABSET(str);
 448 }
 449
 450 void
 451 do_pack(str,arglast)
 452 register STR *str;
 453 int *arglast;
 454 {
 455     register STR **st = stack->ary_array;
 456     register int sp = arglast[1];
 457     register int items;
 458     register char *pat = str_get(st[sp]);
 459     register char *patend = pat + st[sp]->str_cur;
 460     register int len;
 461     int datumtype;
 462     STR *fromstr;
 463     /*SUPPRESS 442*/
 464     static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
 465     static char *space10 = "          ";
 466
 467     /* These must not be in registers: */
 468     char achar;
 469     short ashort;
 470     int aint;
 471     unsigned int auint;
 472     long along;
 473     unsigned long aulong;
 474 #ifdef QUAD
 475     quad aquad;
 476     unsigned quad auquad;
 477 #endif
 478     char *aptr;
 479     float afloat;
 480     double adouble;
 481
 482     items = arglast[2] - sp;
 483     st += ++sp;
 484     str_nset(str,"",0);
 485     while (pat < patend) {
 486 #define NEXTFROM (items-- > 0 ? *st++ : &str_no)
 487         datumtype = *pat++;
 488         if (*pat == '*') {
 489             len = index("@Xxu",datumtype) ? 0 : items;
 490             pat++;
 491         }
 492         else if (isDIGIT(*pat)) {
 493             len = *pat++ - '0';
 494             while (isDIGIT(*pat))
 495                 len = (len * 10) + (*pat++ - '0');
 496         }
 497         else
 498             len = 1;
 499         switch(datumtype) {
 500         default:
 501             break;
 502         case '%':
 503             fatal("% may only be used in unpack");
 504         case '@':
 505             len -= str->str_cur;
 506             if (len > 0)
 507                 goto grow;
 508             len = -len;
 509             if (len > 0)
 510                 goto shrink;
 511             break;
 512         case 'X':
 513           shrink:
 514             if (str->str_cur < len)
 515                 fatal("X outside of string");
 516             str->str_cur -= len;
 517             str->str_ptr[str->str_cur] = '\0';
 518             break;
 519         case 'x':
 520           grow:
 521             while (len >= 10) {
 522                 str_ncat(str,null10,10);
 523                 len -= 10;
 524             }
 525             str_ncat(str,null10,len);
 526             break;
 527         case 'A':
 528         case 'a':
 529             fromstr = NEXTFROM;
 530             aptr = str_get(fromstr);
 531             if (pat[-1] == '*')
 532                 len = fromstr->str_cur;
 533             if (fromstr->str_cur > len)
 534                 str_ncat(str,aptr,len);
 535             else {
 536                 str_ncat(str,aptr,fromstr->str_cur);
 537                 len -= fromstr->str_cur;
 538                 if (datumtype == 'A') {
 539                     while (len >= 10) {
 540                         str_ncat(str,space10,10);
 541                         len -= 10;
 542                     }
 543                     str_ncat(str,space10,len);
 544                 }
 545                 else {
 546                     while (len >= 10) {
 547                         str_ncat(str,null10,10);
 548                         len -= 10;
 549                     }
 550                     str_ncat(str,null10,len);
 551                 }
 552             }
 553             break;
 554         case 'B':
 555         case 'b':
 556             {
 557                 char *savepat = pat;
 558                 int saveitems;
 559
 560                 fromstr = NEXTFROM;
 561                 saveitems = items;
 562                 aptr = str_get(fromstr);
 563                 if (pat[-1] == '*')
 564                     len = fromstr->str_cur;
 565                 pat = aptr;
 566                 aint = str->str_cur;
 567                 str->str_cur += (len+7)/8;
 568                 STR_GROW(str, str->str_cur + 1);
 569                 aptr = str->str_ptr + aint;
 570                 if (len > fromstr->str_cur)
 571                     len = fromstr->str_cur;
 572                 aint = len;
 573                 items = 0;
 574                 if (datumtype == 'B') {
 575                     for (len = 0; len++ < aint;) {
 576                         items |= *pat++ & 1;
 577                         if (len & 7)
 578                             items <<= 1;
 579                         else {
 580                             *aptr++ = items & 0xff;
 581                             items = 0;
 582                         }
 583                     }
 584                 }
 585                 else {
 586                     for (len = 0; len++ < aint;) {
 587                         if (*pat++ & 1)
 588                             items |= 128;
 589                         if (len & 7)
 590                             items >>= 1;
 591                         else {
 592                             *aptr++ = items & 0xff;
 593                             items = 0;
 594                         }
 595                     }
 596                 }
 597                 if (aint & 7) {
 598                     if (datumtype == 'B')
 599                         items <<= 7 - (aint & 7);
 600                     else
 601                         items >>= 7 - (aint & 7);
 602                     *aptr++ = items & 0xff;
 603                 }
 604                 pat = str->str_ptr + str->str_cur;
 605                 while (aptr <= pat)
 606                     *aptr++ = '\0';
 607
 608                 pat = savepat;
 609                 items = saveitems;
 610             }
 611             break;
 612         case 'H':
 613         case 'h':
 614             {
 615                 char *savepat = pat;
 616                 int saveitems;
 617
 618                 fromstr = NEXTFROM;
 619                 saveitems = items;
 620                 aptr = str_get(fromstr);
 621                 if (pat[-1] == '*')
 622                     len = fromstr->str_cur;
 623                 pat = aptr;
 624                 aint = str->str_cur;
 625                 str->str_cur += (len+1)/2;
 626                 STR_GROW(str, str->str_cur + 1);
 627                 aptr = str->str_ptr + aint;
 628                 if (len > fromstr->str_cur)
 629                     len = fromstr->str_cur;
 630                 aint = len;
 631                 items = 0;
 632                 if (datumtype == 'H') {
 633                     for (len = 0; len++ < aint;) {
 634                         if (isALPHA(*pat))
 635                             items |= ((*pat++ & 15) + 9) & 15;
 636                         else
 637                             items |= *pat++ & 15;
 638                         if (len & 1)
 639                             items <<= 4;
 640                         else {
 641                             *aptr++ = items & 0xff;
 642                             items = 0;
 643                         }
 644                     }
 645                 }
 646                 else {
 647                     for (len = 0; len++ < aint;) {
 648                         if (isALPHA(*pat))
 649                             items |= (((*pat++ & 15) + 9) & 15) << 4;
 650                         else
 651                             items |= (*pat++ & 15) << 4;
 652                         if (len & 1)
 653                             items >>= 4;
 654                         else {
 655                             *aptr++ = items & 0xff;
 656                             items = 0;
 657                         }
 658                     }
 659                 }
 660                 if (aint & 1)
 661                     *aptr++ = items & 0xff;
 662                 pat = str->str_ptr + str->str_cur;
 663                 while (aptr <= pat)
 664                     *aptr++ = '\0';
 665
 666                 pat = savepat;
 667                 items = saveitems;
 668             }
 669             break;
 670         case 'C':
 671         case 'c':
 672             while (len-- > 0) {
 673                 fromstr = NEXTFROM;
 674                 aint = (int)str_gnum(fromstr);
 675                 achar = aint;
 676                 str_ncat(str,&achar,sizeof(char));
 677             }
 678             break;
 679         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
 680         case 'f':
 681         case 'F':
 682             while (len-- > 0) {
 683                 fromstr = NEXTFROM;
 684                 afloat = (float)str_gnum(fromstr);
 685                 str_ncat(str, (char *)&afloat, sizeof (float));
 686             }
 687             break;
 688         case 'd':
 689         case 'D':
 690             while (len-- > 0) {
 691                 fromstr = NEXTFROM;
 692                 adouble = (double)str_gnum(fromstr);
 693                 str_ncat(str, (char *)&adouble, sizeof (double));
 694             }
 695             break;
 696         case 'n':
 697             while (len-- > 0) {
 698                 fromstr = NEXTFROM;
 699                 ashort = (short)str_gnum(fromstr);
 700 #ifdef HAS_HTONS
 701                 ashort = htons(ashort);
 702 #endif
 703                 str_ncat(str,(char*)&ashort,sizeof(short));
 704             }
 705             break;
 706         case 'v':
 707             while (len-- > 0) {
 708                 fromstr = NEXTFROM;
 709                 ashort = (short)str_gnum(fromstr);
 710 #ifdef HAS_HTOVS
 711                 ashort = htovs(ashort);
 712 #endif
 713                 str_ncat(str,(char*)&ashort,sizeof(short));
 714             }
 715             break;
 716         case 'S':
 717         case 's':
 718             while (len-- > 0) {
 719                 fromstr = NEXTFROM;
 720                 ashort = (short)str_gnum(fromstr);
 721                 str_ncat(str,(char*)&ashort,sizeof(short));
 722             }
 723             break;
 724         case 'I':
 725             while (len-- > 0) {
 726                 fromstr = NEXTFROM;
 727                 auint = U_I(str_gnum(fromstr));
 728                 str_ncat(str,(char*)&auint,sizeof(unsigned int));
 729             }
 730             break;
 731         case 'i':
 732             while (len-- > 0) {
 733                 fromstr = NEXTFROM;
 734                 aint = (int)str_gnum(fromstr);
 735                 str_ncat(str,(char*)&aint,sizeof(int));
 736             }
 737             break;
 738         case 'N':
 739             while (len-- > 0) {
 740                 fromstr = NEXTFROM;
 741                 aulong = U_L(str_gnum(fromstr));
 742 #ifdef HAS_HTONL
 743                 aulong = htonl(aulong);
 744 #endif
 745                 str_ncat(str,(char*)&aulong,sizeof(unsigned long));
 746             }
 747             break;
 748         case 'V':
 749             while (len-- > 0) {
 750                 fromstr = NEXTFROM;
 751                 aulong = U_L(str_gnum(fromstr));
 752 #ifdef HAS_HTOVL
 753                 aulong = htovl(aulong);
 754 #endif
 755                 str_ncat(str,(char*)&aulong,sizeof(unsigned long));
 756             }
 757             break;
 758         case 'L':
 759             while (len-- > 0) {
 760                 fromstr = NEXTFROM;
 761                 aulong = U_L(str_gnum(fromstr));
 762                 str_ncat(str,(char*)&aulong,sizeof(unsigned long));
 763             }
 764             break;
 765         case 'l':
 766             while (len-- > 0) {
 767                 fromstr = NEXTFROM;
 768                 along = (long)str_gnum(fromstr);
 769                 str_ncat(str,(char*)&along,sizeof(long));
 770             }
 771             break;
 772 #ifdef QUAD
 773         case 'Q':
 774             while (len-- > 0) {
 775                 fromstr = NEXTFROM;
 776                 auquad = (unsigned quad)str_gnum(fromstr);
 777                 str_ncat(str,(char*)&auquad,sizeof(unsigned quad));
 778             }
 779             break;
 780         case 'q':
 781             while (len-- > 0) {
 782                 fromstr = NEXTFROM;
 783                 aquad = (quad)str_gnum(fromstr);
 784                 str_ncat(str,(char*)&aquad,sizeof(quad));
 785             }
 786             break;
 787 #endif /* QUAD */
 788         case 'p':
 789             while (len-- > 0) {
 790                 fromstr = NEXTFROM;
 791                 aptr = str_get(fromstr);
 792                 str_ncat(str,(char*)&aptr,sizeof(char*));
 793             }
 794             break;
 795         case 'u':
 796             fromstr = NEXTFROM;
 797             aptr = str_get(fromstr);
 798             aint = fromstr->str_cur;
 799             STR_GROW(str,aint * 4 / 3);
 800             if (len <= 1)
 801                 len = 45;
 802             else
 803                 len = len / 3 * 3;
 804             while (aint > 0) {
 805                 int todo;
 806
 807                 if (aint > len)
 808                     todo = len;
 809                 else
 810                     todo = aint;
 811                 doencodes(str, aptr, todo);
 812                 aint -= todo;
 813                 aptr += todo;
 814             }
 815             break;
 816         }
 817     }
 818     STABSET(str);
 819 }
 820 #undef NEXTFROM
 821
 822 static void
 823 doencodes(str, s, len)
 824 register STR *str;
 825 register char *s;
 826 register int len;
 827 {
 828     char hunk[5];
 829
 830     *hunk = len + ' ';
 831     str_ncat(str, hunk, 1);
 832     hunk[4] = '\0';
 833     while (len > 0) {
 834         hunk[0] = ' ' + (077 & (*s >> 2));
 835         hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
 836         hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
 837         hunk[3] = ' ' + (077 & (s[2] & 077));
 838         str_ncat(str, hunk, 4);
 839         s += 3;
 840         len -= 3;
 841     }
 842     for (s = str->str_ptr; *s; s++) {
 843         if (*s == ' ')
 844             *s = '`';
 845     }
 846     str_ncat(str, "\n", 1);
 847 }
 848
 849 void
 850 do_sprintf(str,len,sarg)
 851 register STR *str;
 852 register int len;
 853 register STR **sarg;
 854 {
 855     register char *s;
 856     register char *t;
 857     register char *f;
 858     bool dolong;
 859 #ifdef QUAD
 860     bool doquad;
 861 #endif /* QUAD */
 862     char ch;
 863     static STR *sargnull = &str_no;
 864     register char *send;
 865     register STR *arg;
 866     char *xs;
 867     int xlen;
 868     int pre;
 869     int post;
 870     double value;
 871
 872     str_set(str,"");
 873     len--;                      /* don't count pattern string */
 874     t = s = str_get(*sarg);
 875     send = s + (*sarg)->str_cur;
 876     sarg++;
 877     for ( ; ; len--) {
 878
 879         /*SUPPRESS 560*/
 880         if (len <= 0 || !(arg = *sarg++))
 881             arg = sargnull;
 882
 883         /*SUPPRESS 530*/
 884         for ( ; t < send && *t != '%'; t++) ;
 885         if (t >= send)
 886             break;              /* end of format string, ignore extra args */
 887         f = t;
 888         *buf = '\0';
 889         xs = buf;
 890 #ifdef QUAD
 891         doquad =
 892 #endif /* QUAD */
 893         dolong = FALSE;
 894         pre = post = 0;
 895         for (t++; t < send; t++) {
 896             switch (*t) {
 897             default:
 898                 ch = *(++t);
 899                 *t = '\0';
 900                 (void)sprintf(xs,f);
 901                 len++, sarg--;
 902                 xlen = strlen(xs);
 903                 break;
 904             case '0': case '1': case '2': case '3': case '4':
 905             case '5': case '6': case '7': case '8': case '9':
 906             case '.': case '#': case '-': case '+': case ' ':
 907                 continue;
 908             case 'l':
 909 #ifdef QUAD
 910                 if (dolong) {
 911                     dolong = FALSE;
 912                     doquad = TRUE;
 913                 } else
 914 #endif
 915                 dolong = TRUE;
 916                 continue;
 917             case 'c':
 918                 ch = *(++t);
 919                 *t = '\0';
 920                 xlen = (int)str_gnum(arg);
 921                 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
 922                     *xs = xlen;
 923                     xs[1] = '\0';
 924                     xlen = 1;
 925                 }
 926                 else {
 927                     (void)sprintf(xs,f,xlen);
 928                     xlen = strlen(xs);
 929                 }
 930                 break;
 931             case 'D':
 932                 dolong = TRUE;
 933                 /* FALL THROUGH */
 934             case 'd':
 935                 ch = *(++t);
 936                 *t = '\0';
 937 #ifdef QUAD
 938                 if (doquad)
 939                     (void)sprintf(buf,s,(quad)str_gnum(arg));
 940                 else
 941 #endif
 942                 if (dolong)
 943                     (void)sprintf(xs,f,(long)str_gnum(arg));
 944                 else
 945                     (void)sprintf(xs,f,(int)str_gnum(arg));
 946                 xlen = strlen(xs);
 947                 break;
 948             case 'X': case 'O':
 949                 dolong = TRUE;
 950                 /* FALL THROUGH */
 951             case 'x': case 'o': case 'u':
 952                 ch = *(++t);
 953                 *t = '\0';
 954                 value = str_gnum(arg);
 955 #ifdef QUAD
 956                 if (doquad)
 957                     (void)sprintf(buf,s,(unsigned quad)value);
 958                 else
 959 #endif
 960                 if (dolong)
 961                     (void)sprintf(xs,f,U_L(value));
 962                 else
 963                     (void)sprintf(xs,f,U_I(value));
 964                 xlen = strlen(xs);
 965                 break;
 966             case 'E': case 'e': case 'f': case 'G': case 'g':
 967                 ch = *(++t);
 968                 *t = '\0';
 969                 (void)sprintf(xs,f,str_gnum(arg));
 970                 xlen = strlen(xs);
 971                 break;
 972             case 's':
 973                 ch = *(++t);
 974                 *t = '\0';
 975                 xs = str_get(arg);
 976                 xlen = arg->str_cur;
 977                 if (*xs == 'S' && xs[1] == 't' && xs[2] == 'B' && xs[3] == '\0'
 978                   && xlen == sizeof(STBP)) {
 979                     STR *tmpstr = Str_new(24,0);
 980
 981                     stab_efullname(tmpstr, ((STAB*)arg)); /* a stab value! */
 982                     sprintf(tokenbuf,"*%s",tmpstr->str_ptr);
 983                                         /* reformat to non-binary */
 984                     xs = tokenbuf;
 985                     xlen = strlen(tokenbuf);
 986                     str_free(tmpstr);
 987                 }
 988                 if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
 989                     break;              /* so handle simple cases */
 990                 }
 991                 else if (f[1] == '-') {
 992                     char *mp = index(f, '.');
 993                     int min = atoi(f+2);
 994
 995                     if (mp) {
 996                         int max = atoi(mp+1);
 997
 998                         if (xlen > max)
 999                             xlen = max;
1000                     }
1001                     if (xlen < min)
1002                         post = min - xlen;
1003                     break;
1004                 }
1005                 else if (isDIGIT(f[1])) {
1006                     char *mp = index(f, '.');
1007                     int min = atoi(f+1);
1008
1009                     if (mp) {
1010                         int max = atoi(mp+1);
1011
1012                         if (xlen > max)
1013                             xlen = max;
1014                     }
1015                     if (xlen < min)
1016                         pre = min - xlen;
1017                     break;
1018                 }
1019                 strcpy(tokenbuf+64,f);  /* sprintf($s,...$s...) */
1020                 *t = ch;
1021                 (void)sprintf(buf,tokenbuf+64,xs);
1022                 xs = buf;
1023                 xlen = strlen(xs);
1024                 break;
1025             }
1026             /* end of switch, copy results */
1027             *t = ch;
1028             STR_GROW(str, str->str_cur + (f - s) + xlen + 1 + pre + post);
1029             str_ncat(str, s, f - s);
1030             if (pre) {
1031                 repeatcpy(str->str_ptr + str->str_cur, " ", 1, pre);
1032                 str->str_cur += pre;
1033             }
1034             str_ncat(str, xs, xlen);
1035             if (post) {
1036                 repeatcpy(str->str_ptr + str->str_cur, " ", 1, post);
1037                 str->str_cur += post;
1038             }
1039             s = t;
1040             break;              /* break from for loop */
1041         }
1042     }
1043     str_ncat(str, s, t - s);
1044     STABSET(str);
1045 }
1046
1047 STR *
1048 do_push(ary,arglast)
1049 register ARRAY *ary;
1050 int *arglast;
1051 {
1052     register STR **st = stack->ary_array;
1053     register int sp = arglast[1];
1054     register int items = arglast[2] - sp;
1055     register STR *str = &str_undef;
1056
1057     for (st += ++sp; items > 0; items--,st++) {
1058         str = Str_new(26,0);
1059         if (*st)
1060             str_sset(str,*st);
1061         (void)apush(ary,str);
1062     }
1063     return str;
1064 }
1065
1066 void
1067 do_unshift(ary,arglast)
1068 register ARRAY *ary;
1069 int *arglast;
1070 {
1071     register STR **st = stack->ary_array;
1072     register int sp = arglast[1];
1073     register int items = arglast[2] - sp;
1074     register STR *str;
1075     register int i;
1076
1077     aunshift(ary,items);
1078     i = 0;
1079     for (st += ++sp; i < items; i++,st++) {
1080         str = Str_new(27,0);
1081         str_sset(str,*st);
1082         (void)astore(ary,i,str);
1083     }
1084 }
1085
1086 int
1087 do_subr(arg,gimme,arglast)
1088 register ARG *arg;
1089 int gimme;
1090 int *arglast;
1091 {
1092     register STR **st = stack->ary_array;
1093     register int sp = arglast[1];
1094     register int items = arglast[2] - sp;
1095     register SUBR *sub;
1096     SPAT * VOLATILE oldspat = curspat;
1097     STR *str;
1098     STAB *stab;
1099     int oldsave = savestack->ary_fill;
1100     int oldtmps_base = tmps_base;
1101     int hasargs = ((arg[2].arg_type & A_MASK) != A_NULL);
1102     register CSV *csv;
1103
1104     if ((arg[1].arg_type & A_MASK) == A_WORD)
1105         stab = arg[1].arg_ptr.arg_stab;
1106     else {
1107         STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
1108
1109         if (tmpstr)
1110             stab = stabent(str_get(tmpstr),TRUE);
1111         else
1112             stab = Nullstab;
1113     }
1114     if (!stab)
1115         fatal("Undefined subroutine called");
1116     if (!(sub = stab_sub(stab))) {
1117         STR *tmpstr = arg[0].arg_ptr.arg_str;
1118
1119         stab_efullname(tmpstr, stab);
1120         fatal("Undefined subroutine \"%s\" called",tmpstr->str_ptr);
1121     }
1122     if (arg->arg_type == O_DBSUBR && !sub->usersub) {
1123         str = stab_val(DBsub);
1124         saveitem(str);
1125         stab_efullname(str,stab);
1126         sub = stab_sub(DBsub);
1127         if (!sub)
1128             fatal("No DBsub routine");
1129     }
1130     str = Str_new(15, sizeof(CSV));
1131     str->str_state = SS_SCSV;
1132     (void)apush(savestack,str);
1133     csv = (CSV*)str->str_ptr;
1134     csv->sub = sub;
1135     csv->stab = stab;
1136     csv->curcsv = curcsv;
1137     csv->curcmd = curcmd;
1138     csv->depth = sub->depth;
1139     csv->wantarray = gimme;
1140     csv->hasargs = hasargs;
1141     curcsv = csv;
1142     tmps_base = tmps_max;
1143     if (sub->usersub) {
1144         csv->hasargs = 0;
1145         csv->savearray = Null(ARRAY*);;
1146         csv->argarray = Null(ARRAY*);
1147         st[sp] = arg->arg_ptr.arg_str;
1148         if (!hasargs)
1149             items = 0;
1150         sp = (*sub->usersub)(sub->userindex,sp,items);
1151     }
1152     else {
1153         if (hasargs) {
1154             csv->savearray = stab_xarray(defstab);
1155             csv->argarray = afake(defstab, items, &st[sp+1]);
1156             stab_xarray(defstab) = csv->argarray;
1157         }
1158         sub->depth++;
1159         if (sub->depth >= 2) {  /* save temporaries on recursion? */
1160             if (sub->depth == 100 && dowarn)
1161                 warn("Deep recursion on subroutine \"%s\"",stab_ename(stab));
1162             savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
1163         }
1164         sp = cmd_exec(sub->cmd,gimme, --sp);    /* so do it already */
1165     }
1166
1167     st = stack->ary_array;
1168     tmps_base = oldtmps_base;
1169     for (items = arglast[0] + 1; items <= sp; items++)
1170         st[items] = str_mortal(st[items]);
1171             /* in case restore wipes old str */
1172     restorelist(oldsave);
1173     curspat = oldspat;
1174     return sp;
1175 }
1176
1177 int
1178 do_assign(arg,gimme,arglast)
1179 register ARG *arg;
1180 int gimme;
1181 int *arglast;
1182 {
1183
1184     register STR **st = stack->ary_array;
1185     STR **firstrelem = st + arglast[1] + 1;
1186     STR **firstlelem = st + arglast[0] + 1;
1187     STR **lastrelem = st + arglast[2];
1188     STR **lastlelem = st + arglast[1];
1189     register STR **relem;
1190     register STR **lelem;
1191
1192     register STR *str;
1193     register ARRAY *ary;
1194     register int makelocal;
1195     HASH *hash;
1196     int i;
1197
1198     makelocal = (arg->arg_flags & AF_LOCAL) != 0;
1199     localizing = makelocal;
1200     delaymagic = DM_DELAY;              /* catch simultaneous items */
1201
1202     /* If there's a common identifier on both sides we have to take
1203      * special care that assigning the identifier on the left doesn't
1204      * clobber a value on the right that's used later in the list.
1205      */
1206     if (arg->arg_flags & AF_COMMON) {
1207         for (relem = firstrelem; relem <= lastrelem; relem++) {
1208             /*SUPPRESS 560*/
1209             if (str = *relem)
1210                 *relem = str_mortal(str);
1211         }
1212     }
1213     relem = firstrelem;
1214     lelem = firstlelem;
1215     ary = Null(ARRAY*);
1216     hash = Null(HASH*);
1217     while (lelem <= lastlelem) {
1218         str = *lelem++;
1219         if (str->str_state >= SS_HASH) {
1220             if (str->str_state == SS_ARY) {
1221                 if (makelocal)
1222                     ary = saveary(str->str_u.str_stab);
1223                 else {
1224                     ary = stab_array(str->str_u.str_stab);
1225                     ary->ary_fill = -1;
1226                 }
1227                 i = 0;
1228                 while (relem <= lastrelem) {    /* gobble up all the rest */
1229                     str = Str_new(28,0);
1230                     if (*relem)
1231                         str_sset(str,*relem);
1232                     *(relem++) = str;
1233                     (void)astore(ary,i++,str);
1234                 }
1235             }
1236             else if (str->str_state == SS_HASH) {
1237                 char *tmps;
1238                 STR *tmpstr;
1239                 int magic = 0;
1240                 STAB *tmpstab = str->str_u.str_stab;
1241
1242                 if (makelocal)
1243                     hash = savehash(str->str_u.str_stab);
1244                 else {
1245                     hash = stab_hash(str->str_u.str_stab);
1246                     if (tmpstab == envstab) {
1247                         magic = 'E';
1248                         environ[0] = Nullch;
1249                     }
1250                     else if (tmpstab == sigstab) {
1251                         magic = 'S';
1252 #ifndef NSIG
1253 #define NSIG 32
1254 #endif
1255                         for (i = 1; i < NSIG; i++)
1256                             signal(i, SIG_DFL); /* crunch, crunch, crunch */
1257                     }
1258 #ifdef SOME_DBM
1259                     else if (hash->tbl_dbm)
1260                         magic = 'D';
1261 #endif
1262                     hclear(hash, magic == 'D'); /* wipe any dbm file too */
1263
1264                 }
1265                 while (relem < lastrelem) {     /* gobble up all the rest */
1266                     if (*relem)
1267                         str = *(relem++);
1268                     else
1269                         str = &str_no, relem++;
1270                     tmps = str_get(str);
1271                     tmpstr = Str_new(29,0);
1272                     if (*relem)
1273                         str_sset(tmpstr,*relem);        /* value */
1274                     *(relem++) = tmpstr;
1275                     (void)hstore(hash,tmps,str->str_cur,tmpstr,0);
1276                     if (magic) {
1277                         str_magic(tmpstr, tmpstab, magic, tmps, str->str_cur);
1278                         stabset(tmpstr->str_magic, tmpstr);
1279                     }
1280                 }
1281             }
1282             else
1283                 fatal("panic: do_assign");
1284         }
1285         else {
1286             if (makelocal)
1287                 saveitem(str);
1288             if (relem <= lastrelem) {
1289                 str_sset(str, *relem);
1290                 *(relem++) = str;
1291             }
1292             else {
1293                 str_sset(str, &str_undef);
1294                 if (gimme == G_ARRAY) {
1295                     i = ++lastrelem - firstrelem;
1296                     relem++;            /* tacky, I suppose */
1297                     astore(stack,i,str);
1298                     if (st != stack->ary_array) {
1299                         st = stack->ary_array;
1300                         firstrelem = st + arglast[1] + 1;
1301                         firstlelem = st + arglast[0] + 1;
1302                         lastlelem = st + arglast[1];
1303                         lastrelem = st + i;
1304                         relem = lastrelem + 1;
1305                     }
1306                 }
1307             }
1308             STABSET(str);
1309         }
1310     }
1311     if (delaymagic & ~DM_DELAY) {
1312         if (delaymagic & DM_UID) {
1313 #ifdef HAS_SETREUID
1314             (void)setreuid(uid,euid);
1315 #else /* not HAS_SETREUID */
1316 #ifdef HAS_SETRUID
1317             if ((delaymagic & DM_UID) == DM_RUID) {
1318                 (void)setruid(uid);
1319                 delaymagic =~ DM_RUID;
1320             }
1321 #endif /* HAS_SETRUID */
1322 #ifdef HAS_SETEUID
1323             if ((delaymagic & DM_UID) == DM_EUID) {
1324                 (void)seteuid(uid);
1325                 delaymagic =~ DM_EUID;
1326             }
1327 #endif /* HAS_SETEUID */
1328             if (delaymagic & DM_UID) {
1329                 if (uid != euid)
1330                     fatal("No setreuid available");
1331                 (void)setuid(uid);
1332             }
1333 #endif /* not HAS_SETREUID */
1334             uid = (int)getuid();
1335             euid = (int)geteuid();
1336         }
1337         if (delaymagic & DM_GID) {
1338 #ifdef HAS_SETREGID
1339             (void)setregid(gid,egid);
1340 #else /* not HAS_SETREGID */
1341 #ifdef HAS_SETRGID
1342             if ((delaymagic & DM_GID) == DM_RGID) {
1343                 (void)setrgid(gid);
1344                 delaymagic =~ DM_RGID;
1345             }
1346 #endif /* HAS_SETRGID */
1347 #ifdef HAS_SETEGID
1348             if ((delaymagic & DM_GID) == DM_EGID) {
1349                 (void)setegid(gid);
1350                 delaymagic =~ DM_EGID;
1351             }
1352 #endif /* HAS_SETEGID */
1353             if (delaymagic & DM_GID) {
1354                 if (gid != egid)
1355                     fatal("No setregid available");
1356                 (void)setgid(gid);
1357             }
1358 #endif /* not HAS_SETREGID */
1359             gid = (int)getgid();
1360             egid = (int)getegid();
1361         }
1362     }
1363     delaymagic = 0;
1364     localizing = FALSE;
1365     if (gimme == G_ARRAY) {
1366         i = lastrelem - firstrelem + 1;
1367         if (ary || hash)
1368             Copy(firstrelem, firstlelem, i, STR*);
1369         return arglast[0] + i;
1370     }
1371     else {
1372         str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1]));
1373         *firstlelem = arg->arg_ptr.arg_str;
1374         return arglast[0] + 1;
1375     }
1376 }
1377
1378 int                                     /*SUPPRESS 590*/
1379 do_study(str,arg,gimme,arglast)
1380 STR *str;
1381 ARG *arg;
1382 int gimme;
1383 int *arglast;
1384 {
1385     register unsigned char *s;
1386     register int pos = str->str_cur;
1387     register int ch;
1388     register int *sfirst;
1389     register int *snext;
1390     static int maxscream = -1;
1391     static STR *lastscream = Nullstr;
1392     int retval;
1393     int retarg = arglast[0] + 1;
1394
1395 #ifndef lint
1396     s = (unsigned char*)(str_get(str));
1397 #else
1398     s = Null(unsigned char*);
1399 #endif
1400     if (lastscream)
1401         lastscream->str_pok &= ~SP_STUDIED;
1402     lastscream = str;
1403     if (pos <= 0) {
1404         retval = 0;
1405         goto ret;
1406     }
1407     if (pos > maxscream) {
1408         if (maxscream < 0) {
1409             maxscream = pos + 80;
1410             New(301,screamfirst, 256, int);
1411             New(302,screamnext, maxscream, int);
1412         }
1413         else {
1414             maxscream = pos + pos / 4;
1415             Renew(screamnext, maxscream, int);
1416         }
1417     }
1418
1419     sfirst = screamfirst;
1420     snext = screamnext;
1421
1422     if (!sfirst || !snext)
1423         fatal("do_study: out of memory");
1424
1425     for (ch = 256; ch; --ch)
1426         *sfirst++ = -1;
1427     sfirst -= 256;
1428
1429     while (--pos >= 0) {
1430         ch = s[pos];
1431         if (sfirst[ch] >= 0)
1432             snext[pos] = sfirst[ch] - pos;
1433         else
1434             snext[pos] = -pos;
1435         sfirst[ch] = pos;
1436
1437         /* If there were any case insensitive searches, we must assume they
1438          * all are.  This speeds up insensitive searches much more than
1439          * it slows down sensitive ones.
1440          */
1441         if (sawi)
1442             sfirst[fold[ch]] = pos;
1443     }
1444
1445     str->str_pok |= SP_STUDIED;
1446     retval = 1;
1447   ret:
1448     str_numset(arg->arg_ptr.arg_str,(double)retval);
1449     stack->ary_array[retarg] = arg->arg_ptr.arg_str;
1450     return retarg;
1451 }
1452
1453 int                                     /*SUPPRESS 590*/
1454 do_defined(str,arg,gimme,arglast)
1455 STR *str;
1456 register ARG *arg;
1457 int gimme;
1458 int *arglast;
1459 {
1460     register int type;
1461     register int retarg = arglast[0] + 1;
1462     int retval;
1463     ARRAY *ary;
1464     HASH *hash;
1465
1466     if ((arg[1].arg_type & A_MASK) != A_LEXPR)
1467         fatal("Illegal argument to defined()");
1468     arg = arg[1].arg_ptr.arg_arg;
1469     type = arg->arg_type;
1470
1471     if (type == O_SUBR || type == O_DBSUBR) {
1472         if ((arg[1].arg_type & A_MASK) == A_WORD)
1473             retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
1474         else {
1475             STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
1476
1477             retval = tmpstr && stab_sub(stabent(str_get(tmpstr),TRUE)) != 0;
1478         }
1479     }
1480     else if (type == O_ARRAY || type == O_LARRAY ||
1481              type == O_ASLICE || type == O_LASLICE )
1482         retval = ((ary = stab_xarray(arg[1].arg_ptr.arg_stab)) != 0
1483             && ary->ary_max >= 0 );
1484     else if (type == O_HASH || type == O_LHASH ||
1485              type == O_HSLICE || type == O_LHSLICE )
1486         retval = ((hash = stab_xhash(arg[1].arg_ptr.arg_stab)) != 0
1487             && hash->tbl_array);
1488     else
1489         retval = FALSE;
1490     str_numset(str,(double)retval);
1491     stack->ary_array[retarg] = str;
1492     return retarg;
1493 }
1494
1495 int                                             /*SUPPRESS 590*/
1496 do_undef(str,arg,gimme,arglast)
1497 STR *str;
1498 register ARG *arg;
1499 int gimme;
1500 int *arglast;
1501 {
1502     register int type;
1503     register STAB *stab;
1504     int retarg = arglast[0] + 1;
1505
1506     if ((arg[1].arg_type & A_MASK) != A_LEXPR)
1507         fatal("Illegal argument to undef()");
1508     arg = arg[1].arg_ptr.arg_arg;
1509     type = arg->arg_type;
1510
1511     if (type == O_ARRAY || type == O_LARRAY) {
1512         stab = arg[1].arg_ptr.arg_stab;
1513         afree(stab_xarray(stab));
1514         stab_xarray(stab) = anew(stab);         /* so "@array" still works */
1515     }
1516     else if (type == O_HASH || type == O_LHASH) {
1517         stab = arg[1].arg_ptr.arg_stab;
1518         if (stab == envstab)
1519             environ[0] = Nullch;
1520         else if (stab == sigstab) {
1521             int i;
1522
1523             for (i = 1; i < NSIG; i++)
1524                 signal(i, SIG_DFL);     /* munch, munch, munch */
1525         }
1526         (void)hfree(stab_xhash(stab), TRUE);
1527         stab_xhash(stab) = Null(HASH*);
1528     }
1529     else if (type == O_SUBR || type == O_DBSUBR) {
1530         stab = arg[1].arg_ptr.arg_stab;
1531         if ((arg[1].arg_type & A_MASK) != A_WORD) {
1532             STR *tmpstr = STAB_STR(arg[1].arg_ptr.arg_stab);
1533
1534             if (tmpstr)
1535                 stab = stabent(str_get(tmpstr),TRUE);
1536             else
1537                 stab = Nullstab;
1538         }
1539         if (stab && stab_sub(stab)) {
1540             cmd_free(stab_sub(stab)->cmd);
1541             stab_sub(stab)->cmd = Nullcmd;
1542             afree(stab_sub(stab)->tosave);
1543             Safefree(stab_sub(stab));
1544             stab_sub(stab) = Null(SUBR*);
1545         }
1546     }
1547     else
1548         fatal("Can't undefine that kind of object");
1549     str_numset(str,0.0);
1550     stack->ary_array[retarg] = str;
1551     return retarg;
1552 }
1553
1554 int
1555 do_vec(lvalue,astr,arglast)
1556 int lvalue;
1557 STR *astr;
1558 int *arglast;
1559 {
1560     STR **st = stack->ary_array;
1561     int sp = arglast[0];
1562     register STR *str = st[++sp];
1563     register int offset = (int)str_gnum(st[++sp]);
1564     register int size = (int)str_gnum(st[++sp]);
1565     unsigned char *s = (unsigned char*)str_get(str);
1566     unsigned long retnum;
1567     int len;
1568
1569     sp = arglast[1];
1570     offset *= size;             /* turn into bit offset */
1571     len = (offset + size + 7) / 8;
1572     if (offset < 0 || size < 1)
1573         retnum = 0;
1574     else if (!lvalue && len > str->str_cur)
1575         retnum = 0;
1576     else {
1577         if (len > str->str_cur) {
1578             STR_GROW(str,len);
1579             (void)memzero(str->str_ptr + str->str_cur, len - str->str_cur);
1580             str->str_cur = len;
1581         }
1582         s = (unsigned char*)str_get(str);
1583         if (size < 8)
1584             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1585         else {
1586             offset >>= 3;
1587             if (size == 8)
1588                 retnum = s[offset];
1589             else if (size == 16)
1590                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1591             else if (size == 32)
1592                 retnum = ((unsigned long) s[offset] << 24) +
1593                         ((unsigned long) s[offset + 1] << 16) +
1594                         (s[offset + 2] << 8) + s[offset+3];
1595         }
1596
1597         if (lvalue) {                      /* it's an lvalue! */
1598             struct lstring *lstr = (struct lstring*)astr;
1599
1600             astr->str_magic = str;
1601             st[sp]->str_rare = 'v';
1602             lstr->lstr_offset = offset;
1603             lstr->lstr_len = size;
1604         }
1605     }
1606
1607     str_numset(astr,(double)retnum);
1608     st[sp] = astr;
1609     return sp;
1610 }
1611
1612 void
1613 do_vecset(mstr,str)
1614 STR *mstr;
1615 STR *str;
1616 {
1617     struct lstring *lstr = (struct lstring*)str;
1618     register int offset;
1619     register int size;
1620     register unsigned char *s = (unsigned char*)mstr->str_ptr;
1621     register unsigned long lval = U_L(str_gnum(str));
1622     int mask;
1623
1624     mstr->str_rare = 0;
1625     str->str_magic = Nullstr;
1626     offset = lstr->lstr_offset;
1627     size = lstr->lstr_len;
1628     if (size < 8) {
1629         mask = (1 << size) - 1;
1630         size = offset & 7;
1631         lval &= mask;
1632         offset >>= 3;
1633         s[offset] &= ~(mask << size);
1634         s[offset] |= lval << size;
1635     }
1636     else {
1637         if (size == 8)
1638             s[offset] = lval & 255;
1639         else if (size == 16) {
1640             s[offset] = (lval >> 8) & 255;
1641             s[offset+1] = lval & 255;
1642         }
1643         else if (size == 32) {
1644             s[offset] = (lval >> 24) & 255;
1645             s[offset+1] = (lval >> 16) & 255;
1646             s[offset+2] = (lval >> 8) & 255;
1647             s[offset+3] = lval & 255;
1648         }
1649     }
1650 }
1651
1652 void
1653 do_chop(astr,str)
1654 register STR *astr;
1655 register STR *str;
1656 {
1657     register char *tmps;
1658     register int i;
1659     ARRAY *ary;
1660     HASH *hash;
1661     HENT *entry;
1662
1663     if (!str)
1664         return;
1665     if (str->str_state == SS_ARY) {
1666         ary = stab_array(str->str_u.str_stab);
1667         for (i = 0; i <= ary->ary_fill; i++)
1668             do_chop(astr,ary->ary_array[i]);
1669         return;
1670     }
1671     if (str->str_state == SS_HASH) {
1672         hash = stab_hash(str->str_u.str_stab);
1673         (void)hiterinit(hash);
1674         /*SUPPRESS 560*/
1675         while (entry = hiternext(hash))
1676             do_chop(astr,hiterval(hash,entry));
1677         return;
1678     }
1679     tmps = str_get(str);
1680     if (tmps && str->str_cur) {
1681         tmps += str->str_cur - 1;
1682         str_nset(astr,tmps,1);  /* remember last char */
1683         *tmps = '\0';                           /* wipe it out */
1684         str->str_cur = tmps - str->str_ptr;
1685         str->str_nok = 0;
1686         STABSET(str);
1687     }
1688     else
1689         str_nset(astr,"",0);
1690 }
1691
1692 void
1693 do_vop(optype,str,left,right)
1694 STR *str;
1695 STR *left;
1696 STR *right;
1697 {
1698     register char *s;
1699     register char *l = str_get(left);
1700     register char *r = str_get(right);
1701     register int len;
1702
1703     len = left->str_cur;
1704     if (len > right->str_cur)
1705         len = right->str_cur;
1706     if (str->str_cur > len)
1707         str->str_cur = len;
1708     else if (str->str_cur < len) {
1709         STR_GROW(str,len);
1710         (void)memzero(str->str_ptr + str->str_cur, len - str->str_cur);
1711         str->str_cur = len;
1712     }
1713     str->str_pok = 1;
1714     str->str_nok = 0;
1715     s = str->str_ptr;
1716     if (!s) {
1717         str_nset(str,"",0);
1718         s = str->str_ptr;
1719     }
1720     switch (optype) {
1721     case O_BIT_AND:
1722         while (len--)
1723             *s++ = *l++ & *r++;
1724         break;
1725     case O_XOR:
1726         while (len--)
1727             *s++ = *l++ ^ *r++;
1728         goto mop_up;
1729     case O_BIT_OR:
1730         while (len--)
1731             *s++ = *l++ | *r++;
1732       mop_up:
1733         len = str->str_cur;
1734         if (right->str_cur > len)
1735             str_ncat(str,right->str_ptr+len,right->str_cur - len);
1736         else if (left->str_cur > len)
1737             str_ncat(str,left->str_ptr+len,left->str_cur - len);
1738         break;
1739     }
1740 }
1741
1742 int
1743 do_syscall(arglast)
1744 int *arglast;
1745 {
1746     register STR **st = stack->ary_array;
1747     register int sp = arglast[1];
1748     register int items = arglast[2] - sp;
1749 #ifdef atarist
1750     unsigned long arg[14]; /* yes, we really need that many ! */
1751 #else
1752     unsigned long arg[8];
1753 #endif
1754     register int i = 0;
1755     int retval = -1;
1756
1757 #ifdef HAS_SYSCALL
1758 #ifdef TAINT
1759     for (st += ++sp; items--; st++)
1760         tainted |= (*st)->str_tainted;
1761     st = stack->ary_array;
1762     sp = arglast[1];
1763     items = arglast[2] - sp;
1764 #endif
1765 #ifdef TAINT
1766     taintproper("Insecure dependency in syscall");
1767 #endif
1768     /* This probably won't work on machines where sizeof(long) != sizeof(int)
1769      * or where sizeof(long) != sizeof(char*).  But such machines will
1770      * not likely have syscall implemented either, so who cares?
1771      */
1772     while (items--) {
1773         if (st[++sp]->str_nok || !i)
1774             arg[i++] = (unsigned long)str_gnum(st[sp]);
1775 #ifndef lint
1776         else
1777             arg[i++] = (unsigned long)st[sp]->str_ptr;
1778 #endif /* lint */
1779     }
1780     sp = arglast[1];
1781     items = arglast[2] - sp;
1782     switch (items) {
1783     case 0:
1784         fatal("Too few args to syscall");
1785     case 1:
1786         retval = syscall(arg[0]);
1787         break;
1788     case 2:
1789         retval = syscall(arg[0],arg[1]);
1790         break;
1791     case 3:
1792         retval = syscall(arg[0],arg[1],arg[2]);
1793         break;
1794     case 4:
1795         retval = syscall(arg[0],arg[1],arg[2],arg[3]);
1796         break;
1797     case 5:
1798         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4]);
1799         break;
1800     case 6:
1801         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5]);
1802         break;
1803     case 7:
1804         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6]);
1805         break;
1806     case 8:
1807         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1808           arg[7]);
1809         break;
1810 #ifdef atarist
1811     case 9:
1812         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1813           arg[7], arg[8]);
1814         break;
1815     case 10:
1816         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1817           arg[7], arg[8], arg[9]);
1818         break;
1819     case 11:
1820         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1821           arg[7], arg[8], arg[9], arg[10]);
1822         break;
1823     case 12:
1824         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1825           arg[7], arg[8], arg[9], arg[10], arg[11]);
1826         break;
1827     case 13:
1828         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1829           arg[7], arg[8], arg[9], arg[10], arg[11], arg[12]);
1830         break;
1831     case 14:
1832         retval = syscall(arg[0],arg[1],arg[2],arg[3],arg[4],arg[5],arg[6],
1833           arg[7], arg[8], arg[9], arg[10], arg[11], arg[12], arg[13]);
1834         break;
1835 #endif /* atarist */
1836     }
1837     return retval;
1838 #else
1839     fatal("syscall() unimplemented");
1840 #endif
1841 }
1842
1843