doop.c

   1 /* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $
   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.1  92/08/07  17:19:37  lwall
  10  * Stage 6 Snapshot
  11  *
  12  * Revision 4.0.1.7  92/06/11  21:07:11  lwall
  13  * patch34: join with null list attempted negative allocation
  14  * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd  "
  15  *
  16  * Revision 4.0.1.6  92/06/08  12:34:30  lwall
  17  * patch20: removed implicit int declarations on funcions
  18  * patch20: pattern modifiers i and o didn't interact right
  19  * patch20: join() now pre-extends target string to avoid excessive copying
  20  * patch20: fixed confusion between a *var's real name and its effective name
  21  * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
  22  * patch20: usersub routines didn't reclaim temp values soon enough
  23  * patch20: ($<,$>) = ... didn't work on some architectures
  24  * patch20: added Atari ST portability
  25  *
  26  * Revision 4.0.1.5  91/11/11  16:31:58  lwall
  27  * patch19: added little-endian pack/unpack options
  28  *
  29  * Revision 4.0.1.4  91/11/05  16:35:06  lwall
  30  * patch11: /$foo/o optimizer could access deallocated data
  31  * patch11: minimum match length calculation in regexp is now cumulative
  32  * patch11: added some support for 64-bit integers
  33  * patch11: prepared for ctype implementations that don't define isascii()
  34  * patch11: sprintf() now supports any length of s field
  35  * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
  36  * patch11: defined(&$foo) and undef(&$foo) didn't work
  37  *
  38  * Revision 4.0.1.3  91/06/10  01:18:41  lwall
  39  * patch10: pack(hh,1) dumped core
  40  *
  41  * Revision 4.0.1.2  91/06/07  10:42:17  lwall
  42  * patch4: new copyright notice
  43  * patch4: // wouldn't use previous pattern if it started with a null character
  44  * patch4: //o and s///o now optimize themselves fully at runtime
  45  * patch4: added global modifier for pattern matches
  46  * patch4: undef @array disabled "@array" interpolation
  47  * patch4: chop("") was returning "\0" rather than ""
  48  * patch4: vector logical operations &, | and ^ sometimes returned null string
  49  * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
  50  *
  51  * Revision 4.0.1.1  91/04/11  17:40:14  lwall
  52  * patch1: fixed undefined environ problem
  53  * patch1: fixed debugger coredump on subroutines
  54  *
  55  * Revision 4.0  91/03/20  01:06:42  lwall
  56  * 4.0 baseline.
  57  *
  58  */
  59
  60 #include "EXTERN.h"
  61 #include "perl.h"
  62
  63 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  64 #include <signal.h>
  65 #endif
  66
  67 #ifdef BUGGY_MSC
  68  #pragma function(memcmp)
  69 #endif /* BUGGY_MSC */
  70
  71 static void doencodes();
  72
  73 #ifdef BUGGY_MSC
  74  #pragma intrinsic(memcmp)
  75 #endif /* BUGGY_MSC */
  76
  77 I32
  78 do_trans(sv,arg)
  79 SV *sv;
  80 OP *arg;
  81 {
  82     register short *tbl;
  83     register char *s;
  84     register I32 matches = 0;
  85     register I32 ch;
  86     register char *send;
  87     register char *d;
  88     register I32 squash = op->op_private & OPpTRANS_SQUASH;
  89     STRLEN len;
  90
  91     tbl = (short*) cPVOP->op_pv;
  92     s = SvPV(sv, len);
  93     send = s + len;
  94     if (!tbl || !s)
  95         croak("panic: do_trans");
  96     DEBUG_t( deb("2.TBL\n"));
  97     if (!op->op_private) {
  98         while (s < send) {
  99             if ((ch = tbl[*s & 0377]) >= 0) {
 100                 matches++;
 101                 *s = ch;
 102             }
 103             s++;
 104         }
 105     }
 106     else {
 107         d = s;
 108         while (s < send) {
 109             if ((ch = tbl[*s & 0377]) >= 0) {
 110                 *d = ch;
 111                 if (matches++ && squash) {
 112                     if (d[-1] == *d)
 113                         matches--;
 114                     else
 115                         d++;
 116                 }
 117                 else
 118                     d++;
 119             }
 120             else if (ch == -1)          /* -1 is unmapped character */
 121                 *d++ = *s;              /* -2 is delete character */
 122             s++;
 123         }
 124         matches += send - d;    /* account for disappeared chars */
 125         *d = '\0';
 126         SvCUR_set(sv, d - SvPVX(sv));
 127     }
 128     SvSETMAGIC(sv);
 129     return matches;
 130 }
 131
 132 void
 133 do_join(sv,del,mark,sp)
 134 register SV *sv;
 135 SV *del;
 136 register SV **mark;
 137 register SV **sp;
 138 {
 139     SV **oldmark = mark;
 140     register I32 items = sp - mark;
 141     register STRLEN len;
 142     STRLEN delimlen;
 143     register char *delim = SvPV(del, delimlen);
 144     STRLEN tmplen;
 145
 146     mark++;
 147     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
 148     if (SvTYPE(sv) < SVt_PV)
 149         sv_upgrade(sv, SVt_PV);
 150     if (SvLEN(sv) < len + items) {      /* current length is way too short */
 151         while (items-- > 0) {
 152             if (*mark) {
 153                 SvPV(*mark, tmplen);
 154                 len += tmplen;
 155             }
 156             mark++;
 157         }
 158         SvGROW(sv, len + 1);            /* so try to pre-extend */
 159
 160         mark = oldmark;
 161         items = sp - mark;;
 162         ++mark;
 163     }
 164
 165     if (items-- > 0) {
 166         char *s;
 167
 168         if (*mark) {
 169             s = SvPV(*mark, tmplen);
 170             sv_setpvn(sv, s, tmplen);
 171         }
 172         else
 173             sv_setpv(sv, "");
 174         mark++;
 175     }
 176     else
 177         sv_setpv(sv,"");
 178     len = delimlen;
 179     if (len) {
 180         for (; items > 0; items--,mark++) {
 181             sv_catpvn(sv,delim,len);
 182             sv_catsv(sv,*mark);
 183         }
 184     }
 185     else {
 186         for (; items > 0; items--,mark++)
 187             sv_catsv(sv,*mark);
 188     }
 189     SvSETMAGIC(sv);
 190 }
 191
 192 void
 193 do_sprintf(sv,len,sarg)
 194 register SV *sv;
 195 register I32 len;
 196 register SV **sarg;
 197 {
 198     register char *s;
 199     register char *t;
 200     register char *f;
 201     bool dolong;
 202 #ifdef QUAD
 203     bool doquad;
 204 #endif /* QUAD */
 205     char ch;
 206     register char *send;
 207     register SV *arg;
 208     char *xs;
 209     I32 xlen;
 210     I32 pre;
 211     I32 post;
 212     double value;
 213     STRLEN arglen;
 214
 215     sv_setpv(sv,"");
 216     len--;                      /* don't count pattern string */
 217     t = s = SvPV(*sarg, arglen);
 218     send = s + arglen;
 219     sarg++;
 220     for ( ; ; len--) {
 221
 222         /*SUPPRESS 560*/
 223         if (len <= 0 || !(arg = *sarg++))
 224             arg = &sv_no;
 225
 226         /*SUPPRESS 530*/
 227         for ( ; t < send && *t != '%'; t++) ;
 228         if (t >= send)
 229             break;              /* end of run_format string, ignore extra args */
 230         f = t;
 231         *buf = '\0';
 232         xs = buf;
 233 #ifdef QUAD
 234         doquad =
 235 #endif /* QUAD */
 236         dolong = FALSE;
 237         pre = post = 0;
 238         for (t++; t < send; t++) {
 239             switch (*t) {
 240             default:
 241                 ch = *(++t);
 242                 *t = '\0';
 243                 (void)sprintf(xs,f);
 244                 len++, sarg--;
 245                 xlen = strlen(xs);
 246                 break;
 247             case '0': case '1': case '2': case '3': case '4':
 248             case '5': case '6': case '7': case '8': case '9':
 249             case '.': case '#': case '-': case '+': case ' ':
 250                 continue;
 251             case 'l':
 252 #ifdef QUAD
 253                 if (dolong) {
 254                     dolong = FALSE;
 255                     doquad = TRUE;
 256                 } else
 257 #endif
 258                 dolong = TRUE;
 259                 continue;
 260             case 'c':
 261                 ch = *(++t);
 262                 *t = '\0';
 263                 xlen = SvIV(arg);
 264                 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
 265                     *xs = xlen;
 266                     xs[1] = '\0';
 267                     xlen = 1;
 268                 }
 269                 else {
 270                     (void)sprintf(xs,f,xlen);
 271                     xlen = strlen(xs);
 272                 }
 273                 break;
 274             case 'D':
 275                 dolong = TRUE;
 276                 /* FALL THROUGH */
 277             case 'd':
 278                 ch = *(++t);
 279                 *t = '\0';
 280 #ifdef QUAD
 281                 if (doquad)
 282                     (void)sprintf(buf,s,(quad)SvNV(arg));
 283                 else
 284 #endif
 285                 if (dolong)
 286                     (void)sprintf(xs,f,(long)SvNV(arg));
 287                 else
 288                     (void)sprintf(xs,f,SvIV(arg));
 289                 xlen = strlen(xs);
 290                 break;
 291             case 'X': case 'O':
 292                 dolong = TRUE;
 293                 /* FALL THROUGH */
 294             case 'x': case 'o': case 'u':
 295                 ch = *(++t);
 296                 *t = '\0';
 297                 value = SvNV(arg);
 298 #ifdef QUAD
 299                 if (doquad)
 300                     (void)sprintf(buf,s,(unsigned quad)value);
 301                 else
 302 #endif
 303                 if (dolong)
 304                     (void)sprintf(xs,f,U_L(value));
 305                 else
 306                     (void)sprintf(xs,f,U_I(value));
 307                 xlen = strlen(xs);
 308                 break;
 309             case 'E': case 'e': case 'f': case 'G': case 'g':
 310                 ch = *(++t);
 311                 *t = '\0';
 312                 (void)sprintf(xs,f,SvNV(arg));
 313                 xlen = strlen(xs);
 314                 break;
 315             case 's':
 316                 ch = *(++t);
 317                 *t = '\0';
 318                 xs = SvPV(arg, arglen);
 319                 xlen = (I32)arglen;
 320                 if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
 321                     break;              /* so handle simple cases */
 322                 }
 323                 else if (f[1] == '-') {
 324                     char *mp = strchr(f, '.');
 325                     I32 min = atoi(f+2);
 326
 327                     if (mp) {
 328                         I32 max = atoi(mp+1);
 329
 330                         if (xlen > max)
 331                             xlen = max;
 332                     }
 333                     if (xlen < min)
 334                         post = min - xlen;
 335                     break;
 336                 }
 337                 else if (isDIGIT(f[1])) {
 338                     char *mp = strchr(f, '.');
 339                     I32 min = atoi(f+1);
 340
 341                     if (mp) {
 342                         I32 max = atoi(mp+1);
 343
 344                         if (xlen > max)
 345                             xlen = max;
 346                     }
 347                     if (xlen < min)
 348                         pre = min - xlen;
 349                     break;
 350                 }
 351                 strcpy(tokenbuf+64,f);  /* sprintf($s,...$s...) */
 352                 *t = ch;
 353                 (void)sprintf(buf,tokenbuf+64,xs);
 354                 xs = buf;
 355                 xlen = strlen(xs);
 356                 break;
 357             }
 358             /* end of switch, copy results */
 359             *t = ch;
 360             SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
 361             sv_catpvn(sv, s, f - s);
 362             if (pre) {
 363                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
 364                 SvCUR(sv) += pre;
 365             }
 366             sv_catpvn(sv, xs, xlen);
 367             if (post) {
 368                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
 369                 SvCUR(sv) += post;
 370             }
 371             s = t;
 372             break;              /* break from for loop */
 373         }
 374     }
 375     sv_catpvn(sv, s, t - s);
 376     SvSETMAGIC(sv);
 377 }
 378
 379 void
 380 do_vecset(sv)
 381 SV *sv;
 382 {
 383     SV *targ = LvTARG(sv);
 384     register I32 offset;
 385     register I32 size;
 386     register unsigned char *s;
 387     register unsigned long lval;
 388     I32 mask;
 389
 390     if (!targ)
 391         return;
 392     s = (unsigned char*)SvPVX(targ);
 393     lval = U_L(SvNV(sv));
 394     offset = LvTARGOFF(sv);
 395     size = LvTARGLEN(sv);
 396     if (size < 8) {
 397         mask = (1 << size) - 1;
 398         size = offset & 7;
 399         lval &= mask;
 400         offset >>= 3;
 401         s[offset] &= ~(mask << size);
 402         s[offset] |= lval << size;
 403     }
 404     else {
 405         if (size == 8)
 406             s[offset] = lval & 255;
 407         else if (size == 16) {
 408             s[offset] = (lval >> 8) & 255;
 409             s[offset+1] = lval & 255;
 410         }
 411         else if (size == 32) {
 412             s[offset] = (lval >> 24) & 255;
 413             s[offset+1] = (lval >> 16) & 255;
 414             s[offset+2] = (lval >> 8) & 255;
 415             s[offset+3] = lval & 255;
 416         }
 417     }
 418 }
 419
 420 void
 421 do_chop(astr,sv)
 422 register SV *astr;
 423 register SV *sv;
 424 {
 425     register char *tmps;
 426     register I32 i;
 427     AV *ary;
 428     HV *hv;
 429     HE *entry;
 430     STRLEN len;
 431
 432     if (!sv)
 433         return;
 434     if (SvTHINKFIRST(sv)) {
 435         if (SvREADONLY(sv))
 436             croak("Can't chop readonly value");
 437         if (SvROK(sv))
 438             sv_unref(sv);
 439     }
 440     if (SvTYPE(sv) == SVt_PVAV) {
 441         I32 max;
 442         SV **array = AvARRAY(sv);
 443         max = AvFILL(sv);
 444         for (i = 0; i <= max; i++)
 445             do_chop(astr,array[i]);
 446         return;
 447     }
 448     if (SvTYPE(sv) == SVt_PVHV) {
 449         hv = (HV*)sv;
 450         (void)hv_iterinit(hv);
 451         /*SUPPRESS 560*/
 452         while (entry = hv_iternext(hv))
 453             do_chop(astr,hv_iterval(hv,entry));
 454         return;
 455     }
 456     tmps = SvPV(sv, len);
 457     if (tmps && len) {
 458         tmps += len - 1;
 459         sv_setpvn(astr,tmps,1); /* remember last char */
 460         *tmps = '\0';                           /* wipe it out */
 461         SvCUR_set(sv, tmps - SvPVX(sv));
 462         SvNOK_off(sv);
 463         SvSETMAGIC(sv);
 464     }
 465     else
 466         sv_setpvn(astr,"",0);
 467 }
 468
 469 void
 470 do_vop(optype,sv,left,right)
 471 I32 optype;
 472 SV *sv;
 473 SV *left;
 474 SV *right;
 475 {
 476 #ifdef LIBERAL
 477     register long *dl;
 478     register long *ll;
 479     register long *rl;
 480 #endif
 481     register char *dc;
 482     STRLEN leftlen;
 483     STRLEN rightlen;
 484     register char *lc = SvPV(left, leftlen);
 485     register char *rc = SvPV(right, rightlen);
 486     register I32 len;
 487
 488     if (SvTHINKFIRST(sv)) {
 489         if (SvREADONLY(sv))
 490             croak("Can't do %s to readonly value", op_name[optype]);
 491         if (SvROK(sv))
 492             sv_unref(sv);
 493     }
 494     len = leftlen < rightlen ? leftlen : rightlen;
 495     if (SvTYPE(sv) < SVt_PV)
 496         sv_upgrade(sv, SVt_PV);
 497     if (SvCUR(sv) > len)
 498         SvCUR_set(sv, len);
 499     else if (SvCUR(sv) < len) {
 500         SvGROW(sv,len);
 501         (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
 502         SvCUR_set(sv, len);
 503     }
 504     SvPOK_only(sv);
 505     dc = SvPVX(sv);
 506     if (!dc) {
 507         sv_setpvn(sv,"",0);
 508         dc = SvPVX(sv);
 509     }
 510 #ifdef LIBERAL
 511     if (len >= sizeof(long)*4 &&
 512         !((long)dc % sizeof(long)) &&
 513         !((long)lc % sizeof(long)) &&
 514         !((long)rc % sizeof(long)))     /* It's almost always aligned... */
 515     {
 516         I32 remainder = len % (sizeof(long)*4);
 517         len /= (sizeof(long)*4);
 518
 519         dl = (long*)dc;
 520         ll = (long*)lc;
 521         rl = (long*)rc;
 522
 523         switch (optype) {
 524         case OP_BIT_AND:
 525             while (len--) {
 526                 *dl++ = *ll++ & *rl++;
 527                 *dl++ = *ll++ & *rl++;
 528                 *dl++ = *ll++ & *rl++;
 529                 *dl++ = *ll++ & *rl++;
 530             }
 531             break;
 532         case OP_XOR:
 533             while (len--) {
 534                 *dl++ = *ll++ ^ *rl++;
 535                 *dl++ = *ll++ ^ *rl++;
 536                 *dl++ = *ll++ ^ *rl++;
 537                 *dl++ = *ll++ ^ *rl++;
 538             }
 539             break;
 540         case OP_BIT_OR:
 541             while (len--) {
 542                 *dl++ = *ll++ | *rl++;
 543                 *dl++ = *ll++ | *rl++;
 544                 *dl++ = *ll++ | *rl++;
 545                 *dl++ = *ll++ | *rl++;
 546             }
 547         }
 548
 549         dc = (char*)dl;
 550         lc = (char*)ll;
 551         rc = (char*)rl;
 552
 553         len = remainder;
 554     }
 555 #endif
 556     switch (optype) {
 557     case OP_BIT_AND:
 558         while (len--)
 559             *dc++ = *lc++ & *rc++;
 560         break;
 561     case OP_XOR:
 562         while (len--)
 563             *dc++ = *lc++ ^ *rc++;
 564         goto mop_up;
 565     case OP_BIT_OR:
 566         while (len--)
 567             *dc++ = *lc++ | *rc++;
 568       mop_up:
 569         len = SvCUR(sv);
 570         if (rightlen > len)
 571             sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
 572         else if (leftlen > len)
 573             sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
 574         break;
 575     }
 576 }
 577
 578 OP *
 579 do_kv(ARGS)
 580 dARGS
 581 {
 582     dSP;
 583     HV *hv = (HV*)POPs;
 584     register AV *ary = stack;
 585     I32 i;
 586     register HE *entry;
 587     char *tmps;
 588     SV *tmpstr;
 589     I32 dokeys =   (op->op_type == OP_KEYS   || op->op_type == OP_RV2HV);
 590     I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
 591
 592     if (!hv)
 593         RETURN;
 594     if (GIMME != G_ARRAY) {
 595         dTARGET;
 596
 597         if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
 598             i = HvKEYS(hv);
 599         else {
 600             i = 0;
 601             (void)hv_iterinit(hv);
 602             /*SUPPRESS 560*/
 603             while (entry = hv_iternext(hv)) {
 604                 i++;
 605             }
 606         }
 607         PUSHi( i );
 608         RETURN;
 609     }
 610
 611     /* Guess how much room we need.  hv_max may be a few too many.  Oh well. */
 612     EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
 613
 614     (void)hv_iterinit(hv);
 615
 616     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
 617     while (entry = hv_iternext(hv)) {
 618         SPAGAIN;
 619         if (dokeys) {
 620             tmps = hv_iterkey(entry,&i);        /* won't clobber stack_sp */
 621             if (!i)
 622                 tmps = "";
 623             XPUSHs(sv_2mortal(newSVpv(tmps,i)));
 624         }
 625         if (dovalues) {
 626             tmpstr = NEWSV(45,0);
 627             PUTBACK;
 628             sv_setsv(tmpstr,hv_iterval(hv,entry));
 629             SPAGAIN;
 630             DEBUG_H( {
 631                 sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
 632                     HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
 633                 sv_setpv(tmpstr,buf);
 634             } )
 635             XPUSHs(sv_2mortal(tmpstr));
 636         }
 637         PUTBACK;
 638     }
 639     return NORMAL;
 640 }
 641