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 = SvPV(*mark, tmplen);
 167         sv_setpvn(sv, s, tmplen);
 168         mark++;
 169     }
 170     else
 171         sv_setpv(sv,"");
 172     len = delimlen;
 173     if (len) {
 174         for (; items > 0; items--,mark++) {
 175             sv_catpvn(sv,delim,len);
 176             sv_catsv(sv,*mark);
 177         }
 178     }
 179     else {
 180         for (; items > 0; items--,mark++)
 181             sv_catsv(sv,*mark);
 182     }
 183     SvSETMAGIC(sv);
 184 }
 185
 186 void
 187 do_sprintf(sv,len,sarg)
 188 register SV *sv;
 189 register I32 len;
 190 register SV **sarg;
 191 {
 192     register char *s;
 193     register char *t;
 194     register char *f;
 195     bool dolong;
 196 #ifdef QUAD
 197     bool doquad;
 198 #endif /* QUAD */
 199     char ch;
 200     register char *send;
 201     register SV *arg;
 202     char *xs;
 203     I32 xlen;
 204     I32 pre;
 205     I32 post;
 206     double value;
 207     STRLEN arglen;
 208
 209     sv_setpv(sv,"");
 210     len--;                      /* don't count pattern string */
 211     t = s = SvPV(*sarg, arglen);
 212     send = s + arglen;
 213     sarg++;
 214     for ( ; ; len--) {
 215
 216         /*SUPPRESS 560*/
 217         if (len <= 0 || !(arg = *sarg++))
 218             arg = &sv_no;
 219
 220         /*SUPPRESS 530*/
 221         for ( ; t < send && *t != '%'; t++) ;
 222         if (t >= send)
 223             break;              /* end of run_format string, ignore extra args */
 224         f = t;
 225         *buf = '\0';
 226         xs = buf;
 227 #ifdef QUAD
 228         doquad =
 229 #endif /* QUAD */
 230         dolong = FALSE;
 231         pre = post = 0;
 232         for (t++; t < send; t++) {
 233             switch (*t) {
 234             default:
 235                 ch = *(++t);
 236                 *t = '\0';
 237                 (void)sprintf(xs,f);
 238                 len++, sarg--;
 239                 xlen = strlen(xs);
 240                 break;
 241             case '0': case '1': case '2': case '3': case '4':
 242             case '5': case '6': case '7': case '8': case '9':
 243             case '.': case '#': case '-': case '+': case ' ':
 244                 continue;
 245             case 'l':
 246 #ifdef QUAD
 247                 if (dolong) {
 248                     dolong = FALSE;
 249                     doquad = TRUE;
 250                 } else
 251 #endif
 252                 dolong = TRUE;
 253                 continue;
 254             case 'c':
 255                 ch = *(++t);
 256                 *t = '\0';
 257                 xlen = SvIV(arg);
 258                 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
 259                     *xs = xlen;
 260                     xs[1] = '\0';
 261                     xlen = 1;
 262                 }
 263                 else {
 264                     (void)sprintf(xs,f,xlen);
 265                     xlen = strlen(xs);
 266                 }
 267                 break;
 268             case 'D':
 269                 dolong = TRUE;
 270                 /* FALL THROUGH */
 271             case 'd':
 272                 ch = *(++t);
 273                 *t = '\0';
 274 #ifdef QUAD
 275                 if (doquad)
 276                     (void)sprintf(buf,s,(quad)SvNV(arg));
 277                 else
 278 #endif
 279                 if (dolong)
 280                     (void)sprintf(xs,f,(long)SvNV(arg));
 281                 else
 282                     (void)sprintf(xs,f,SvIV(arg));
 283                 xlen = strlen(xs);
 284                 break;
 285             case 'X': case 'O':
 286                 dolong = TRUE;
 287                 /* FALL THROUGH */
 288             case 'x': case 'o': case 'u':
 289                 ch = *(++t);
 290                 *t = '\0';
 291                 value = SvNV(arg);
 292 #ifdef QUAD
 293                 if (doquad)
 294                     (void)sprintf(buf,s,(unsigned quad)value);
 295                 else
 296 #endif
 297                 if (dolong)
 298                     (void)sprintf(xs,f,U_L(value));
 299                 else
 300                     (void)sprintf(xs,f,U_I(value));
 301                 xlen = strlen(xs);
 302                 break;
 303             case 'E': case 'e': case 'f': case 'G': case 'g':
 304                 ch = *(++t);
 305                 *t = '\0';
 306                 (void)sprintf(xs,f,SvNV(arg));
 307                 xlen = strlen(xs);
 308                 break;
 309             case 's':
 310                 ch = *(++t);
 311                 *t = '\0';
 312                 xs = SvPV(arg, arglen);
 313                 xlen = (I32)arglen;
 314                 if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
 315                     break;              /* so handle simple cases */
 316                 }
 317                 else if (f[1] == '-') {
 318                     char *mp = strchr(f, '.');
 319                     I32 min = atoi(f+2);
 320
 321                     if (mp) {
 322                         I32 max = atoi(mp+1);
 323
 324                         if (xlen > max)
 325                             xlen = max;
 326                     }
 327                     if (xlen < min)
 328                         post = min - xlen;
 329                     break;
 330                 }
 331                 else if (isDIGIT(f[1])) {
 332                     char *mp = strchr(f, '.');
 333                     I32 min = atoi(f+1);
 334
 335                     if (mp) {
 336                         I32 max = atoi(mp+1);
 337
 338                         if (xlen > max)
 339                             xlen = max;
 340                     }
 341                     if (xlen < min)
 342                         pre = min - xlen;
 343                     break;
 344                 }
 345                 strcpy(tokenbuf+64,f);  /* sprintf($s,...$s...) */
 346                 *t = ch;
 347                 (void)sprintf(buf,tokenbuf+64,xs);
 348                 xs = buf;
 349                 xlen = strlen(xs);
 350                 break;
 351             }
 352             /* end of switch, copy results */
 353             *t = ch;
 354             SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
 355             sv_catpvn(sv, s, f - s);
 356             if (pre) {
 357                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
 358                 SvCUR(sv) += pre;
 359             }
 360             sv_catpvn(sv, xs, xlen);
 361             if (post) {
 362                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
 363                 SvCUR(sv) += post;
 364             }
 365             s = t;
 366             break;              /* break from for loop */
 367         }
 368     }
 369     sv_catpvn(sv, s, t - s);
 370     SvSETMAGIC(sv);
 371 }
 372
 373 void
 374 do_vecset(sv)
 375 SV *sv;
 376 {
 377     SV *targ = LvTARG(sv);
 378     register I32 offset;
 379     register I32 size;
 380     register unsigned char *s = (unsigned char*)SvPVX(targ);
 381     register unsigned long lval = U_L(SvNV(sv));
 382     I32 mask;
 383
 384     offset = LvTARGOFF(sv);
 385     size = LvTARGLEN(sv);
 386     if (size < 8) {
 387         mask = (1 << size) - 1;
 388         size = offset & 7;
 389         lval &= mask;
 390         offset >>= 3;
 391         s[offset] &= ~(mask << size);
 392         s[offset] |= lval << size;
 393     }
 394     else {
 395         if (size == 8)
 396             s[offset] = lval & 255;
 397         else if (size == 16) {
 398             s[offset] = (lval >> 8) & 255;
 399             s[offset+1] = lval & 255;
 400         }
 401         else if (size == 32) {
 402             s[offset] = (lval >> 24) & 255;
 403             s[offset+1] = (lval >> 16) & 255;
 404             s[offset+2] = (lval >> 8) & 255;
 405             s[offset+3] = lval & 255;
 406         }
 407     }
 408 }
 409
 410 void
 411 do_chop(astr,sv)
 412 register SV *astr;
 413 register SV *sv;
 414 {
 415     register char *tmps;
 416     register I32 i;
 417     AV *ary;
 418     HV *hv;
 419     HE *entry;
 420     STRLEN len;
 421
 422     if (!sv)
 423         return;
 424     if (SvREADONLY(sv))
 425         croak("Can't chop readonly value");
 426     if (SvTYPE(sv) == SVt_PVAV) {
 427         I32 max;
 428         SV **array = AvARRAY(sv);
 429         max = AvFILL(sv);
 430         for (i = 0; i <= max; i++)
 431             do_chop(astr,array[i]);
 432         return;
 433     }
 434     if (SvTYPE(sv) == SVt_PVHV) {
 435         hv = (HV*)sv;
 436         (void)hv_iterinit(hv);
 437         /*SUPPRESS 560*/
 438         while (entry = hv_iternext(hv))
 439             do_chop(astr,hv_iterval(hv,entry));
 440         return;
 441     }
 442     tmps = SvPV(sv, len);
 443     if (tmps && len) {
 444         tmps += len - 1;
 445         sv_setpvn(astr,tmps,1); /* remember last char */
 446         *tmps = '\0';                           /* wipe it out */
 447         SvCUR_set(sv, tmps - SvPVX(sv));
 448         SvNOK_off(sv);
 449         SvSETMAGIC(sv);
 450     }
 451     else
 452         sv_setpvn(astr,"",0);
 453 }
 454
 455 void
 456 do_vop(optype,sv,left,right)
 457 I32 optype;
 458 SV *sv;
 459 SV *left;
 460 SV *right;
 461 {
 462 #ifdef LIBERAL
 463     register long *dl;
 464     register long *ll;
 465     register long *rl;
 466 #endif
 467     register char *dc;
 468     STRLEN leftlen;
 469     STRLEN rightlen;
 470     register char *lc = SvPV(left, leftlen);
 471     register char *rc = SvPV(right, rightlen);
 472     register I32 len;
 473
 474     if (SvREADONLY(sv))
 475         croak("Can't do %s to readonly value", op_name[optype]);
 476     len = leftlen < rightlen ? leftlen : rightlen;
 477     if (SvTYPE(sv) < SVt_PV)
 478         sv_upgrade(sv, SVt_PV);
 479     if (SvCUR(sv) > len)
 480         SvCUR_set(sv, len);
 481     else if (SvCUR(sv) < len) {
 482         SvGROW(sv,len);
 483         (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
 484         SvCUR_set(sv, len);
 485     }
 486     SvPOK_only(sv);
 487     dc = SvPVX(sv);
 488     if (!dc) {
 489         sv_setpvn(sv,"",0);
 490         dc = SvPVX(sv);
 491     }
 492 #ifdef LIBERAL
 493     if (len >= sizeof(long)*4 &&
 494         !((long)dc % sizeof(long)) &&
 495         !((long)lc % sizeof(long)) &&
 496         !((long)rc % sizeof(long)))     /* It's almost always aligned... */
 497     {
 498         I32 remainder = len % (sizeof(long)*4);
 499         len /= (sizeof(long)*4);
 500
 501         dl = (long*)dc;
 502         ll = (long*)lc;
 503         rl = (long*)rc;
 504
 505         switch (optype) {
 506         case OP_BIT_AND:
 507             while (len--) {
 508                 *dl++ = *ll++ & *rl++;
 509                 *dl++ = *ll++ & *rl++;
 510                 *dl++ = *ll++ & *rl++;
 511                 *dl++ = *ll++ & *rl++;
 512             }
 513             break;
 514         case OP_XOR:
 515             while (len--) {
 516                 *dl++ = *ll++ ^ *rl++;
 517                 *dl++ = *ll++ ^ *rl++;
 518                 *dl++ = *ll++ ^ *rl++;
 519                 *dl++ = *ll++ ^ *rl++;
 520             }
 521             break;
 522         case OP_BIT_OR:
 523             while (len--) {
 524                 *dl++ = *ll++ | *rl++;
 525                 *dl++ = *ll++ | *rl++;
 526                 *dl++ = *ll++ | *rl++;
 527                 *dl++ = *ll++ | *rl++;
 528             }
 529         }
 530
 531         dc = (char*)dl;
 532         lc = (char*)ll;
 533         rc = (char*)rl;
 534
 535         len = remainder;
 536     }
 537 #endif
 538     switch (optype) {
 539     case OP_BIT_AND:
 540         while (len--)
 541             *dc++ = *lc++ & *rc++;
 542         break;
 543     case OP_XOR:
 544         while (len--)
 545             *dc++ = *lc++ ^ *rc++;
 546         goto mop_up;
 547     case OP_BIT_OR:
 548         while (len--)
 549             *dc++ = *lc++ | *rc++;
 550       mop_up:
 551         len = SvCUR(sv);
 552         if (rightlen > len)
 553             sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
 554         else if (leftlen > len)
 555             sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
 556         break;
 557     }
 558 }
 559
 560 OP *
 561 do_kv(ARGS)
 562 dARGS
 563 {
 564     dSP;
 565     HV *hv = (HV*)POPs;
 566     register AV *ary = stack;
 567     I32 i;
 568     register HE *entry;
 569     char *tmps;
 570     SV *tmpstr;
 571     I32 dokeys =   (op->op_type == OP_KEYS   || op->op_type == OP_RV2HV);
 572     I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
 573
 574     if (!hv)
 575         RETURN;
 576     if (GIMME != G_ARRAY) {
 577         dTARGET;
 578
 579         if (!SvMAGICAL(hv) || !mg_find((SV*)hv,'P'))
 580             i = HvKEYS(hv);
 581         else {
 582             i = 0;
 583             (void)hv_iterinit(hv);
 584             /*SUPPRESS 560*/
 585             while (entry = hv_iternext(hv)) {
 586                 i++;
 587             }
 588         }
 589         PUSHi( i );
 590         RETURN;
 591     }
 592
 593     /* Guess how much room we need.  hv_max may be a few too many.  Oh well. */
 594     EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
 595
 596     (void)hv_iterinit(hv);
 597
 598     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
 599     while (entry = hv_iternext(hv)) {
 600         SPAGAIN;
 601         if (dokeys) {
 602             tmps = hv_iterkey(entry,&i);        /* won't clobber stack_sp */
 603             if (!i)
 604                 tmps = "";
 605             XPUSHs(sv_2mortal(newSVpv(tmps,i)));
 606         }
 607         if (dovalues) {
 608             tmpstr = NEWSV(45,0);
 609             PUTBACK;
 610             sv_setsv(tmpstr,hv_iterval(hv,entry));
 611             SPAGAIN;
 612             DEBUG_H( {
 613                 sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
 614                     HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
 615                 sv_setpv(tmpstr,buf);
 616             } )
 617             XPUSHs(sv_2mortal(tmpstr));
 618         }
 619         PUTBACK;
 620     }
 621     return NORMAL;
 622 }
 623