| Commit | Line | Data |
|---|
| 79072805 |
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 | |
| 90 | tbl = (short*) cPVOP->op_pv; |
| 91 | s = SvPVn(sv); |
| 93a17b20 |
92 | send = s + SvCUROK(sv); |
| 79072805 |
93 | if (!tbl || !s) |
| 94 | fatal("panic: do_trans"); |
| 95 | DEBUG_t( deb("2.TBL\n")); |
| 96 | if (!op->op_private) { |
| 97 | while (s < send) { |
| 98 | if ((ch = tbl[*s & 0377]) >= 0) { |
| 99 | matches++; |
| 100 | *s = ch; |
| 101 | } |
| 102 | s++; |
| 103 | } |
| 104 | } |
| 105 | else { |
| 106 | d = s; |
| 107 | while (s < send) { |
| 108 | if ((ch = tbl[*s & 0377]) >= 0) { |
| 109 | *d = ch; |
| 110 | if (matches++ && squash) { |
| 111 | if (d[-1] == *d) |
| 112 | matches--; |
| 113 | else |
| 114 | d++; |
| 115 | } |
| 116 | else |
| 117 | d++; |
| 118 | } |
| 119 | else if (ch == -1) /* -1 is unmapped character */ |
| 120 | *d++ = *s; /* -2 is delete character */ |
| 121 | s++; |
| 122 | } |
| 123 | matches += send - d; /* account for disappeared chars */ |
| 124 | *d = '\0'; |
| 125 | SvCUR_set(sv, d - SvPV(sv)); |
| 126 | } |
| 127 | SvSETMAGIC(sv); |
| 128 | return matches; |
| 129 | } |
| 130 | |
| 131 | void |
| 132 | do_join(sv,del,mark,sp) |
| 133 | register SV *sv; |
| 134 | SV *del; |
| 135 | register SV **mark; |
| 136 | register SV **sp; |
| 137 | { |
| 138 | SV **oldmark = mark; |
| 139 | register I32 items = sp - mark; |
| 140 | register char *delim = SvPVn(del); |
| 141 | register STRLEN len; |
| 93a17b20 |
142 | I32 delimlen = SvCUROK(del); |
| 79072805 |
143 | |
| 144 | mark++; |
| 145 | len = (items > 0 ? (delimlen * (items - 1) ) : 0); |
| 146 | if (SvTYPE(sv) < SVt_PV) |
| 147 | sv_upgrade(sv, SVt_PV); |
| 148 | if (SvLEN(sv) < len + items) { /* current length is way too short */ |
| 149 | while (items-- > 0) { |
| 150 | if (*mark) { |
| 151 | if (!SvPOK(*mark)) { |
| 152 | sv_2pv(*mark); |
| 153 | if (!SvPOK(*mark)) |
| 154 | *mark = &sv_no; |
| 155 | } |
| 156 | len += SvCUR((*mark)); |
| 157 | } |
| 158 | mark++; |
| 159 | } |
| 160 | SvGROW(sv, len + 1); /* so try to pre-extend */ |
| 161 | |
| 162 | mark = oldmark; |
| 163 | items = sp - mark;; |
| 164 | ++mark; |
| 165 | } |
| 166 | |
| 167 | if (items-- > 0) |
| 168 | sv_setsv(sv, *mark++); |
| 169 | else |
| 170 | sv_setpv(sv,""); |
| 171 | len = delimlen; |
| 172 | if (len) { |
| 173 | for (; items > 0; items--,mark++) { |
| 174 | sv_catpvn(sv,delim,len); |
| 175 | sv_catsv(sv,*mark); |
| 176 | } |
| 177 | } |
| 178 | else { |
| 179 | for (; items > 0; items--,mark++) |
| 180 | sv_catsv(sv,*mark); |
| 181 | } |
| 182 | SvSETMAGIC(sv); |
| 183 | } |
| 184 | |
| 185 | void |
| 186 | do_sprintf(sv,len,sarg) |
| 187 | register SV *sv; |
| 188 | register I32 len; |
| 189 | register SV **sarg; |
| 190 | { |
| 191 | register char *s; |
| 192 | register char *t; |
| 193 | register char *f; |
| 194 | bool dolong; |
| 195 | #ifdef QUAD |
| 196 | bool doquad; |
| 197 | #endif /* QUAD */ |
| 198 | char ch; |
| 199 | register char *send; |
| 200 | register SV *arg; |
| 201 | char *xs; |
| 202 | I32 xlen; |
| 203 | I32 pre; |
| 204 | I32 post; |
| 205 | double value; |
| 206 | |
| 207 | sv_setpv(sv,""); |
| 208 | len--; /* don't count pattern string */ |
| 209 | t = s = SvPVn(*sarg); |
| 93a17b20 |
210 | send = s + SvCUROK(*sarg); |
| 79072805 |
211 | sarg++; |
| 212 | for ( ; ; len--) { |
| 213 | |
| 214 | /*SUPPRESS 560*/ |
| 215 | if (len <= 0 || !(arg = *sarg++)) |
| 216 | arg = &sv_no; |
| 217 | |
| 218 | /*SUPPRESS 530*/ |
| 219 | for ( ; t < send && *t != '%'; t++) ; |
| 220 | if (t >= send) |
| 221 | break; /* end of run_format string, ignore extra args */ |
| 222 | f = t; |
| 223 | *buf = '\0'; |
| 224 | xs = buf; |
| 225 | #ifdef QUAD |
| 226 | doquad = |
| 227 | #endif /* QUAD */ |
| 228 | dolong = FALSE; |
| 229 | pre = post = 0; |
| 230 | for (t++; t < send; t++) { |
| 231 | switch (*t) { |
| 232 | default: |
| 233 | ch = *(++t); |
| 234 | *t = '\0'; |
| 235 | (void)sprintf(xs,f); |
| 236 | len++, sarg--; |
| 237 | xlen = strlen(xs); |
| 238 | break; |
| 239 | case '0': case '1': case '2': case '3': case '4': |
| 240 | case '5': case '6': case '7': case '8': case '9': |
| 241 | case '.': case '#': case '-': case '+': case ' ': |
| 242 | continue; |
| 243 | case 'lXXX': |
| 244 | #ifdef QUAD |
| 245 | if (dolong) { |
| 246 | dolong = FALSE; |
| 247 | doquad = TRUE; |
| 248 | } else |
| 249 | #endif |
| 250 | dolong = TRUE; |
| 251 | continue; |
| 252 | case 'c': |
| 253 | ch = *(++t); |
| 254 | *t = '\0'; |
| 255 | xlen = SvIVn(arg); |
| 256 | if (strEQ(f,"%c")) { /* some printfs fail on null chars */ |
| 257 | *xs = xlen; |
| 258 | xs[1] = '\0'; |
| 259 | xlen = 1; |
| 260 | } |
| 261 | else { |
| 262 | (void)sprintf(xs,f,xlen); |
| 263 | xlen = strlen(xs); |
| 264 | } |
| 265 | break; |
| 266 | case 'D': |
| 267 | dolong = TRUE; |
| 268 | /* FALL THROUGH */ |
| 269 | case 'd': |
| 270 | ch = *(++t); |
| 271 | *t = '\0'; |
| 272 | #ifdef QUAD |
| 273 | if (doquad) |
| 274 | (void)sprintf(buf,s,(quad)SvNVn(arg)); |
| 275 | else |
| 276 | #endif |
| 277 | if (dolong) |
| 278 | (void)sprintf(xs,f,(long)SvNVn(arg)); |
| 279 | else |
| 280 | (void)sprintf(xs,f,SvIVn(arg)); |
| 281 | xlen = strlen(xs); |
| 282 | break; |
| 283 | case 'X': case 'O': |
| 284 | dolong = TRUE; |
| 285 | /* FALL THROUGH */ |
| 286 | case 'x': case 'o': case 'u': |
| 287 | ch = *(++t); |
| 288 | *t = '\0'; |
| 289 | value = SvNVn(arg); |
| 290 | #ifdef QUAD |
| 291 | if (doquad) |
| 292 | (void)sprintf(buf,s,(unsigned quad)value); |
| 293 | else |
| 294 | #endif |
| 295 | if (dolong) |
| 296 | (void)sprintf(xs,f,U_L(value)); |
| 297 | else |
| 298 | (void)sprintf(xs,f,U_I(value)); |
| 299 | xlen = strlen(xs); |
| 300 | break; |
| 301 | case 'E': case 'e': case 'f': case 'G': case 'g': |
| 302 | ch = *(++t); |
| 303 | *t = '\0'; |
| 304 | (void)sprintf(xs,f,SvNVn(arg)); |
| 305 | xlen = strlen(xs); |
| 306 | break; |
| 307 | case 's': |
| 308 | ch = *(++t); |
| 309 | *t = '\0'; |
| 310 | xs = SvPVn(arg); |
| 311 | if (SvPOK(arg)) |
| 312 | xlen = SvCUR(arg); |
| 313 | else |
| 314 | xlen = strlen(xs); |
| 315 | if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */ |
| 316 | break; /* so handle simple cases */ |
| 317 | } |
| 318 | else if (f[1] == '-') { |
| 93a17b20 |
319 | char *mp = strchr(f, '.'); |
| 79072805 |
320 | I32 min = atoi(f+2); |
| 321 | |
| 322 | if (mp) { |
| 323 | I32 max = atoi(mp+1); |
| 324 | |
| 325 | if (xlen > max) |
| 326 | xlen = max; |
| 327 | } |
| 328 | if (xlen < min) |
| 329 | post = min - xlen; |
| 330 | break; |
| 331 | } |
| 332 | else if (isDIGIT(f[1])) { |
| 93a17b20 |
333 | char *mp = strchr(f, '.'); |
| 79072805 |
334 | I32 min = atoi(f+1); |
| 335 | |
| 336 | if (mp) { |
| 337 | I32 max = atoi(mp+1); |
| 338 | |
| 339 | if (xlen > max) |
| 340 | xlen = max; |
| 341 | } |
| 342 | if (xlen < min) |
| 343 | pre = min - xlen; |
| 344 | break; |
| 345 | } |
| 346 | strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */ |
| 347 | *t = ch; |
| 348 | (void)sprintf(buf,tokenbuf+64,xs); |
| 349 | xs = buf; |
| 350 | xlen = strlen(xs); |
| 351 | break; |
| 352 | } |
| 353 | /* end of switch, copy results */ |
| 354 | *t = ch; |
| 355 | SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post); |
| 356 | sv_catpvn(sv, s, f - s); |
| 357 | if (pre) { |
| 358 | repeatcpy(SvPV(sv) + SvCUR(sv), " ", 1, pre); |
| 359 | SvCUR(sv) += pre; |
| 360 | } |
| 361 | sv_catpvn(sv, xs, xlen); |
| 362 | if (post) { |
| 363 | repeatcpy(SvPV(sv) + SvCUR(sv), " ", 1, post); |
| 364 | SvCUR(sv) += post; |
| 365 | } |
| 366 | s = t; |
| 367 | break; /* break from for loop */ |
| 368 | } |
| 369 | } |
| 370 | sv_catpvn(sv, s, t - s); |
| 371 | SvSETMAGIC(sv); |
| 372 | } |
| 373 | |
| 374 | void |
| 375 | do_vecset(sv) |
| 376 | SV *sv; |
| 377 | { |
| 378 | SV *targ = LvTARG(sv); |
| 379 | register I32 offset; |
| 380 | register I32 size; |
| 381 | register unsigned char *s = (unsigned char*)SvPV(targ); |
| 382 | register unsigned long lval = U_L(SvNVn(sv)); |
| 383 | I32 mask; |
| 384 | |
| 385 | offset = LvTARGOFF(sv); |
| 386 | size = LvTARGLEN(sv); |
| 387 | if (size < 8) { |
| 388 | mask = (1 << size) - 1; |
| 389 | size = offset & 7; |
| 390 | lval &= mask; |
| 391 | offset >>= 3; |
| 392 | s[offset] &= ~(mask << size); |
| 393 | s[offset] |= lval << size; |
| 394 | } |
| 395 | else { |
| 396 | if (size == 8) |
| 397 | s[offset] = lval & 255; |
| 398 | else if (size == 16) { |
| 399 | s[offset] = (lval >> 8) & 255; |
| 400 | s[offset+1] = lval & 255; |
| 401 | } |
| 402 | else if (size == 32) { |
| 403 | s[offset] = (lval >> 24) & 255; |
| 404 | s[offset+1] = (lval >> 16) & 255; |
| 405 | s[offset+2] = (lval >> 8) & 255; |
| 406 | s[offset+3] = lval & 255; |
| 407 | } |
| 408 | } |
| 409 | } |
| 410 | |
| 411 | void |
| 412 | do_chop(astr,sv) |
| 413 | register SV *astr; |
| 414 | register SV *sv; |
| 415 | { |
| 416 | register char *tmps; |
| 417 | register I32 i; |
| 418 | AV *ary; |
| 419 | HV *hash; |
| 420 | HE *entry; |
| 421 | |
| 422 | if (!sv) |
| 423 | return; |
| 424 | if (SvTYPE(sv) == SVt_PVAV) { |
| 425 | I32 max; |
| 426 | SV **array = AvARRAY(sv); |
| 427 | max = AvFILL(sv); |
| 428 | for (i = 0; i <= max; i++) |
| 429 | do_chop(astr,array[i]); |
| 430 | return; |
| 431 | } |
| 432 | if (SvTYPE(sv) == SVt_PVHV) { |
| 433 | hash = (HV*)sv; |
| 434 | (void)hv_iterinit(hash); |
| 435 | /*SUPPRESS 560*/ |
| 436 | while (entry = hv_iternext(hash)) |
| 437 | do_chop(astr,hv_iterval(hash,entry)); |
| 438 | return; |
| 439 | } |
| 440 | tmps = SvPVn(sv); |
| 93a17b20 |
441 | if (tmps && SvCUROK(sv)) { |
| 79072805 |
442 | tmps += SvCUR(sv) - 1; |
| 443 | sv_setpvn(astr,tmps,1); /* remember last char */ |
| 444 | *tmps = '\0'; /* wipe it out */ |
| 445 | SvCUR_set(sv, tmps - SvPV(sv)); |
| 446 | SvNOK_off(sv); |
| 447 | SvSETMAGIC(sv); |
| 448 | } |
| 449 | else |
| 450 | sv_setpvn(astr,"",0); |
| 451 | } |
| 452 | |
| 453 | void |
| 454 | do_vop(optype,sv,left,right) |
| 455 | I32 optype; |
| 456 | SV *sv; |
| 457 | SV *left; |
| 458 | SV *right; |
| 459 | { |
| 460 | #ifdef LIBERAL |
| 461 | register long *dl; |
| 462 | register long *ll; |
| 463 | register long *rl; |
| 464 | #endif |
| 465 | register char *dc; |
| 466 | register char *lc = SvPVn(left); |
| 467 | register char *rc = SvPVn(right); |
| 468 | register I32 len; |
| 93a17b20 |
469 | I32 leftlen = SvCUROK(left); |
| 470 | I32 rightlen = SvCUROK(right); |
| 79072805 |
471 | |
| 93a17b20 |
472 | len = leftlen < rightlen ? leftlen : rightlen; |
| 79072805 |
473 | if (SvTYPE(sv) < SVt_PV) |
| 474 | sv_upgrade(sv, SVt_PV); |
| 475 | if (SvCUR(sv) > len) |
| 476 | SvCUR_set(sv, len); |
| 477 | else if (SvCUR(sv) < len) { |
| 478 | SvGROW(sv,len); |
| 479 | (void)memzero(SvPV(sv) + SvCUR(sv), len - SvCUR(sv)); |
| 480 | SvCUR_set(sv, len); |
| 481 | } |
| 482 | SvPOK_only(sv); |
| 483 | dc = SvPV(sv); |
| 484 | if (!dc) { |
| 485 | sv_setpvn(sv,"",0); |
| 486 | dc = SvPV(sv); |
| 487 | } |
| 488 | #ifdef LIBERAL |
| 489 | if (len >= sizeof(long)*4 && |
| 490 | !((long)dc % sizeof(long)) && |
| 491 | !((long)lc % sizeof(long)) && |
| 492 | !((long)rc % sizeof(long))) /* It's almost always aligned... */ |
| 493 | { |
| 494 | I32 remainder = len % (sizeof(long)*4); |
| 495 | len /= (sizeof(long)*4); |
| 496 | |
| 497 | dl = (long*)dc; |
| 498 | ll = (long*)lc; |
| 499 | rl = (long*)rc; |
| 500 | |
| 501 | switch (optype) { |
| 502 | case OP_BIT_AND: |
| 503 | while (len--) { |
| 504 | *dl++ = *ll++ & *rl++; |
| 505 | *dl++ = *ll++ & *rl++; |
| 506 | *dl++ = *ll++ & *rl++; |
| 507 | *dl++ = *ll++ & *rl++; |
| 508 | } |
| 509 | break; |
| 510 | case OP_XOR: |
| 511 | while (len--) { |
| 512 | *dl++ = *ll++ ^ *rl++; |
| 513 | *dl++ = *ll++ ^ *rl++; |
| 514 | *dl++ = *ll++ ^ *rl++; |
| 515 | *dl++ = *ll++ ^ *rl++; |
| 516 | } |
| 517 | break; |
| 518 | case OP_BIT_OR: |
| 519 | while (len--) { |
| 520 | *dl++ = *ll++ | *rl++; |
| 521 | *dl++ = *ll++ | *rl++; |
| 522 | *dl++ = *ll++ | *rl++; |
| 523 | *dl++ = *ll++ | *rl++; |
| 524 | } |
| 525 | } |
| 526 | |
| 527 | dc = (char*)dl; |
| 528 | lc = (char*)ll; |
| 529 | rc = (char*)rl; |
| 530 | |
| 531 | len = remainder; |
| 532 | } |
| 533 | #endif |
| 534 | switch (optype) { |
| 535 | case OP_BIT_AND: |
| 536 | while (len--) |
| 537 | *dc++ = *lc++ & *rc++; |
| 538 | break; |
| 539 | case OP_XOR: |
| 540 | while (len--) |
| 541 | *dc++ = *lc++ ^ *rc++; |
| 542 | goto mop_up; |
| 543 | case OP_BIT_OR: |
| 544 | while (len--) |
| 545 | *dc++ = *lc++ | *rc++; |
| 546 | mop_up: |
| 547 | len = SvCUR(sv); |
| 93a17b20 |
548 | if (rightlen > len) |
| 549 | sv_catpvn(sv, SvPV(right) + len, rightlen - len); |
| 550 | else if (leftlen > len) |
| 551 | sv_catpvn(sv, SvPV(left) + len, leftlen - len); |
| 79072805 |
552 | break; |
| 553 | } |
| 554 | } |
projects / p5sagit/p5-mst-13.2.git / blame