1 /* pp.c 2 * 3 * Copyright (c) 1991-2001, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "It's a big house this, and very peculiar. Always a bit more to discover, 12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise 13 */ 14 15 #include "EXTERN.h" 16 #define PERL_IN_PP_C 17 #include "perl.h" 18 19 /* 20 * The compiler on Concurrent CX/UX systems has a subtle bug which only 21 * seems to show up when compiling pp.c - it generates the wrong double 22 * precision constant value for (double)UV_MAX when used inline in the body 23 * of the code below, so this makes a static variable up front (which the 24 * compiler seems to get correct) and uses it in place of UV_MAX below. 25 */ 26 #ifdef CXUX_BROKEN_CONSTANT_CONVERT 27 static double UV_MAX_cxux = ((double)UV_MAX); 28 #endif 29 30 /* 31 * Offset for integer pack/unpack. 32 * 33 * On architectures where I16 and I32 aren't really 16 and 32 bits, 34 * which for now are all Crays, pack and unpack have to play games. 35 */ 36 37 /* 38 * These values are required for portability of pack() output. 39 * If they're not right on your machine, then pack() and unpack() 40 * wouldn't work right anyway; you'll need to apply the Cray hack. 41 * (I'd like to check them with #if, but you can't use sizeof() in 42 * the preprocessor.) --??? 43 */ 44 /* 45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE 46 defines are now in config.h. --Andy Dougherty April 1998 47 */ 48 #define SIZE16 2 49 #define SIZE32 4 50 51 /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). 52 --jhi Feb 1999 */ 53 54 #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 55 # define PERL_NATINT_PACK 56 #endif 57 58 #if LONGSIZE > 4 && defined(_CRAY) 59 # if BYTEORDER == 0x12345678 60 # define OFF16(p) (char*)(p) 61 # define OFF32(p) (char*)(p) 62 # else 63 # if BYTEORDER == 0x87654321 64 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) 65 # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) 66 # else 67 }}}} bad cray byte order 68 # endif 69 # endif 70 # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) 71 # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) 72 # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char)) 73 # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) 74 # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) 75 #else 76 # define COPY16(s,p) Copy(s, p, SIZE16, char) 77 # define COPY32(s,p) Copy(s, p, SIZE32, char) 78 # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char) 79 # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) 80 # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) 81 #endif 82 83 /* variations on pp_null */ 84 85 /* XXX I can't imagine anyone who doesn't have this actually _needs_ 86 it, since pid_t is an integral type. 87 --AD 2/20/1998 88 */ 89 #ifdef NEED_GETPID_PROTO 90 extern Pid_t getpid (void); 91 #endif 92 93 PP(pp_stub) 94 { 95 dSP; 96 if (GIMME_V == G_SCALAR) 97 XPUSHs(&PL_sv_undef); 98 RETURN; 99 } 100 101 PP(pp_scalar) 102 { 103 return NORMAL; 104 } 105 106 /* Pushy stuff. */ 107 108 PP(pp_padav) 109 { 110 dSP; dTARGET; 111 if (PL_op->op_private & OPpLVAL_INTRO) 112 SAVECLEARSV(PL_curpad[PL_op->op_targ]); 113 EXTEND(SP, 1); 114 if (PL_op->op_flags & OPf_REF) { 115 PUSHs(TARG); 116 RETURN; 117 } else if (LVRET) { 118 if (GIMME == G_SCALAR) 119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); 120 PUSHs(TARG); 121 RETURN; 122 } 123 if (GIMME == G_ARRAY) { 124 I32 maxarg = AvFILL((AV*)TARG) + 1; 125 EXTEND(SP, maxarg); 126 if (SvMAGICAL(TARG)) { 127 U32 i; 128 for (i=0; i < maxarg; i++) { 129 SV **svp = av_fetch((AV*)TARG, i, FALSE); 130 SP[i+1] = (svp) ? *svp : &PL_sv_undef; 131 } 132 } 133 else { 134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); 135 } 136 SP += maxarg; 137 } 138 else { 139 SV* sv = sv_newmortal(); 140 I32 maxarg = AvFILL((AV*)TARG) + 1; 141 sv_setiv(sv, maxarg); 142 PUSHs(sv); 143 } 144 RETURN; 145 } 146 147 PP(pp_padhv) 148 { 149 dSP; dTARGET; 150 I32 gimme; 151 152 XPUSHs(TARG); 153 if (PL_op->op_private & OPpLVAL_INTRO) 154 SAVECLEARSV(PL_curpad[PL_op->op_targ]); 155 if (PL_op->op_flags & OPf_REF) 156 RETURN; 157 else if (LVRET) { 158 if (GIMME == G_SCALAR) 159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 160 RETURN; 161 } 162 gimme = GIMME_V; 163 if (gimme == G_ARRAY) { 164 RETURNOP(do_kv()); 165 } 166 else if (gimme == G_SCALAR) { 167 SV* sv = sv_newmortal(); 168 if (HvFILL((HV*)TARG)) 169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", 170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); 171 else 172 sv_setiv(sv, 0); 173 SETs(sv); 174 } 175 RETURN; 176 } 177 178 PP(pp_padany) 179 { 180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); 181 } 182 183 /* Translations. */ 184 185 PP(pp_rv2gv) 186 { 187 dSP; dTOPss; 188 189 if (SvROK(sv)) { 190 wasref: 191 tryAMAGICunDEREF(to_gv); 192 193 sv = SvRV(sv); 194 if (SvTYPE(sv) == SVt_PVIO) { 195 GV *gv = (GV*) sv_newmortal(); 196 gv_init(gv, 0, "", 0, 0); 197 GvIOp(gv) = (IO *)sv; 198 (void)SvREFCNT_inc(sv); 199 sv = (SV*) gv; 200 } 201 else if (SvTYPE(sv) != SVt_PVGV) 202 DIE(aTHX_ "Not a GLOB reference"); 203 } 204 else { 205 if (SvTYPE(sv) != SVt_PVGV) { 206 char *sym; 207 STRLEN len; 208 209 if (SvGMAGICAL(sv)) { 210 mg_get(sv); 211 if (SvROK(sv)) 212 goto wasref; 213 } 214 if (!SvOK(sv) && sv != &PL_sv_undef) { 215 /* If this is a 'my' scalar and flag is set then vivify 216 * NI-S 1999/05/07 217 */ 218 if (PL_op->op_private & OPpDEREF) { 219 char *name; 220 GV *gv; 221 if (cUNOP->op_targ) { 222 STRLEN len; 223 SV *namesv = PL_curpad[cUNOP->op_targ]; 224 name = SvPV(namesv, len); 225 gv = (GV*)NEWSV(0,0); 226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0); 227 } 228 else { 229 name = CopSTASHPV(PL_curcop); 230 gv = newGVgen(name); 231 } 232 sv_upgrade(sv, SVt_RV); 233 SvRV(sv) = (SV*)gv; 234 SvROK_on(sv); 235 SvSETMAGIC(sv); 236 goto wasref; 237 } 238 if (PL_op->op_flags & OPf_REF || 239 PL_op->op_private & HINT_STRICT_REFS) 240 DIE(aTHX_ PL_no_usym, "a symbol"); 241 if (ckWARN(WARN_UNINITIALIZED)) 242 report_uninit(); 243 RETSETUNDEF; 244 } 245 sym = SvPV(sv,len); 246 if ((PL_op->op_flags & OPf_SPECIAL) && 247 !(PL_op->op_flags & OPf_MOD)) 248 { 249 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV); 250 if (!sv 251 && (!is_gv_magical(sym,len,0) 252 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV)))) 253 { 254 RETSETUNDEF; 255 } 256 } 257 else { 258 if (PL_op->op_private & HINT_STRICT_REFS) 259 DIE(aTHX_ PL_no_symref, sym, "a symbol"); 260 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV); 261 } 262 } 263 } 264 if (PL_op->op_private & OPpLVAL_INTRO) 265 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); 266 SETs(sv); 267 RETURN; 268 } 269 270 PP(pp_rv2sv) 271 { 272 dSP; dTOPss; 273 274 if (SvROK(sv)) { 275 wasref: 276 tryAMAGICunDEREF(to_sv); 277 278 sv = SvRV(sv); 279 switch (SvTYPE(sv)) { 280 case SVt_PVAV: 281 case SVt_PVHV: 282 case SVt_PVCV: 283 DIE(aTHX_ "Not a SCALAR reference"); 284 } 285 } 286 else { 287 GV *gv = (GV*)sv; 288 char *sym; 289 STRLEN len; 290 291 if (SvTYPE(gv) != SVt_PVGV) { 292 if (SvGMAGICAL(sv)) { 293 mg_get(sv); 294 if (SvROK(sv)) 295 goto wasref; 296 } 297 if (!SvOK(sv)) { 298 if (PL_op->op_flags & OPf_REF || 299 PL_op->op_private & HINT_STRICT_REFS) 300 DIE(aTHX_ PL_no_usym, "a SCALAR"); 301 if (ckWARN(WARN_UNINITIALIZED)) 302 report_uninit(); 303 RETSETUNDEF; 304 } 305 sym = SvPV(sv, len); 306 if ((PL_op->op_flags & OPf_SPECIAL) && 307 !(PL_op->op_flags & OPf_MOD)) 308 { 309 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV); 310 if (!gv 311 && (!is_gv_magical(sym,len,0) 312 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV)))) 313 { 314 RETSETUNDEF; 315 } 316 } 317 else { 318 if (PL_op->op_private & HINT_STRICT_REFS) 319 DIE(aTHX_ PL_no_symref, sym, "a SCALAR"); 320 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); 321 } 322 } 323 sv = GvSV(gv); 324 } 325 if (PL_op->op_flags & OPf_MOD) { 326 if (PL_op->op_private & OPpLVAL_INTRO) 327 sv = save_scalar((GV*)TOPs); 328 else if (PL_op->op_private & OPpDEREF) 329 vivify_ref(sv, PL_op->op_private & OPpDEREF); 330 } 331 SETs(sv); 332 RETURN; 333 } 334 335 PP(pp_av2arylen) 336 { 337 dSP; 338 AV *av = (AV*)TOPs; 339 SV *sv = AvARYLEN(av); 340 if (!sv) { 341 AvARYLEN(av) = sv = NEWSV(0,0); 342 sv_upgrade(sv, SVt_IV); 343 sv_magic(sv, (SV*)av, '#', Nullch, 0); 344 } 345 SETs(sv); 346 RETURN; 347 } 348 349 PP(pp_pos) 350 { 351 dSP; dTARGET; dPOPss; 352 353 if (PL_op->op_flags & OPf_MOD || LVRET) { 354 if (SvTYPE(TARG) < SVt_PVLV) { 355 sv_upgrade(TARG, SVt_PVLV); 356 sv_magic(TARG, Nullsv, '.', Nullch, 0); 357 } 358 359 LvTYPE(TARG) = '.'; 360 if (LvTARG(TARG) != sv) { 361 if (LvTARG(TARG)) 362 SvREFCNT_dec(LvTARG(TARG)); 363 LvTARG(TARG) = SvREFCNT_inc(sv); 364 } 365 PUSHs(TARG); /* no SvSETMAGIC */ 366 RETURN; 367 } 368 else { 369 MAGIC* mg; 370 371 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 372 mg = mg_find(sv, 'g'); 373 if (mg && mg->mg_len >= 0) { 374 I32 i = mg->mg_len; 375 if (DO_UTF8(sv)) 376 sv_pos_b2u(sv, &i); 377 PUSHi(i + PL_curcop->cop_arybase); 378 RETURN; 379 } 380 } 381 RETPUSHUNDEF; 382 } 383 } 384 385 PP(pp_rv2cv) 386 { 387 dSP; 388 GV *gv; 389 HV *stash; 390 391 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ 392 /* (But not in defined().) */ 393 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); 394 if (cv) { 395 if (CvCLONE(cv)) 396 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 397 if ((PL_op->op_private & OPpLVAL_INTRO)) { 398 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) 399 cv = GvCV(gv); 400 if (!CvLVALUE(cv)) 401 DIE(aTHX_ "Can't modify non-lvalue subroutine call"); 402 } 403 } 404 else 405 cv = (CV*)&PL_sv_undef; 406 SETs((SV*)cv); 407 RETURN; 408 } 409 410 PP(pp_prototype) 411 { 412 dSP; 413 CV *cv; 414 HV *stash; 415 GV *gv; 416 SV *ret; 417 418 ret = &PL_sv_undef; 419 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { 420 char *s = SvPVX(TOPs); 421 if (strnEQ(s, "CORE::", 6)) { 422 int code; 423 424 code = keyword(s + 6, SvCUR(TOPs) - 6); 425 if (code < 0) { /* Overridable. */ 426 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) 427 int i = 0, n = 0, seen_question = 0; 428 I32 oa; 429 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ 430 431 while (i < MAXO) { /* The slow way. */ 432 if (strEQ(s + 6, PL_op_name[i]) 433 || strEQ(s + 6, PL_op_desc[i])) 434 { 435 goto found; 436 } 437 i++; 438 } 439 goto nonesuch; /* Should not happen... */ 440 found: 441 oa = PL_opargs[i] >> OASHIFT; 442 while (oa) { 443 if (oa & OA_OPTIONAL) { 444 seen_question = 1; 445 str[n++] = ';'; 446 } 447 else if (n && str[0] == ';' && seen_question) 448 goto set; /* XXXX system, exec */ 449 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 450 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { 451 str[n++] = '\\'; 452 } 453 /* What to do with R ((un)tie, tied, (sys)read, recv)? */ 454 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; 455 oa = oa >> 4; 456 } 457 str[n++] = '\0'; 458 ret = sv_2mortal(newSVpvn(str, n - 1)); 459 } 460 else if (code) /* Non-Overridable */ 461 goto set; 462 else { /* None such */ 463 nonesuch: 464 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); 465 } 466 } 467 } 468 cv = sv_2cv(TOPs, &stash, &gv, FALSE); 469 if (cv && SvPOK(cv)) 470 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv))); 471 set: 472 SETs(ret); 473 RETURN; 474 } 475 476 PP(pp_anoncode) 477 { 478 dSP; 479 CV* cv = (CV*)PL_curpad[PL_op->op_targ]; 480 if (CvCLONE(cv)) 481 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 482 EXTEND(SP,1); 483 PUSHs((SV*)cv); 484 RETURN; 485 } 486 487 PP(pp_srefgen) 488 { 489 dSP; 490 *SP = refto(*SP); 491 RETURN; 492 } 493 494 PP(pp_refgen) 495 { 496 dSP; dMARK; 497 if (GIMME != G_ARRAY) { 498 if (++MARK <= SP) 499 *MARK = *SP; 500 else 501 *MARK = &PL_sv_undef; 502 *MARK = refto(*MARK); 503 SP = MARK; 504 RETURN; 505 } 506 EXTEND_MORTAL(SP - MARK); 507 while (++MARK <= SP) 508 *MARK = refto(*MARK); 509 RETURN; 510 } 511 512 STATIC SV* 513 S_refto(pTHX_ SV *sv) 514 { 515 SV* rv; 516 517 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 518 if (LvTARGLEN(sv)) 519 vivify_defelem(sv); 520 if (!(sv = LvTARG(sv))) 521 sv = &PL_sv_undef; 522 else 523 (void)SvREFCNT_inc(sv); 524 } 525 else if (SvTYPE(sv) == SVt_PVAV) { 526 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) 527 av_reify((AV*)sv); 528 SvTEMP_off(sv); 529 (void)SvREFCNT_inc(sv); 530 } 531 else if (SvPADTMP(sv)) 532 sv = newSVsv(sv); 533 else { 534 SvTEMP_off(sv); 535 (void)SvREFCNT_inc(sv); 536 } 537 rv = sv_newmortal(); 538 sv_upgrade(rv, SVt_RV); 539 SvRV(rv) = sv; 540 SvROK_on(rv); 541 return rv; 542 } 543 544 PP(pp_ref) 545 { 546 dSP; dTARGET; 547 SV *sv; 548 char *pv; 549 550 sv = POPs; 551 552 if (sv && SvGMAGICAL(sv)) 553 mg_get(sv); 554 555 if (!sv || !SvROK(sv)) 556 RETPUSHNO; 557 558 sv = SvRV(sv); 559 pv = sv_reftype(sv,TRUE); 560 PUSHp(pv, strlen(pv)); 561 RETURN; 562 } 563 564 PP(pp_bless) 565 { 566 dSP; 567 HV *stash; 568 569 if (MAXARG == 1) 570 stash = CopSTASH(PL_curcop); 571 else { 572 SV *ssv = POPs; 573 STRLEN len; 574 char *ptr = SvPV(ssv,len); 575 if (ckWARN(WARN_MISC) && len == 0) 576 Perl_warner(aTHX_ WARN_MISC, 577 "Explicit blessing to '' (assuming package main)"); 578 stash = gv_stashpvn(ptr, len, TRUE); 579 } 580 581 (void)sv_bless(TOPs, stash); 582 RETURN; 583 } 584 585 PP(pp_gelem) 586 { 587 GV *gv; 588 SV *sv; 589 SV *tmpRef; 590 char *elem; 591 dSP; 592 STRLEN n_a; 593 594 sv = POPs; 595 elem = SvPV(sv, n_a); 596 gv = (GV*)POPs; 597 tmpRef = Nullsv; 598 sv = Nullsv; 599 switch (elem ? *elem : '\0') 600 { 601 case 'A': 602 if (strEQ(elem, "ARRAY")) 603 tmpRef = (SV*)GvAV(gv); 604 break; 605 case 'C': 606 if (strEQ(elem, "CODE")) 607 tmpRef = (SV*)GvCVu(gv); 608 break; 609 case 'F': 610 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ 611 tmpRef = (SV*)GvIOp(gv); 612 break; 613 case 'G': 614 if (strEQ(elem, "GLOB")) 615 tmpRef = (SV*)gv; 616 break; 617 case 'H': 618 if (strEQ(elem, "HASH")) 619 tmpRef = (SV*)GvHV(gv); 620 break; 621 case 'I': 622 if (strEQ(elem, "IO")) 623 tmpRef = (SV*)GvIOp(gv); 624 break; 625 case 'N': 626 if (strEQ(elem, "NAME")) 627 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); 628 break; 629 case 'P': 630 if (strEQ(elem, "PACKAGE")) 631 sv = newSVpv(HvNAME(GvSTASH(gv)), 0); 632 break; 633 case 'S': 634 if (strEQ(elem, "SCALAR")) 635 tmpRef = GvSV(gv); 636 break; 637 } 638 if (tmpRef) 639 sv = newRV(tmpRef); 640 if (sv) 641 sv_2mortal(sv); 642 else 643 sv = &PL_sv_undef; 644 XPUSHs(sv); 645 RETURN; 646 } 647 648 /* Pattern matching */ 649 650 PP(pp_study) 651 { 652 dSP; dPOPss; 653 register unsigned char *s; 654 register I32 pos; 655 register I32 ch; 656 register I32 *sfirst; 657 register I32 *snext; 658 STRLEN len; 659 660 if (sv == PL_lastscream) { 661 if (SvSCREAM(sv)) 662 RETPUSHYES; 663 } 664 else { 665 if (PL_lastscream) { 666 SvSCREAM_off(PL_lastscream); 667 SvREFCNT_dec(PL_lastscream); 668 } 669 PL_lastscream = SvREFCNT_inc(sv); 670 } 671 672 s = (unsigned char*)(SvPV(sv, len)); 673 pos = len; 674 if (pos <= 0) 675 RETPUSHNO; 676 if (pos > PL_maxscream) { 677 if (PL_maxscream < 0) { 678 PL_maxscream = pos + 80; 679 New(301, PL_screamfirst, 256, I32); 680 New(302, PL_screamnext, PL_maxscream, I32); 681 } 682 else { 683 PL_maxscream = pos + pos / 4; 684 Renew(PL_screamnext, PL_maxscream, I32); 685 } 686 } 687 688 sfirst = PL_screamfirst; 689 snext = PL_screamnext; 690 691 if (!sfirst || !snext) 692 DIE(aTHX_ "do_study: out of memory"); 693 694 for (ch = 256; ch; --ch) 695 *sfirst++ = -1; 696 sfirst -= 256; 697 698 while (--pos >= 0) { 699 ch = s[pos]; 700 if (sfirst[ch] >= 0) 701 snext[pos] = sfirst[ch] - pos; 702 else 703 snext[pos] = -pos; 704 sfirst[ch] = pos; 705 } 706 707 SvSCREAM_on(sv); 708 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */ 709 RETPUSHYES; 710 } 711 712 PP(pp_trans) 713 { 714 dSP; dTARG; 715 SV *sv; 716 717 if (PL_op->op_flags & OPf_STACKED) 718 sv = POPs; 719 else { 720 sv = DEFSV; 721 EXTEND(SP,1); 722 } 723 TARG = sv_newmortal(); 724 PUSHi(do_trans(sv)); 725 RETURN; 726 } 727 728 /* Lvalue operators. */ 729 730 PP(pp_schop) 731 { 732 dSP; dTARGET; 733 do_chop(TARG, TOPs); 734 SETTARG; 735 RETURN; 736 } 737 738 PP(pp_chop) 739 { 740 dSP; dMARK; dTARGET; dORIGMARK; 741 while (MARK < SP) 742 do_chop(TARG, *++MARK); 743 SP = ORIGMARK; 744 PUSHTARG; 745 RETURN; 746 } 747 748 PP(pp_schomp) 749 { 750 dSP; dTARGET; 751 SETi(do_chomp(TOPs)); 752 RETURN; 753 } 754 755 PP(pp_chomp) 756 { 757 dSP; dMARK; dTARGET; 758 register I32 count = 0; 759 760 while (SP > MARK) 761 count += do_chomp(POPs); 762 PUSHi(count); 763 RETURN; 764 } 765 766 PP(pp_defined) 767 { 768 dSP; 769 register SV* sv; 770 771 sv = POPs; 772 if (!sv || !SvANY(sv)) 773 RETPUSHNO; 774 switch (SvTYPE(sv)) { 775 case SVt_PVAV: 776 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) 777 RETPUSHYES; 778 break; 779 case SVt_PVHV: 780 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) 781 RETPUSHYES; 782 break; 783 case SVt_PVCV: 784 if (CvROOT(sv) || CvXSUB(sv)) 785 RETPUSHYES; 786 break; 787 default: 788 if (SvGMAGICAL(sv)) 789 mg_get(sv); 790 if (SvOK(sv)) 791 RETPUSHYES; 792 } 793 RETPUSHNO; 794 } 795 796 PP(pp_undef) 797 { 798 dSP; 799 SV *sv; 800 801 if (!PL_op->op_private) { 802 EXTEND(SP, 1); 803 RETPUSHUNDEF; 804 } 805 806 sv = POPs; 807 if (!sv) 808 RETPUSHUNDEF; 809 810 if (SvTHINKFIRST(sv)) 811 sv_force_normal(sv); 812 813 switch (SvTYPE(sv)) { 814 case SVt_NULL: 815 break; 816 case SVt_PVAV: 817 av_undef((AV*)sv); 818 break; 819 case SVt_PVHV: 820 hv_undef((HV*)sv); 821 break; 822 case SVt_PVCV: 823 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) 824 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined", 825 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); 826 /* FALL THROUGH */ 827 case SVt_PVFM: 828 { 829 /* let user-undef'd sub keep its identity */ 830 GV* gv = CvGV((CV*)sv); 831 cv_undef((CV*)sv); 832 CvGV((CV*)sv) = gv; 833 } 834 break; 835 case SVt_PVGV: 836 if (SvFAKE(sv)) 837 SvSetMagicSV(sv, &PL_sv_undef); 838 else { 839 GP *gp; 840 gp_free((GV*)sv); 841 Newz(602, gp, 1, GP); 842 GvGP(sv) = gp_ref(gp); 843 GvSV(sv) = NEWSV(72,0); 844 GvLINE(sv) = CopLINE(PL_curcop); 845 GvEGV(sv) = (GV*)sv; 846 GvMULTI_on(sv); 847 } 848 break; 849 default: 850 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { 851 (void)SvOOK_off(sv); 852 Safefree(SvPVX(sv)); 853 SvPV_set(sv, Nullch); 854 SvLEN_set(sv, 0); 855 } 856 (void)SvOK_off(sv); 857 SvSETMAGIC(sv); 858 } 859 860 RETPUSHUNDEF; 861 } 862 863 PP(pp_predec) 864 { 865 dSP; 866 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) 867 DIE(aTHX_ PL_no_modify); 868 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && 869 SvIVX(TOPs) != IV_MIN) 870 { 871 --SvIVX(TOPs); 872 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 873 } 874 else 875 sv_dec(TOPs); 876 SvSETMAGIC(TOPs); 877 return NORMAL; 878 } 879 880 PP(pp_postinc) 881 { 882 dSP; dTARGET; 883 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) 884 DIE(aTHX_ PL_no_modify); 885 sv_setsv(TARG, TOPs); 886 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && 887 SvIVX(TOPs) != IV_MAX) 888 { 889 ++SvIVX(TOPs); 890 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 891 } 892 else 893 sv_inc(TOPs); 894 SvSETMAGIC(TOPs); 895 if (!SvOK(TARG)) 896 sv_setiv(TARG, 0); 897 SETs(TARG); 898 return NORMAL; 899 } 900 901 PP(pp_postdec) 902 { 903 dSP; dTARGET; 904 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) 905 DIE(aTHX_ PL_no_modify); 906 sv_setsv(TARG, TOPs); 907 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && 908 SvIVX(TOPs) != IV_MIN) 909 { 910 --SvIVX(TOPs); 911 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); 912 } 913 else 914 sv_dec(TOPs); 915 SvSETMAGIC(TOPs); 916 SETs(TARG); 917 return NORMAL; 918 } 919 920 /* Ordinary operators. */ 921 922 PP(pp_pow) 923 { 924 dSP; dATARGET; tryAMAGICbin(pow,opASSIGN); 925 { 926 dPOPTOPnnrl; 927 SETn( Perl_pow( left, right) ); 928 RETURN; 929 } 930 } 931 932 PP(pp_multiply) 933 { 934 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 935 { 936 dPOPTOPnnrl; 937 SETn( left * right ); 938 RETURN; 939 } 940 } 941 942 PP(pp_divide) 943 { 944 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 945 { 946 dPOPPOPnnrl; 947 NV value; 948 if (right == 0.0) 949 DIE(aTHX_ "Illegal division by zero"); 950 #ifdef SLOPPYDIVIDE 951 /* insure that 20./5. == 4. */ 952 { 953 IV k; 954 if ((NV)I_V(left) == left && 955 (NV)I_V(right) == right && 956 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { 957 value = k; 958 } 959 else { 960 value = left / right; 961 } 962 } 963 #else 964 value = left / right; 965 #endif 966 PUSHn( value ); 967 RETURN; 968 } 969 } 970 971 PP(pp_modulo) 972 { 973 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 974 { 975 UV left; 976 UV right; 977 bool left_neg; 978 bool right_neg; 979 bool use_double = 0; 980 NV dright; 981 NV dleft; 982 983 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { 984 IV i = SvIVX(POPs); 985 right = (right_neg = (i < 0)) ? -i : i; 986 } 987 else { 988 dright = POPn; 989 use_double = 1; 990 right_neg = dright < 0; 991 if (right_neg) 992 dright = -dright; 993 } 994 995 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) { 996 IV i = SvIVX(POPs); 997 left = (left_neg = (i < 0)) ? -i : i; 998 } 999 else { 1000 dleft = POPn; 1001 if (!use_double) { 1002 use_double = 1; 1003 dright = right; 1004 } 1005 left_neg = dleft < 0; 1006 if (left_neg) 1007 dleft = -dleft; 1008 } 1009 1010 if (use_double) { 1011 NV dans; 1012 1013 #if 1 1014 /* Somehow U_V is pessimized even if CASTFLAGS is 0 */ 1015 # if CASTFLAGS & 2 1016 # define CAST_D2UV(d) U_V(d) 1017 # else 1018 # define CAST_D2UV(d) ((UV)(d)) 1019 # endif 1020 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE, 1021 * or, in other words, precision of UV more than of NV. 1022 * But in fact the approach below turned out to be an 1023 * optimization - floor() may be slow */ 1024 if (dright <= UV_MAX && dleft <= UV_MAX) { 1025 right = CAST_D2UV(dright); 1026 left = CAST_D2UV(dleft); 1027 goto do_uv; 1028 } 1029 #endif 1030 1031 /* Backward-compatibility clause: */ 1032 dright = Perl_floor(dright + 0.5); 1033 dleft = Perl_floor(dleft + 0.5); 1034 1035 if (!dright) 1036 DIE(aTHX_ "Illegal modulus zero"); 1037 1038 dans = Perl_fmod(dleft, dright); 1039 if ((left_neg != right_neg) && dans) 1040 dans = dright - dans; 1041 if (right_neg) 1042 dans = -dans; 1043 sv_setnv(TARG, dans); 1044 } 1045 else { 1046 UV ans; 1047 1048 do_uv: 1049 if (!right) 1050 DIE(aTHX_ "Illegal modulus zero"); 1051 1052 ans = left % right; 1053 if ((left_neg != right_neg) && ans) 1054 ans = right - ans; 1055 if (right_neg) { 1056 /* XXX may warn: unary minus operator applied to unsigned type */ 1057 /* could change -foo to be (~foo)+1 instead */ 1058 if (ans <= ~((UV)IV_MAX)+1) 1059 sv_setiv(TARG, ~ans+1); 1060 else 1061 sv_setnv(TARG, -(NV)ans); 1062 } 1063 else 1064 sv_setuv(TARG, ans); 1065 } 1066 PUSHTARG; 1067 RETURN; 1068 } 1069 } 1070 1071 PP(pp_repeat) 1072 { 1073 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); 1074 { 1075 register IV count = POPi; 1076 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 1077 dMARK; 1078 I32 items = SP - MARK; 1079 I32 max; 1080 1081 max = items * count; 1082 MEXTEND(MARK, max); 1083 if (count > 1) { 1084 while (SP > MARK) { 1085 if (*SP) 1086 SvTEMP_off((*SP)); 1087 SP--; 1088 } 1089 MARK++; 1090 repeatcpy((char*)(MARK + items), (char*)MARK, 1091 items * sizeof(SV*), count - 1); 1092 SP += max; 1093 } 1094 else if (count <= 0) 1095 SP -= items; 1096 } 1097 else { /* Note: mark already snarfed by pp_list */ 1098 SV *tmpstr = POPs; 1099 STRLEN len; 1100 bool isutf; 1101 1102 SvSetSV(TARG, tmpstr); 1103 SvPV_force(TARG, len); 1104 isutf = DO_UTF8(TARG); 1105 if (count != 1) { 1106 if (count < 1) 1107 SvCUR_set(TARG, 0); 1108 else { 1109 SvGROW(TARG, (count * len) + 1); 1110 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); 1111 SvCUR(TARG) *= count; 1112 } 1113 *SvEND(TARG) = '\0'; 1114 } 1115 if (isutf) 1116 (void)SvPOK_only_UTF8(TARG); 1117 else 1118 (void)SvPOK_only(TARG); 1119 PUSHTARG; 1120 } 1121 RETURN; 1122 } 1123 } 1124 1125 PP(pp_subtract) 1126 { 1127 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 1128 { 1129 dPOPTOPnnrl_ul; 1130 SETn( left - right ); 1131 RETURN; 1132 } 1133 } 1134 1135 PP(pp_left_shift) 1136 { 1137 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); 1138 { 1139 IV shift = POPi; 1140 if (PL_op->op_private & HINT_INTEGER) { 1141 IV i = TOPi; 1142 SETi(i << shift); 1143 } 1144 else { 1145 UV u = TOPu; 1146 SETu(u << shift); 1147 } 1148 RETURN; 1149 } 1150 } 1151 1152 PP(pp_right_shift) 1153 { 1154 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); 1155 { 1156 IV shift = POPi; 1157 if (PL_op->op_private & HINT_INTEGER) { 1158 IV i = TOPi; 1159 SETi(i >> shift); 1160 } 1161 else { 1162 UV u = TOPu; 1163 SETu(u >> shift); 1164 } 1165 RETURN; 1166 } 1167 } 1168 1169 PP(pp_lt) 1170 { 1171 dSP; tryAMAGICbinSET(lt,0); 1172 { 1173 dPOPnv; 1174 SETs(boolSV(TOPn < value)); 1175 RETURN; 1176 } 1177 } 1178 1179 PP(pp_gt) 1180 { 1181 dSP; tryAMAGICbinSET(gt,0); 1182 { 1183 dPOPnv; 1184 SETs(boolSV(TOPn > value)); 1185 RETURN; 1186 } 1187 } 1188 1189 PP(pp_le) 1190 { 1191 dSP; tryAMAGICbinSET(le,0); 1192 { 1193 dPOPnv; 1194 SETs(boolSV(TOPn <= value)); 1195 RETURN; 1196 } 1197 } 1198 1199 PP(pp_ge) 1200 { 1201 dSP; tryAMAGICbinSET(ge,0); 1202 { 1203 dPOPnv; 1204 SETs(boolSV(TOPn >= value)); 1205 RETURN; 1206 } 1207 } 1208 1209 PP(pp_ne) 1210 { 1211 dSP; tryAMAGICbinSET(ne,0); 1212 { 1213 dPOPnv; 1214 SETs(boolSV(TOPn != value)); 1215 RETURN; 1216 } 1217 } 1218 1219 PP(pp_ncmp) 1220 { 1221 dSP; dTARGET; tryAMAGICbin(ncmp,0); 1222 { 1223 dPOPTOPnnrl; 1224 I32 value; 1225 1226 #ifdef Perl_isnan 1227 if (Perl_isnan(left) || Perl_isnan(right)) { 1228 SETs(&PL_sv_undef); 1229 RETURN; 1230 } 1231 value = (left > right) - (left < right); 1232 #else 1233 if (left == right) 1234 value = 0; 1235 else if (left < right) 1236 value = -1; 1237 else if (left > right) 1238 value = 1; 1239 else { 1240 SETs(&PL_sv_undef); 1241 RETURN; 1242 } 1243 #endif 1244 SETi(value); 1245 RETURN; 1246 } 1247 } 1248 1249 PP(pp_slt) 1250 { 1251 dSP; tryAMAGICbinSET(slt,0); 1252 { 1253 dPOPTOPssrl; 1254 int cmp = ((PL_op->op_private & OPpLOCALE) 1255 ? sv_cmp_locale(left, right) 1256 : sv_cmp(left, right)); 1257 SETs(boolSV(cmp < 0)); 1258 RETURN; 1259 } 1260 } 1261 1262 PP(pp_sgt) 1263 { 1264 dSP; tryAMAGICbinSET(sgt,0); 1265 { 1266 dPOPTOPssrl; 1267 int cmp = ((PL_op->op_private & OPpLOCALE) 1268 ? sv_cmp_locale(left, right) 1269 : sv_cmp(left, right)); 1270 SETs(boolSV(cmp > 0)); 1271 RETURN; 1272 } 1273 } 1274 1275 PP(pp_sle) 1276 { 1277 dSP; tryAMAGICbinSET(sle,0); 1278 { 1279 dPOPTOPssrl; 1280 int cmp = ((PL_op->op_private & OPpLOCALE) 1281 ? sv_cmp_locale(left, right) 1282 : sv_cmp(left, right)); 1283 SETs(boolSV(cmp <= 0)); 1284 RETURN; 1285 } 1286 } 1287 1288 PP(pp_sge) 1289 { 1290 dSP; tryAMAGICbinSET(sge,0); 1291 { 1292 dPOPTOPssrl; 1293 int cmp = ((PL_op->op_private & OPpLOCALE) 1294 ? sv_cmp_locale(left, right) 1295 : sv_cmp(left, right)); 1296 SETs(boolSV(cmp >= 0)); 1297 RETURN; 1298 } 1299 } 1300 1301 PP(pp_seq) 1302 { 1303 dSP; tryAMAGICbinSET(seq,0); 1304 { 1305 dPOPTOPssrl; 1306 SETs(boolSV(sv_eq(left, right))); 1307 RETURN; 1308 } 1309 } 1310 1311 PP(pp_sne) 1312 { 1313 dSP; tryAMAGICbinSET(sne,0); 1314 { 1315 dPOPTOPssrl; 1316 SETs(boolSV(!sv_eq(left, right))); 1317 RETURN; 1318 } 1319 } 1320 1321 PP(pp_scmp) 1322 { 1323 dSP; dTARGET; tryAMAGICbin(scmp,0); 1324 { 1325 dPOPTOPssrl; 1326 int cmp = ((PL_op->op_private & OPpLOCALE) 1327 ? sv_cmp_locale(left, right) 1328 : sv_cmp(left, right)); 1329 SETi( cmp ); 1330 RETURN; 1331 } 1332 } 1333 1334 PP(pp_bit_and) 1335 { 1336 dSP; dATARGET; tryAMAGICbin(band,opASSIGN); 1337 { 1338 dPOPTOPssrl; 1339 if (SvNIOKp(left) || SvNIOKp(right)) { 1340 if (PL_op->op_private & HINT_INTEGER) { 1341 IV i = SvIV(left) & SvIV(right); 1342 SETi(i); 1343 } 1344 else { 1345 UV u = SvUV(left) & SvUV(right); 1346 SETu(u); 1347 } 1348 } 1349 else { 1350 do_vop(PL_op->op_type, TARG, left, right); 1351 SETTARG; 1352 } 1353 RETURN; 1354 } 1355 } 1356 1357 PP(pp_bit_xor) 1358 { 1359 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); 1360 { 1361 dPOPTOPssrl; 1362 if (SvNIOKp(left) || SvNIOKp(right)) { 1363 if (PL_op->op_private & HINT_INTEGER) { 1364 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); 1365 SETi(i); 1366 } 1367 else { 1368 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); 1369 SETu(u); 1370 } 1371 } 1372 else { 1373 do_vop(PL_op->op_type, TARG, left, right); 1374 SETTARG; 1375 } 1376 RETURN; 1377 } 1378 } 1379 1380 PP(pp_bit_or) 1381 { 1382 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); 1383 { 1384 dPOPTOPssrl; 1385 if (SvNIOKp(left) || SvNIOKp(right)) { 1386 if (PL_op->op_private & HINT_INTEGER) { 1387 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); 1388 SETi(i); 1389 } 1390 else { 1391 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); 1392 SETu(u); 1393 } 1394 } 1395 else { 1396 do_vop(PL_op->op_type, TARG, left, right); 1397 SETTARG; 1398 } 1399 RETURN; 1400 } 1401 } 1402 1403 PP(pp_negate) 1404 { 1405 dSP; dTARGET; tryAMAGICun(neg); 1406 { 1407 dTOPss; 1408 if (SvGMAGICAL(sv)) 1409 mg_get(sv); 1410 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) { 1411 if (SvIsUV(sv)) { 1412 if (SvIVX(sv) == IV_MIN) { 1413 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ 1414 RETURN; 1415 } 1416 else if (SvUVX(sv) <= IV_MAX) { 1417 SETi(-SvIVX(sv)); 1418 RETURN; 1419 } 1420 } 1421 else if (SvIVX(sv) != IV_MIN) { 1422 SETi(-SvIVX(sv)); 1423 RETURN; 1424 } 1425 } 1426 if (SvNIOKp(sv)) 1427 SETn(-SvNV(sv)); 1428 else if (SvPOKp(sv)) { 1429 STRLEN len; 1430 char *s = SvPV(sv, len); 1431 if (isIDFIRST(*s)) { 1432 sv_setpvn(TARG, "-", 1); 1433 sv_catsv(TARG, sv); 1434 } 1435 else if (*s == '+' || *s == '-') { 1436 sv_setsv(TARG, sv); 1437 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; 1438 } 1439 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) { 1440 sv_setpvn(TARG, "-", 1); 1441 sv_catsv(TARG, sv); 1442 } 1443 else 1444 sv_setnv(TARG, -SvNV(sv)); 1445 SETTARG; 1446 } 1447 else 1448 SETn(-SvNV(sv)); 1449 } 1450 RETURN; 1451 } 1452 1453 PP(pp_not) 1454 { 1455 dSP; tryAMAGICunSET(not); 1456 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); 1457 return NORMAL; 1458 } 1459 1460 PP(pp_complement) 1461 { 1462 dSP; dTARGET; tryAMAGICun(compl); 1463 { 1464 dTOPss; 1465 if (SvNIOKp(sv)) { 1466 if (PL_op->op_private & HINT_INTEGER) { 1467 IV i = ~SvIV(sv); 1468 SETi(i); 1469 } 1470 else { 1471 UV u = ~SvUV(sv); 1472 SETu(u); 1473 } 1474 } 1475 else { 1476 register U8 *tmps; 1477 register I32 anum; 1478 STRLEN len; 1479 1480 SvSetSV(TARG, sv); 1481 tmps = (U8*)SvPV_force(TARG, len); 1482 anum = len; 1483 if (SvUTF8(TARG)) { 1484 /* Calculate exact length, let's not estimate. */ 1485 STRLEN targlen = 0; 1486 U8 *result; 1487 U8 *send; 1488 STRLEN l; 1489 UV nchar = 0; 1490 UV nwide = 0; 1491 1492 send = tmps + len; 1493 while (tmps < send) { 1494 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 1495 tmps += UTF8SKIP(tmps); 1496 targlen += UNISKIP(~c); 1497 nchar++; 1498 if (c > 0xff) 1499 nwide++; 1500 } 1501 1502 /* Now rewind strings and write them. */ 1503 tmps -= len; 1504 1505 if (nwide) { 1506 Newz(0, result, targlen + 1, U8); 1507 while (tmps < send) { 1508 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 1509 tmps += UTF8SKIP(tmps); 1510 result = uv_to_utf8(result, ~c); 1511 } 1512 *result = '\0'; 1513 result -= targlen; 1514 sv_setpvn(TARG, (char*)result, targlen); 1515 SvUTF8_on(TARG); 1516 } 1517 else { 1518 Newz(0, result, nchar + 1, U8); 1519 while (tmps < send) { 1520 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY); 1521 tmps += UTF8SKIP(tmps); 1522 *result++ = ~c; 1523 } 1524 *result = '\0'; 1525 result -= nchar; 1526 sv_setpvn(TARG, (char*)result, nchar); 1527 } 1528 Safefree(result); 1529 SETs(TARG); 1530 RETURN; 1531 } 1532 #ifdef LIBERAL 1533 { 1534 register long *tmpl; 1535 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) 1536 *tmps = ~*tmps; 1537 tmpl = (long*)tmps; 1538 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) 1539 *tmpl = ~*tmpl; 1540 tmps = (U8*)tmpl; 1541 } 1542 #endif 1543 for ( ; anum > 0; anum--, tmps++) 1544 *tmps = ~*tmps; 1545 1546 SETs(TARG); 1547 } 1548 RETURN; 1549 } 1550 } 1551 1552 /* integer versions of some of the above */ 1553 1554 PP(pp_i_multiply) 1555 { 1556 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); 1557 { 1558 dPOPTOPiirl; 1559 SETi( left * right ); 1560 RETURN; 1561 } 1562 } 1563 1564 PP(pp_i_divide) 1565 { 1566 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); 1567 { 1568 dPOPiv; 1569 if (value == 0) 1570 DIE(aTHX_ "Illegal division by zero"); 1571 value = POPi / value; 1572 PUSHi( value ); 1573 RETURN; 1574 } 1575 } 1576 1577 PP(pp_i_modulo) 1578 { 1579 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 1580 { 1581 dPOPTOPiirl; 1582 if (!right) 1583 DIE(aTHX_ "Illegal modulus zero"); 1584 SETi( left % right ); 1585 RETURN; 1586 } 1587 } 1588 1589 PP(pp_i_add) 1590 { 1591 dSP; dATARGET; tryAMAGICbin(add,opASSIGN); 1592 { 1593 dPOPTOPiirl_ul; 1594 SETi( left + right ); 1595 RETURN; 1596 } 1597 } 1598 1599 PP(pp_i_subtract) 1600 { 1601 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); 1602 { 1603 dPOPTOPiirl_ul; 1604 SETi( left - right ); 1605 RETURN; 1606 } 1607 } 1608 1609 PP(pp_i_lt) 1610 { 1611 dSP; tryAMAGICbinSET(lt,0); 1612 { 1613 dPOPTOPiirl; 1614 SETs(boolSV(left < right)); 1615 RETURN; 1616 } 1617 } 1618 1619 PP(pp_i_gt) 1620 { 1621 dSP; tryAMAGICbinSET(gt,0); 1622 { 1623 dPOPTOPiirl; 1624 SETs(boolSV(left > right)); 1625 RETURN; 1626 } 1627 } 1628 1629 PP(pp_i_le) 1630 { 1631 dSP; tryAMAGICbinSET(le,0); 1632 { 1633 dPOPTOPiirl; 1634 SETs(boolSV(left <= right)); 1635 RETURN; 1636 } 1637 } 1638 1639 PP(pp_i_ge) 1640 { 1641 dSP; tryAMAGICbinSET(ge,0); 1642 { 1643 dPOPTOPiirl; 1644 SETs(boolSV(left >= right)); 1645 RETURN; 1646 } 1647 } 1648 1649 PP(pp_i_eq) 1650 { 1651 dSP; tryAMAGICbinSET(eq,0); 1652 { 1653 dPOPTOPiirl; 1654 SETs(boolSV(left == right)); 1655 RETURN; 1656 } 1657 } 1658 1659 PP(pp_i_ne) 1660 { 1661 dSP; tryAMAGICbinSET(ne,0); 1662 { 1663 dPOPTOPiirl; 1664 SETs(boolSV(left != right)); 1665 RETURN; 1666 } 1667 } 1668 1669 PP(pp_i_ncmp) 1670 { 1671 dSP; dTARGET; tryAMAGICbin(ncmp,0); 1672 { 1673 dPOPTOPiirl; 1674 I32 value; 1675 1676 if (left > right) 1677 value = 1; 1678 else if (left < right) 1679 value = -1; 1680 else 1681 value = 0; 1682 SETi(value); 1683 RETURN; 1684 } 1685 } 1686 1687 PP(pp_i_negate) 1688 { 1689 dSP; dTARGET; tryAMAGICun(neg); 1690 SETi(-TOPi); 1691 RETURN; 1692 } 1693 1694 /* High falutin' math. */ 1695 1696 PP(pp_atan2) 1697 { 1698 dSP; dTARGET; tryAMAGICbin(atan2,0); 1699 { 1700 dPOPTOPnnrl; 1701 SETn(Perl_atan2(left, right)); 1702 RETURN; 1703 } 1704 } 1705 1706 PP(pp_sin) 1707 { 1708 dSP; dTARGET; tryAMAGICun(sin); 1709 { 1710 NV value; 1711 value = POPn; 1712 value = Perl_sin(value); 1713 XPUSHn(value); 1714 RETURN; 1715 } 1716 } 1717 1718 PP(pp_cos) 1719 { 1720 dSP; dTARGET; tryAMAGICun(cos); 1721 { 1722 NV value; 1723 value = POPn; 1724 value = Perl_cos(value); 1725 XPUSHn(value); 1726 RETURN; 1727 } 1728 } 1729 1730 /* Support Configure command-line overrides for rand() functions. 1731 After 5.005, perhaps we should replace this by Configure support 1732 for drand48(), random(), or rand(). For 5.005, though, maintain 1733 compatibility by calling rand() but allow the user to override it. 1734 See INSTALL for details. --Andy Dougherty 15 July 1998 1735 */ 1736 /* Now it's after 5.005, and Configure supports drand48() and random(), 1737 in addition to rand(). So the overrides should not be needed any more. 1738 --Jarkko Hietaniemi 27 September 1998 1739 */ 1740 1741 #ifndef HAS_DRAND48_PROTO 1742 extern double drand48 (void); 1743 #endif 1744 1745 PP(pp_rand) 1746 { 1747 dSP; dTARGET; 1748 NV value; 1749 if (MAXARG < 1) 1750 value = 1.0; 1751 else 1752 value = POPn; 1753 if (value == 0.0) 1754 value = 1.0; 1755 if (!PL_srand_called) { 1756 (void)seedDrand01((Rand_seed_t)seed()); 1757 PL_srand_called = TRUE; 1758 } 1759 value *= Drand01(); 1760 XPUSHn(value); 1761 RETURN; 1762 } 1763 1764 PP(pp_srand) 1765 { 1766 dSP; 1767 UV anum; 1768 if (MAXARG < 1) 1769 anum = seed(); 1770 else 1771 anum = POPu; 1772 (void)seedDrand01((Rand_seed_t)anum); 1773 PL_srand_called = TRUE; 1774 EXTEND(SP, 1); 1775 RETPUSHYES; 1776 } 1777 1778 STATIC U32 1779 S_seed(pTHX) 1780 { 1781 /* 1782 * This is really just a quick hack which grabs various garbage 1783 * values. It really should be a real hash algorithm which 1784 * spreads the effect of every input bit onto every output bit, 1785 * if someone who knows about such things would bother to write it. 1786 * Might be a good idea to add that function to CORE as well. 1787 * No numbers below come from careful analysis or anything here, 1788 * except they are primes and SEED_C1 > 1E6 to get a full-width 1789 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should 1790 * probably be bigger too. 1791 */ 1792 #if RANDBITS > 16 1793 # define SEED_C1 1000003 1794 #define SEED_C4 73819 1795 #else 1796 # define SEED_C1 25747 1797 #define SEED_C4 20639 1798 #endif 1799 #define SEED_C2 3 1800 #define SEED_C3 269 1801 #define SEED_C5 26107 1802 1803 #ifndef PERL_NO_DEV_RANDOM 1804 int fd; 1805 #endif 1806 U32 u; 1807 #ifdef VMS 1808 # include <starlet.h> 1809 /* when[] = (low 32 bits, high 32 bits) of time since epoch 1810 * in 100-ns units, typically incremented ever 10 ms. */ 1811 unsigned int when[2]; 1812 #else 1813 # ifdef HAS_GETTIMEOFDAY 1814 struct timeval when; 1815 # else 1816 Time_t when; 1817 # endif 1818 #endif 1819 1820 /* This test is an escape hatch, this symbol isn't set by Configure. */ 1821 #ifndef PERL_NO_DEV_RANDOM 1822 #ifndef PERL_RANDOM_DEVICE 1823 /* /dev/random isn't used by default because reads from it will block 1824 * if there isn't enough entropy available. You can compile with 1825 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there 1826 * is enough real entropy to fill the seed. */ 1827 # define PERL_RANDOM_DEVICE "/dev/urandom" 1828 #endif 1829 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); 1830 if (fd != -1) { 1831 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) 1832 u = 0; 1833 PerlLIO_close(fd); 1834 if (u) 1835 return u; 1836 } 1837 #endif 1838 1839 #ifdef VMS 1840 _ckvmssts(sys$gettim(when)); 1841 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; 1842 #else 1843 # ifdef HAS_GETTIMEOFDAY 1844 gettimeofday(&when,(struct timezone *) 0); 1845 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; 1846 # else 1847 (void)time(&when); 1848 u = (U32)SEED_C1 * when; 1849 # endif 1850 #endif 1851 u += SEED_C3 * (U32)PerlProc_getpid(); 1852 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); 1853 #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ 1854 u += SEED_C5 * (U32)PTR2UV(&when); 1855 #endif 1856 return u; 1857 } 1858 1859 PP(pp_exp) 1860 { 1861 dSP; dTARGET; tryAMAGICun(exp); 1862 { 1863 NV value; 1864 value = POPn; 1865 value = Perl_exp(value); 1866 XPUSHn(value); 1867 RETURN; 1868 } 1869 } 1870 1871 PP(pp_log) 1872 { 1873 dSP; dTARGET; tryAMAGICun(log); 1874 { 1875 NV value; 1876 value = POPn; 1877 if (value <= 0.0) { 1878 SET_NUMERIC_STANDARD(); 1879 DIE(aTHX_ "Can't take log of %g", value); 1880 } 1881 value = Perl_log(value); 1882 XPUSHn(value); 1883 RETURN; 1884 } 1885 } 1886 1887 PP(pp_sqrt) 1888 { 1889 dSP; dTARGET; tryAMAGICun(sqrt); 1890 { 1891 NV value; 1892 value = POPn; 1893 if (value < 0.0) { 1894 SET_NUMERIC_STANDARD(); 1895 DIE(aTHX_ "Can't take sqrt of %g", value); 1896 } 1897 value = Perl_sqrt(value); 1898 XPUSHn(value); 1899 RETURN; 1900 } 1901 } 1902 1903 PP(pp_int) 1904 { 1905 dSP; dTARGET; 1906 { 1907 NV value = TOPn; 1908 IV iv; 1909 1910 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { 1911 iv = SvIVX(TOPs); 1912 SETi(iv); 1913 } 1914 else { 1915 if (value >= 0.0) { 1916 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) 1917 (void)Perl_modf(value, &value); 1918 #else 1919 double tmp = (double)value; 1920 (void)Perl_modf(tmp, &tmp); 1921 value = (NV)tmp; 1922 #endif 1923 } 1924 else { 1925 #if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE) 1926 (void)Perl_modf(-value, &value); 1927 value = -value; 1928 #else 1929 double tmp = (double)value; 1930 (void)Perl_modf(-tmp, &tmp); 1931 value = -(NV)tmp; 1932 #endif 1933 } 1934 iv = I_V(value); 1935 if (iv == value) 1936 SETi(iv); 1937 else 1938 SETn(value); 1939 } 1940 } 1941 RETURN; 1942 } 1943 1944 PP(pp_abs) 1945 { 1946 dSP; dTARGET; tryAMAGICun(abs); 1947 { 1948 NV value = TOPn; 1949 IV iv; 1950 1951 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && 1952 (iv = SvIVX(TOPs)) != IV_MIN) { 1953 if (iv < 0) 1954 iv = -iv; 1955 SETi(iv); 1956 } 1957 else { 1958 if (value < 0.0) 1959 value = -value; 1960 SETn(value); 1961 } 1962 } 1963 RETURN; 1964 } 1965 1966 PP(pp_hex) 1967 { 1968 dSP; dTARGET; 1969 char *tmps; 1970 STRLEN argtype; 1971 STRLEN len; 1972 1973 tmps = (SvPVx(POPs, len)); 1974 argtype = 1; /* allow underscores */ 1975 XPUSHn(scan_hex(tmps, len, &argtype)); 1976 RETURN; 1977 } 1978 1979 PP(pp_oct) 1980 { 1981 dSP; dTARGET; 1982 NV value; 1983 STRLEN argtype; 1984 char *tmps; 1985 STRLEN len; 1986 1987 tmps = (SvPVx(POPs, len)); 1988 while (*tmps && len && isSPACE(*tmps)) 1989 tmps++, len--; 1990 if (*tmps == '0') 1991 tmps++, len--; 1992 argtype = 1; /* allow underscores */ 1993 if (*tmps == 'x') 1994 value = scan_hex(++tmps, --len, &argtype); 1995 else if (*tmps == 'b') 1996 value = scan_bin(++tmps, --len, &argtype); 1997 else 1998 value = scan_oct(tmps, len, &argtype); 1999 XPUSHn(value); 2000 RETURN; 2001 } 2002 2003 /* String stuff. */ 2004 2005 PP(pp_length) 2006 { 2007 dSP; dTARGET; 2008 SV *sv = TOPs; 2009 2010 if (DO_UTF8(sv)) 2011 SETi(sv_len_utf8(sv)); 2012 else 2013 SETi(sv_len(sv)); 2014 RETURN; 2015 } 2016 2017 PP(pp_substr) 2018 { 2019 dSP; dTARGET; 2020 SV *sv; 2021 I32 len; 2022 STRLEN curlen; 2023 STRLEN utf8_curlen; 2024 I32 pos; 2025 I32 rem; 2026 I32 fail; 2027 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 2028 char *tmps; 2029 I32 arybase = PL_curcop->cop_arybase; 2030 SV *repl_sv = NULL; 2031 char *repl = 0; 2032 STRLEN repl_len; 2033 int num_args = PL_op->op_private & 7; 2034 bool repl_need_utf8_upgrade = FALSE; 2035 bool repl_is_utf8 = FALSE; 2036 2037 SvTAINTED_off(TARG); /* decontaminate */ 2038 SvUTF8_off(TARG); /* decontaminate */ 2039 if (num_args > 2) { 2040 if (num_args > 3) { 2041 repl_sv = POPs; 2042 repl = SvPV(repl_sv, repl_len); 2043 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); 2044 } 2045 len = POPi; 2046 } 2047 pos = POPi; 2048 sv = POPs; 2049 PUTBACK; 2050 if (repl_sv) { 2051 if (repl_is_utf8) { 2052 if (!DO_UTF8(sv)) 2053 sv_utf8_upgrade(sv); 2054 } 2055 else if (DO_UTF8(sv)) 2056 repl_need_utf8_upgrade = TRUE; 2057 } 2058 tmps = SvPV(sv, curlen); 2059 if (DO_UTF8(sv)) { 2060 utf8_curlen = sv_len_utf8(sv); 2061 if (utf8_curlen == curlen) 2062 utf8_curlen = 0; 2063 else 2064 curlen = utf8_curlen; 2065 } 2066 else 2067 utf8_curlen = 0; 2068 2069 if (pos >= arybase) { 2070 pos -= arybase; 2071 rem = curlen-pos; 2072 fail = rem; 2073 if (num_args > 2) { 2074 if (len < 0) { 2075 rem += len; 2076 if (rem < 0) 2077 rem = 0; 2078 } 2079 else if (rem > len) 2080 rem = len; 2081 } 2082 } 2083 else { 2084 pos += curlen; 2085 if (num_args < 3) 2086 rem = curlen; 2087 else if (len >= 0) { 2088 rem = pos+len; 2089 if (rem > (I32)curlen) 2090 rem = curlen; 2091 } 2092 else { 2093 rem = curlen+len; 2094 if (rem < pos) 2095 rem = pos; 2096 } 2097 if (pos < 0) 2098 pos = 0; 2099 fail = rem; 2100 rem -= pos; 2101 } 2102 if (fail < 0) { 2103 if (lvalue || repl) 2104 Perl_croak(aTHX_ "substr outside of string"); 2105 if (ckWARN(WARN_SUBSTR)) 2106 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string"); 2107 RETPUSHUNDEF; 2108 } 2109 else { 2110 I32 upos = pos; 2111 I32 urem = rem; 2112 if (utf8_curlen) 2113 sv_pos_u2b(sv, &pos, &rem); 2114 tmps += pos; 2115 sv_setpvn(TARG, tmps, rem); 2116 if (utf8_curlen) 2117 SvUTF8_on(TARG); 2118 if (repl) { 2119 SV* repl_sv_copy = NULL; 2120 2121 if (repl_need_utf8_upgrade) { 2122 repl_sv_copy = newSVsv(repl_sv); 2123 sv_utf8_upgrade(repl_sv_copy); 2124 repl = SvPV(repl_sv_copy, repl_len); 2125 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); 2126 } 2127 sv_insert(sv, pos, rem, repl, repl_len); 2128 if (repl_is_utf8) 2129 SvUTF8_on(sv); 2130 if (repl_sv_copy) 2131 SvREFCNT_dec(repl_sv_copy); 2132 } 2133 else if (lvalue) { /* it's an lvalue! */ 2134 if (!SvGMAGICAL(sv)) { 2135 if (SvROK(sv)) { 2136 STRLEN n_a; 2137 SvPV_force(sv,n_a); 2138 if (ckWARN(WARN_SUBSTR)) 2139 Perl_warner(aTHX_ WARN_SUBSTR, 2140 "Attempt to use reference as lvalue in substr"); 2141 } 2142 if (SvOK(sv)) /* is it defined ? */ 2143 (void)SvPOK_only_UTF8(sv); 2144 else 2145 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ 2146 } 2147 2148 if (SvTYPE(TARG) < SVt_PVLV) { 2149 sv_upgrade(TARG, SVt_PVLV); 2150 sv_magic(TARG, Nullsv, 'x', Nullch, 0); 2151 } 2152 2153 LvTYPE(TARG) = 'x'; 2154 if (LvTARG(TARG) != sv) { 2155 if (LvTARG(TARG)) 2156 SvREFCNT_dec(LvTARG(TARG)); 2157 LvTARG(TARG) = SvREFCNT_inc(sv); 2158 } 2159 LvTARGOFF(TARG) = upos; 2160 LvTARGLEN(TARG) = urem; 2161 } 2162 } 2163 SPAGAIN; 2164 PUSHs(TARG); /* avoid SvSETMAGIC here */ 2165 RETURN; 2166 } 2167 2168 PP(pp_vec) 2169 { 2170 dSP; dTARGET; 2171 register IV size = POPi; 2172 register IV offset = POPi; 2173 register SV *src = POPs; 2174 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 2175 2176 SvTAINTED_off(TARG); /* decontaminate */ 2177 if (lvalue) { /* it's an lvalue! */ 2178 if (SvTYPE(TARG) < SVt_PVLV) { 2179 sv_upgrade(TARG, SVt_PVLV); 2180 sv_magic(TARG, Nullsv, 'v', Nullch, 0); 2181 } 2182 LvTYPE(TARG) = 'v'; 2183 if (LvTARG(TARG) != src) { 2184 if (LvTARG(TARG)) 2185 SvREFCNT_dec(LvTARG(TARG)); 2186 LvTARG(TARG) = SvREFCNT_inc(src); 2187 } 2188 LvTARGOFF(TARG) = offset; 2189 LvTARGLEN(TARG) = size; 2190 } 2191 2192 sv_setuv(TARG, do_vecget(src, offset, size)); 2193 PUSHs(TARG); 2194 RETURN; 2195 } 2196 2197 PP(pp_index) 2198 { 2199 dSP; dTARGET; 2200 SV *big; 2201 SV *little; 2202 I32 offset; 2203 I32 retval; 2204 char *tmps; 2205 char *tmps2; 2206 STRLEN biglen; 2207 I32 arybase = PL_curcop->cop_arybase; 2208 2209 if (MAXARG < 3) 2210 offset = 0; 2211 else 2212 offset = POPi - arybase; 2213 little = POPs; 2214 big = POPs; 2215 tmps = SvPV(big, biglen); 2216 if (offset > 0 && DO_UTF8(big)) 2217 sv_pos_u2b(big, &offset, 0); 2218 if (offset < 0) 2219 offset = 0; 2220 else if (offset > biglen) 2221 offset = biglen; 2222 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, 2223 (unsigned char*)tmps + biglen, little, 0))) 2224 retval = -1; 2225 else 2226 retval = tmps2 - tmps; 2227 if (retval > 0 && DO_UTF8(big)) 2228 sv_pos_b2u(big, &retval); 2229 PUSHi(retval + arybase); 2230 RETURN; 2231 } 2232 2233 PP(pp_rindex) 2234 { 2235 dSP; dTARGET; 2236 SV *big; 2237 SV *little; 2238 STRLEN blen; 2239 STRLEN llen; 2240 I32 offset; 2241 I32 retval; 2242 char *tmps; 2243 char *tmps2; 2244 I32 arybase = PL_curcop->cop_arybase; 2245 2246 if (MAXARG >= 3) 2247 offset = POPi; 2248 little = POPs; 2249 big = POPs; 2250 tmps2 = SvPV(little, llen); 2251 tmps = SvPV(big, blen); 2252 if (MAXARG < 3) 2253 offset = blen; 2254 else { 2255 if (offset > 0 && DO_UTF8(big)) 2256 sv_pos_u2b(big, &offset, 0); 2257 offset = offset - arybase + llen; 2258 } 2259 if (offset < 0) 2260 offset = 0; 2261 else if (offset > blen) 2262 offset = blen; 2263 if (!(tmps2 = rninstr(tmps, tmps + offset, 2264 tmps2, tmps2 + llen))) 2265 retval = -1; 2266 else 2267 retval = tmps2 - tmps; 2268 if (retval > 0 && DO_UTF8(big)) 2269 sv_pos_b2u(big, &retval); 2270 PUSHi(retval + arybase); 2271 RETURN; 2272 } 2273 2274 PP(pp_sprintf) 2275 { 2276 dSP; dMARK; dORIGMARK; dTARGET; 2277 do_sprintf(TARG, SP-MARK, MARK+1); 2278 TAINT_IF(SvTAINTED(TARG)); 2279 SP = ORIGMARK; 2280 PUSHTARG; 2281 RETURN; 2282 } 2283 2284 PP(pp_ord) 2285 { 2286 dSP; dTARGET; 2287 SV *argsv = POPs; 2288 STRLEN len; 2289 U8 *s = (U8*)SvPVx(argsv, len); 2290 2291 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff)); 2292 RETURN; 2293 } 2294 2295 PP(pp_chr) 2296 { 2297 dSP; dTARGET; 2298 char *tmps; 2299 UV value = POPu; 2300 2301 (void)SvUPGRADE(TARG,SVt_PV); 2302 2303 if (value > 255 && !IN_BYTE) { 2304 SvGROW(TARG, UTF8_MAXLEN+1); 2305 tmps = SvPVX(TARG); 2306 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value); 2307 SvCUR_set(TARG, tmps - SvPVX(TARG)); 2308 *tmps = '\0'; 2309 (void)SvPOK_only(TARG); 2310 SvUTF8_on(TARG); 2311 XPUSHs(TARG); 2312 RETURN; 2313 } 2314 2315 SvGROW(TARG,2); 2316 SvCUR_set(TARG, 1); 2317 tmps = SvPVX(TARG); 2318 *tmps++ = value; 2319 *tmps = '\0'; 2320 (void)SvPOK_only(TARG); 2321 XPUSHs(TARG); 2322 RETURN; 2323 } 2324 2325 PP(pp_crypt) 2326 { 2327 dSP; dTARGET; dPOPTOPssrl; 2328 STRLEN n_a; 2329 #ifdef HAS_CRYPT 2330 char *tmps = SvPV(left, n_a); 2331 #ifdef FCRYPT 2332 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); 2333 #else 2334 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); 2335 #endif 2336 #else 2337 DIE(aTHX_ 2338 "The crypt() function is unimplemented due to excessive paranoia."); 2339 #endif 2340 SETs(TARG); 2341 RETURN; 2342 } 2343 2344 PP(pp_ucfirst) 2345 { 2346 dSP; 2347 SV *sv = TOPs; 2348 register U8 *s; 2349 STRLEN slen; 2350 2351 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { 2352 STRLEN ulen; 2353 U8 tmpbuf[UTF8_MAXLEN+1]; 2354 U8 *tend; 2355 UV uv = utf8_to_uv(s, slen, &ulen, 0); 2356 2357 if (PL_op->op_private & OPpLOCALE) { 2358 TAINT; 2359 SvTAINTED_on(sv); 2360 uv = toTITLE_LC_uni(uv); 2361 } 2362 else 2363 uv = toTITLE_utf8(s); 2364 2365 tend = uv_to_utf8(tmpbuf, uv); 2366 2367 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { 2368 dTARGET; 2369 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); 2370 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 2371 SvUTF8_on(TARG); 2372 SETs(TARG); 2373 } 2374 else { 2375 s = (U8*)SvPV_force(sv, slen); 2376 Copy(tmpbuf, s, ulen, U8); 2377 } 2378 } 2379 else { 2380 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 2381 dTARGET; 2382 SvUTF8_off(TARG); /* decontaminate */ 2383 sv_setsv(TARG, sv); 2384 sv = TARG; 2385 SETs(sv); 2386 } 2387 s = (U8*)SvPV_force(sv, slen); 2388 if (*s) { 2389 if (PL_op->op_private & OPpLOCALE) { 2390 TAINT; 2391 SvTAINTED_on(sv); 2392 *s = toUPPER_LC(*s); 2393 } 2394 else 2395 *s = toUPPER(*s); 2396 } 2397 } 2398 if (SvSMAGICAL(sv)) 2399 mg_set(sv); 2400 RETURN; 2401 } 2402 2403 PP(pp_lcfirst) 2404 { 2405 dSP; 2406 SV *sv = TOPs; 2407 register U8 *s; 2408 STRLEN slen; 2409 2410 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) { 2411 STRLEN ulen; 2412 U8 tmpbuf[UTF8_MAXLEN+1]; 2413 U8 *tend; 2414 UV uv = utf8_to_uv(s, slen, &ulen, 0); 2415 2416 if (PL_op->op_private & OPpLOCALE) { 2417 TAINT; 2418 SvTAINTED_on(sv); 2419 uv = toLOWER_LC_uni(uv); 2420 } 2421 else 2422 uv = toLOWER_utf8(s); 2423 2424 tend = uv_to_utf8(tmpbuf, uv); 2425 2426 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) { 2427 dTARGET; 2428 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); 2429 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 2430 SvUTF8_on(TARG); 2431 SETs(TARG); 2432 } 2433 else { 2434 s = (U8*)SvPV_force(sv, slen); 2435 Copy(tmpbuf, s, ulen, U8); 2436 } 2437 } 2438 else { 2439 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 2440 dTARGET; 2441 SvUTF8_off(TARG); /* decontaminate */ 2442 sv_setsv(TARG, sv); 2443 sv = TARG; 2444 SETs(sv); 2445 } 2446 s = (U8*)SvPV_force(sv, slen); 2447 if (*s) { 2448 if (PL_op->op_private & OPpLOCALE) { 2449 TAINT; 2450 SvTAINTED_on(sv); 2451 *s = toLOWER_LC(*s); 2452 } 2453 else 2454 *s = toLOWER(*s); 2455 } 2456 } 2457 if (SvSMAGICAL(sv)) 2458 mg_set(sv); 2459 RETURN; 2460 } 2461 2462 PP(pp_uc) 2463 { 2464 dSP; 2465 SV *sv = TOPs; 2466 register U8 *s; 2467 STRLEN len; 2468 2469 if (DO_UTF8(sv)) { 2470 dTARGET; 2471 STRLEN ulen; 2472 register U8 *d; 2473 U8 *send; 2474 2475 s = (U8*)SvPV(sv,len); 2476 if (!len) { 2477 SvUTF8_off(TARG); /* decontaminate */ 2478 sv_setpvn(TARG, "", 0); 2479 SETs(TARG); 2480 } 2481 else { 2482 (void)SvUPGRADE(TARG, SVt_PV); 2483 SvGROW(TARG, (len * 2) + 1); 2484 (void)SvPOK_only(TARG); 2485 d = (U8*)SvPVX(TARG); 2486 send = s + len; 2487 if (PL_op->op_private & OPpLOCALE) { 2488 TAINT; 2489 SvTAINTED_on(TARG); 2490 while (s < send) { 2491 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); 2492 s += ulen; 2493 } 2494 } 2495 else { 2496 while (s < send) { 2497 d = uv_to_utf8(d, toUPPER_utf8( s )); 2498 s += UTF8SKIP(s); 2499 } 2500 } 2501 *d = '\0'; 2502 SvUTF8_on(TARG); 2503 SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); 2504 SETs(TARG); 2505 } 2506 } 2507 else { 2508 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 2509 dTARGET; 2510 SvUTF8_off(TARG); /* decontaminate */ 2511 sv_setsv(TARG, sv); 2512 sv = TARG; 2513 SETs(sv); 2514 } 2515 s = (U8*)SvPV_force(sv, len); 2516 if (len) { 2517 register U8 *send = s + len; 2518 2519 if (PL_op->op_private & OPpLOCALE) { 2520 TAINT; 2521 SvTAINTED_on(sv); 2522 for (; s < send; s++) 2523 *s = toUPPER_LC(*s); 2524 } 2525 else { 2526 for (; s < send; s++) 2527 *s = toUPPER(*s); 2528 } 2529 } 2530 } 2531 if (SvSMAGICAL(sv)) 2532 mg_set(sv); 2533 RETURN; 2534 } 2535 2536 PP(pp_lc) 2537 { 2538 dSP; 2539 SV *sv = TOPs; 2540 register U8 *s; 2541 STRLEN len; 2542 2543 if (DO_UTF8(sv)) { 2544 dTARGET; 2545 STRLEN ulen; 2546 register U8 *d; 2547 U8 *send; 2548 2549 s = (U8*)SvPV(sv,len); 2550 if (!len) { 2551 SvUTF8_off(TARG); /* decontaminate */ 2552 sv_setpvn(TARG, "", 0); 2553 SETs(TARG); 2554 } 2555 else { 2556 (void)SvUPGRADE(TARG, SVt_PV); 2557 SvGROW(TARG, (len * 2) + 1); 2558 (void)SvPOK_only(TARG); 2559 d = (U8*)SvPVX(TARG); 2560 send = s + len; 2561 if (PL_op->op_private & OPpLOCALE) { 2562 TAINT; 2563 SvTAINTED_on(TARG); 2564 while (s < send) { 2565 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0))); 2566 s += ulen; 2567 } 2568 } 2569 else { 2570 while (s < send) { 2571 d = uv_to_utf8(d, toLOWER_utf8(s)); 2572 s += UTF8SKIP(s); 2573 } 2574 } 2575 *d = '\0'; 2576 SvUTF8_on(TARG); 2577 SvCUR_set(TARG, d - (U8*)SvPVX(TARG)); 2578 SETs(TARG); 2579 } 2580 } 2581 else { 2582 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 2583 dTARGET; 2584 SvUTF8_off(TARG); /* decontaminate */ 2585 sv_setsv(TARG, sv); 2586 sv = TARG; 2587 SETs(sv); 2588 } 2589 2590 s = (U8*)SvPV_force(sv, len); 2591 if (len) { 2592 register U8 *send = s + len; 2593 2594 if (PL_op->op_private & OPpLOCALE) { 2595 TAINT; 2596 SvTAINTED_on(sv); 2597 for (; s < send; s++) 2598 *s = toLOWER_LC(*s); 2599 } 2600 else { 2601 for (; s < send; s++) 2602 *s = toLOWER(*s); 2603 } 2604 } 2605 } 2606 if (SvSMAGICAL(sv)) 2607 mg_set(sv); 2608 RETURN; 2609 } 2610 2611 PP(pp_quotemeta) 2612 { 2613 dSP; dTARGET; 2614 SV *sv = TOPs; 2615 STRLEN len; 2616 register char *s = SvPV(sv,len); 2617 register char *d; 2618 2619 SvUTF8_off(TARG); /* decontaminate */ 2620 if (len) { 2621 (void)SvUPGRADE(TARG, SVt_PV); 2622 SvGROW(TARG, (len * 2) + 1); 2623 d = SvPVX(TARG); 2624 if (DO_UTF8(sv)) { 2625 while (len) { 2626 if (UTF8_IS_CONTINUED(*s)) { 2627 STRLEN ulen = UTF8SKIP(s); 2628 if (ulen > len) 2629 ulen = len; 2630 len -= ulen; 2631 while (ulen--) 2632 *d++ = *s++; 2633 } 2634 else { 2635 if (!isALNUM(*s)) 2636 *d++ = '\\'; 2637 *d++ = *s++; 2638 len--; 2639 } 2640 } 2641 SvUTF8_on(TARG); 2642 } 2643 else { 2644 while (len--) { 2645 if (!isALNUM(*s)) 2646 *d++ = '\\'; 2647 *d++ = *s++; 2648 } 2649 } 2650 *d = '\0'; 2651 SvCUR_set(TARG, d - SvPVX(TARG)); 2652 (void)SvPOK_only_UTF8(TARG); 2653 } 2654 else 2655 sv_setpvn(TARG, s, len); 2656 SETs(TARG); 2657 if (SvSMAGICAL(TARG)) 2658 mg_set(TARG); 2659 RETURN; 2660 } 2661 2662 /* Arrays. */ 2663 2664 PP(pp_aslice) 2665 { 2666 dSP; dMARK; dORIGMARK; 2667 register SV** svp; 2668 register AV* av = (AV*)POPs; 2669 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 2670 I32 arybase = PL_curcop->cop_arybase; 2671 I32 elem; 2672 2673 if (SvTYPE(av) == SVt_PVAV) { 2674 if (lval && PL_op->op_private & OPpLVAL_INTRO) { 2675 I32 max = -1; 2676 for (svp = MARK + 1; svp <= SP; svp++) { 2677 elem = SvIVx(*svp); 2678 if (elem > max) 2679 max = elem; 2680 } 2681 if (max > AvMAX(av)) 2682 av_extend(av, max); 2683 } 2684 while (++MARK <= SP) { 2685 elem = SvIVx(*MARK); 2686 2687 if (elem > 0) 2688 elem -= arybase; 2689 svp = av_fetch(av, elem, lval); 2690 if (lval) { 2691 if (!svp || *svp == &PL_sv_undef) 2692 DIE(aTHX_ PL_no_aelem, elem); 2693 if (PL_op->op_private & OPpLVAL_INTRO) 2694 save_aelem(av, elem, svp); 2695 } 2696 *MARK = svp ? *svp : &PL_sv_undef; 2697 } 2698 } 2699 if (GIMME != G_ARRAY) { 2700 MARK = ORIGMARK; 2701 *++MARK = *SP; 2702 SP = MARK; 2703 } 2704 RETURN; 2705 } 2706 2707 /* Associative arrays. */ 2708 2709 PP(pp_each) 2710 { 2711 dSP; 2712 HV *hash = (HV*)POPs; 2713 HE *entry; 2714 I32 gimme = GIMME_V; 2715 I32 realhv = (SvTYPE(hash) == SVt_PVHV); 2716 2717 PUTBACK; 2718 /* might clobber stack_sp */ 2719 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); 2720 SPAGAIN; 2721 2722 EXTEND(SP, 2); 2723 if (entry) { 2724 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ 2725 if (gimme == G_ARRAY) { 2726 SV *val; 2727 PUTBACK; 2728 /* might clobber stack_sp */ 2729 val = realhv ? 2730 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); 2731 SPAGAIN; 2732 PUSHs(val); 2733 } 2734 } 2735 else if (gimme == G_SCALAR) 2736 RETPUSHUNDEF; 2737 2738 RETURN; 2739 } 2740 2741 PP(pp_values) 2742 { 2743 return do_kv(); 2744 } 2745 2746 PP(pp_keys) 2747 { 2748 return do_kv(); 2749 } 2750 2751 PP(pp_delete) 2752 { 2753 dSP; 2754 I32 gimme = GIMME_V; 2755 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; 2756 SV *sv; 2757 HV *hv; 2758 2759 if (PL_op->op_private & OPpSLICE) { 2760 dMARK; dORIGMARK; 2761 U32 hvtype; 2762 hv = (HV*)POPs; 2763 hvtype = SvTYPE(hv); 2764 if (hvtype == SVt_PVHV) { /* hash element */ 2765 while (++MARK <= SP) { 2766 sv = hv_delete_ent(hv, *MARK, discard, 0); 2767 *MARK = sv ? sv : &PL_sv_undef; 2768 } 2769 } 2770 else if (hvtype == SVt_PVAV) { 2771 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 2772 while (++MARK <= SP) { 2773 sv = av_delete((AV*)hv, SvIV(*MARK), discard); 2774 *MARK = sv ? sv : &PL_sv_undef; 2775 } 2776 } 2777 else { /* pseudo-hash element */ 2778 while (++MARK <= SP) { 2779 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0); 2780 *MARK = sv ? sv : &PL_sv_undef; 2781 } 2782 } 2783 } 2784 else 2785 DIE(aTHX_ "Not a HASH reference"); 2786 if (discard) 2787 SP = ORIGMARK; 2788 else if (gimme == G_SCALAR) { 2789 MARK = ORIGMARK; 2790 *++MARK = *SP; 2791 SP = MARK; 2792 } 2793 } 2794 else { 2795 SV *keysv = POPs; 2796 hv = (HV*)POPs; 2797 if (SvTYPE(hv) == SVt_PVHV) 2798 sv = hv_delete_ent(hv, keysv, discard, 0); 2799 else if (SvTYPE(hv) == SVt_PVAV) { 2800 if (PL_op->op_flags & OPf_SPECIAL) 2801 sv = av_delete((AV*)hv, SvIV(keysv), discard); 2802 else 2803 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0); 2804 } 2805 else 2806 DIE(aTHX_ "Not a HASH reference"); 2807 if (!sv) 2808 sv = &PL_sv_undef; 2809 if (!discard) 2810 PUSHs(sv); 2811 } 2812 RETURN; 2813 } 2814 2815 PP(pp_exists) 2816 { 2817 dSP; 2818 SV *tmpsv; 2819 HV *hv; 2820 2821 if (PL_op->op_private & OPpEXISTS_SUB) { 2822 GV *gv; 2823 CV *cv; 2824 SV *sv = POPs; 2825 cv = sv_2cv(sv, &hv, &gv, FALSE); 2826 if (cv) 2827 RETPUSHYES; 2828 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) 2829 RETPUSHYES; 2830 RETPUSHNO; 2831 } 2832 tmpsv = POPs; 2833 hv = (HV*)POPs; 2834 if (SvTYPE(hv) == SVt_PVHV) { 2835 if (hv_exists_ent(hv, tmpsv, 0)) 2836 RETPUSHYES; 2837 } 2838 else if (SvTYPE(hv) == SVt_PVAV) { 2839 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 2840 if (av_exists((AV*)hv, SvIV(tmpsv))) 2841 RETPUSHYES; 2842 } 2843 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */ 2844 RETPUSHYES; 2845 } 2846 else { 2847 DIE(aTHX_ "Not a HASH reference"); 2848 } 2849 RETPUSHNO; 2850 } 2851 2852 PP(pp_hslice) 2853 { 2854 dSP; dMARK; dORIGMARK; 2855 register HV *hv = (HV*)POPs; 2856 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 2857 I32 realhv = (SvTYPE(hv) == SVt_PVHV); 2858 2859 if (!realhv && PL_op->op_private & OPpLVAL_INTRO) 2860 DIE(aTHX_ "Can't localize pseudo-hash element"); 2861 2862 if (realhv || SvTYPE(hv) == SVt_PVAV) { 2863 while (++MARK <= SP) { 2864 SV *keysv = *MARK; 2865 SV **svp; 2866 if (realhv) { 2867 HE *he = hv_fetch_ent(hv, keysv, lval, 0); 2868 svp = he ? &HeVAL(he) : 0; 2869 } 2870 else { 2871 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0); 2872 } 2873 if (lval) { 2874 if (!svp || *svp == &PL_sv_undef) { 2875 STRLEN n_a; 2876 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); 2877 } 2878 if (PL_op->op_private & OPpLVAL_INTRO) 2879 save_helem(hv, keysv, svp); 2880 } 2881 *MARK = svp ? *svp : &PL_sv_undef; 2882 } 2883 } 2884 if (GIMME != G_ARRAY) { 2885 MARK = ORIGMARK; 2886 *++MARK = *SP; 2887 SP = MARK; 2888 } 2889 RETURN; 2890 } 2891 2892 /* List operators. */ 2893 2894 PP(pp_list) 2895 { 2896 dSP; dMARK; 2897 if (GIMME != G_ARRAY) { 2898 if (++MARK <= SP) 2899 *MARK = *SP; /* unwanted list, return last item */ 2900 else 2901 *MARK = &PL_sv_undef; 2902 SP = MARK; 2903 } 2904 RETURN; 2905 } 2906 2907 PP(pp_lslice) 2908 { 2909 dSP; 2910 SV **lastrelem = PL_stack_sp; 2911 SV **lastlelem = PL_stack_base + POPMARK; 2912 SV **firstlelem = PL_stack_base + POPMARK + 1; 2913 register SV **firstrelem = lastlelem + 1; 2914 I32 arybase = PL_curcop->cop_arybase; 2915 I32 lval = PL_op->op_flags & OPf_MOD; 2916 I32 is_something_there = lval; 2917 2918 register I32 max = lastrelem - lastlelem; 2919 register SV **lelem; 2920 register I32 ix; 2921 2922 if (GIMME != G_ARRAY) { 2923 ix = SvIVx(*lastlelem); 2924 if (ix < 0) 2925 ix += max; 2926 else 2927 ix -= arybase; 2928 if (ix < 0 || ix >= max) 2929 *firstlelem = &PL_sv_undef; 2930 else 2931 *firstlelem = firstrelem[ix]; 2932 SP = firstlelem; 2933 RETURN; 2934 } 2935 2936 if (max == 0) { 2937 SP = firstlelem - 1; 2938 RETURN; 2939 } 2940 2941 for (lelem = firstlelem; lelem <= lastlelem; lelem++) { 2942 ix = SvIVx(*lelem); 2943 if (ix < 0) 2944 ix += max; 2945 else 2946 ix -= arybase; 2947 if (ix < 0 || ix >= max) 2948 *lelem = &PL_sv_undef; 2949 else { 2950 is_something_there = TRUE; 2951 if (!(*lelem = firstrelem[ix])) 2952 *lelem = &PL_sv_undef; 2953 } 2954 } 2955 if (is_something_there) 2956 SP = lastlelem; 2957 else 2958 SP = firstlelem - 1; 2959 RETURN; 2960 } 2961 2962 PP(pp_anonlist) 2963 { 2964 dSP; dMARK; dORIGMARK; 2965 I32 items = SP - MARK; 2966 SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); 2967 SP = ORIGMARK; /* av_make() might realloc stack_sp */ 2968 XPUSHs(av); 2969 RETURN; 2970 } 2971 2972 PP(pp_anonhash) 2973 { 2974 dSP; dMARK; dORIGMARK; 2975 HV* hv = (HV*)sv_2mortal((SV*)newHV()); 2976 2977 while (MARK < SP) { 2978 SV* key = *++MARK; 2979 SV *val = NEWSV(46, 0); 2980 if (MARK < SP) 2981 sv_setsv(val, *++MARK); 2982 else if (ckWARN(WARN_MISC)) 2983 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment"); 2984 (void)hv_store_ent(hv,key,val,0); 2985 } 2986 SP = ORIGMARK; 2987 XPUSHs((SV*)hv); 2988 RETURN; 2989 } 2990 2991 PP(pp_splice) 2992 { 2993 dSP; dMARK; dORIGMARK; 2994 register AV *ary = (AV*)*++MARK; 2995 register SV **src; 2996 register SV **dst; 2997 register I32 i; 2998 register I32 offset; 2999 register I32 length; 3000 I32 newlen; 3001 I32 after; 3002 I32 diff; 3003 SV **tmparyval = 0; 3004 MAGIC *mg; 3005 3006 if ((mg = SvTIED_mg((SV*)ary, 'P'))) { 3007 *MARK-- = SvTIED_obj((SV*)ary, mg); 3008 PUSHMARK(MARK); 3009 PUTBACK; 3010 ENTER; 3011 call_method("SPLICE",GIMME_V); 3012 LEAVE; 3013 SPAGAIN; 3014 RETURN; 3015 } 3016 3017 SP++; 3018 3019 if (++MARK < SP) { 3020 offset = i = SvIVx(*MARK); 3021 if (offset < 0) 3022 offset += AvFILLp(ary) + 1; 3023 else 3024 offset -= PL_curcop->cop_arybase; 3025 if (offset < 0) 3026 DIE(aTHX_ PL_no_aelem, i); 3027 if (++MARK < SP) { 3028 length = SvIVx(*MARK++); 3029 if (length < 0) { 3030 length += AvFILLp(ary) - offset + 1; 3031 if (length < 0) 3032 length = 0; 3033 } 3034 } 3035 else 3036 length = AvMAX(ary) + 1; /* close enough to infinity */ 3037 } 3038 else { 3039 offset = 0; 3040 length = AvMAX(ary) + 1; 3041 } 3042 if (offset > AvFILLp(ary) + 1) 3043 offset = AvFILLp(ary) + 1; 3044 after = AvFILLp(ary) + 1 - (offset + length); 3045 if (after < 0) { /* not that much array */ 3046 length += after; /* offset+length now in array */ 3047 after = 0; 3048 if (!AvALLOC(ary)) 3049 av_extend(ary, 0); 3050 } 3051 3052 /* At this point, MARK .. SP-1 is our new LIST */ 3053 3054 newlen = SP - MARK; 3055 diff = newlen - length; 3056 if (newlen && !AvREAL(ary) && AvREIFY(ary)) 3057 av_reify(ary); 3058 3059 if (diff < 0) { /* shrinking the area */ 3060 if (newlen) { 3061 New(451, tmparyval, newlen, SV*); /* so remember insertion */ 3062 Copy(MARK, tmparyval, newlen, SV*); 3063 } 3064 3065 MARK = ORIGMARK + 1; 3066 if (GIMME == G_ARRAY) { /* copy return vals to stack */ 3067 MEXTEND(MARK, length); 3068 Copy(AvARRAY(ary)+offset, MARK, length, SV*); 3069 if (AvREAL(ary)) { 3070 EXTEND_MORTAL(length); 3071 for (i = length, dst = MARK; i; i--) { 3072 sv_2mortal(*dst); /* free them eventualy */ 3073 dst++; 3074 } 3075 } 3076 MARK += length - 1; 3077 } 3078 else { 3079 *MARK = AvARRAY(ary)[offset+length-1]; 3080 if (AvREAL(ary)) { 3081 sv_2mortal(*MARK); 3082 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) 3083 SvREFCNT_dec(*dst++); /* free them now */ 3084 } 3085 } 3086 AvFILLp(ary) += diff; 3087 3088 /* pull up or down? */ 3089 3090 if (offset < after) { /* easier to pull up */ 3091 if (offset) { /* esp. if nothing to pull */ 3092 src = &AvARRAY(ary)[offset-1]; 3093 dst = src - diff; /* diff is negative */ 3094 for (i = offset; i > 0; i--) /* can't trust Copy */ 3095 *dst-- = *src--; 3096 } 3097 dst = AvARRAY(ary); 3098 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ 3099 AvMAX(ary) += diff; 3100 } 3101 else { 3102 if (after) { /* anything to pull down? */ 3103 src = AvARRAY(ary) + offset + length; 3104 dst = src + diff; /* diff is negative */ 3105 Move(src, dst, after, SV*); 3106 } 3107 dst = &AvARRAY(ary)[AvFILLp(ary)+1]; 3108 /* avoid later double free */ 3109 } 3110 i = -diff; 3111 while (i) 3112 dst[--i] = &PL_sv_undef; 3113 3114 if (newlen) { 3115 for (src = tmparyval, dst = AvARRAY(ary) + offset; 3116 newlen; newlen--) { 3117 *dst = NEWSV(46, 0); 3118 sv_setsv(*dst++, *src++); 3119 } 3120 Safefree(tmparyval); 3121 } 3122 } 3123 else { /* no, expanding (or same) */ 3124 if (length) { 3125 New(452, tmparyval, length, SV*); /* so remember deletion */ 3126 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); 3127 } 3128 3129 if (diff > 0) { /* expanding */ 3130 3131 /* push up or down? */ 3132 3133 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { 3134 if (offset) { 3135 src = AvARRAY(ary); 3136 dst = src - diff; 3137 Move(src, dst, offset, SV*); 3138 } 3139 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ 3140 AvMAX(ary) += diff; 3141 AvFILLp(ary) += diff; 3142 } 3143 else { 3144 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ 3145 av_extend(ary, AvFILLp(ary) + diff); 3146 AvFILLp(ary) += diff; 3147 3148 if (after) { 3149 dst = AvARRAY(ary) + AvFILLp(ary); 3150 src = dst - diff; 3151 for (i = after; i; i--) { 3152 *dst-- = *src--; 3153 } 3154 } 3155 } 3156 } 3157 3158 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { 3159 *dst = NEWSV(46, 0); 3160 sv_setsv(*dst++, *src++); 3161 } 3162 MARK = ORIGMARK + 1; 3163 if (GIMME == G_ARRAY) { /* copy return vals to stack */ 3164 if (length) { 3165 Copy(tmparyval, MARK, length, SV*); 3166 if (AvREAL(ary)) { 3167 EXTEND_MORTAL(length); 3168 for (i = length, dst = MARK; i; i--) { 3169 sv_2mortal(*dst); /* free them eventualy */ 3170 dst++; 3171 } 3172 } 3173 Safefree(tmparyval); 3174 } 3175 MARK += length - 1; 3176 } 3177 else if (length--) { 3178 *MARK = tmparyval[length]; 3179 if (AvREAL(ary)) { 3180 sv_2mortal(*MARK); 3181 while (length-- > 0) 3182 SvREFCNT_dec(tmparyval[length]); 3183 } 3184 Safefree(tmparyval); 3185 } 3186 else 3187 *MARK = &PL_sv_undef; 3188 } 3189 SP = MARK; 3190 RETURN; 3191 } 3192 3193 PP(pp_push) 3194 { 3195 dSP; dMARK; dORIGMARK; dTARGET; 3196 register AV *ary = (AV*)*++MARK; 3197 register SV *sv = &PL_sv_undef; 3198 MAGIC *mg; 3199 3200 if ((mg = SvTIED_mg((SV*)ary, 'P'))) { 3201 *MARK-- = SvTIED_obj((SV*)ary, mg); 3202 PUSHMARK(MARK); 3203 PUTBACK; 3204 ENTER; 3205 call_method("PUSH",G_SCALAR|G_DISCARD); 3206 LEAVE; 3207 SPAGAIN; 3208 } 3209 else { 3210 /* Why no pre-extend of ary here ? */ 3211 for (++MARK; MARK <= SP; MARK++) { 3212 sv = NEWSV(51, 0); 3213 if (*MARK) 3214 sv_setsv(sv, *MARK); 3215 av_push(ary, sv); 3216 } 3217 } 3218 SP = ORIGMARK; 3219 PUSHi( AvFILL(ary) + 1 ); 3220 RETURN; 3221 } 3222 3223 PP(pp_pop) 3224 { 3225 dSP; 3226 AV *av = (AV*)POPs; 3227 SV *sv = av_pop(av); 3228 if (AvREAL(av)) 3229 (void)sv_2mortal(sv); 3230 PUSHs(sv); 3231 RETURN; 3232 } 3233 3234 PP(pp_shift) 3235 { 3236 dSP; 3237 AV *av = (AV*)POPs; 3238 SV *sv = av_shift(av); 3239 EXTEND(SP, 1); 3240 if (!sv) 3241 RETPUSHUNDEF; 3242 if (AvREAL(av)) 3243 (void)sv_2mortal(sv); 3244 PUSHs(sv); 3245 RETURN; 3246 } 3247 3248 PP(pp_unshift) 3249 { 3250 dSP; dMARK; dORIGMARK; dTARGET; 3251 register AV *ary = (AV*)*++MARK; 3252 register SV *sv; 3253 register I32 i = 0; 3254 MAGIC *mg; 3255 3256 if ((mg = SvTIED_mg((SV*)ary, 'P'))) { 3257 *MARK-- = SvTIED_obj((SV*)ary, mg); 3258 PUSHMARK(MARK); 3259 PUTBACK; 3260 ENTER; 3261 call_method("UNSHIFT",G_SCALAR|G_DISCARD); 3262 LEAVE; 3263 SPAGAIN; 3264 } 3265 else { 3266 av_unshift(ary, SP - MARK); 3267 while (MARK < SP) { 3268 sv = NEWSV(27, 0); 3269 sv_setsv(sv, *++MARK); 3270 (void)av_store(ary, i++, sv); 3271 } 3272 } 3273 SP = ORIGMARK; 3274 PUSHi( AvFILL(ary) + 1 ); 3275 RETURN; 3276 } 3277 3278 PP(pp_reverse) 3279 { 3280 dSP; dMARK; 3281 register SV *tmp; 3282 SV **oldsp = SP; 3283 3284 if (GIMME == G_ARRAY) { 3285 MARK++; 3286 while (MARK < SP) { 3287 tmp = *MARK; 3288 *MARK++ = *SP; 3289 *SP-- = tmp; 3290 } 3291 /* safe as long as stack cannot get extended in the above */ 3292 SP = oldsp; 3293 } 3294 else { 3295 register char *up; 3296 register char *down; 3297 register I32 tmp; 3298 dTARGET; 3299 STRLEN len; 3300 3301 SvUTF8_off(TARG); /* decontaminate */ 3302 if (SP - MARK > 1) 3303 do_join(TARG, &PL_sv_no, MARK, SP); 3304 else 3305 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV); 3306 up = SvPV_force(TARG, len); 3307 if (len > 1) { 3308 if (DO_UTF8(TARG)) { /* first reverse each character */ 3309 U8* s = (U8*)SvPVX(TARG); 3310 U8* send = (U8*)(s + len); 3311 while (s < send) { 3312 if (UTF8_IS_ASCII(*s)) { 3313 s++; 3314 continue; 3315 } 3316 else { 3317 if (!utf8_to_uv_simple(s, 0)) 3318 break; 3319 up = (char*)s; 3320 s += UTF8SKIP(s); 3321 down = (char*)(s - 1); 3322 /* reverse this character */ 3323 while (down > up) { 3324 tmp = *up; 3325 *up++ = *down; 3326 *down-- = tmp; 3327 } 3328 } 3329 } 3330 up = SvPVX(TARG); 3331 } 3332 down = SvPVX(TARG) + len - 1; 3333 while (down > up) { 3334 tmp = *up; 3335 *up++ = *down; 3336 *down-- = tmp; 3337 } 3338 (void)SvPOK_only_UTF8(TARG); 3339 } 3340 SP = MARK + 1; 3341 SETTARG; 3342 } 3343 RETURN; 3344 } 3345 3346 STATIC SV * 3347 S_mul128(pTHX_ SV *sv, U8 m) 3348 { 3349 STRLEN len; 3350 char *s = SvPV(sv, len); 3351 char *t; 3352 U32 i = 0; 3353 3354 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ 3355 SV *tmpNew = newSVpvn("0000000000", 10); 3356 3357 sv_catsv(tmpNew, sv); 3358 SvREFCNT_dec(sv); /* free old sv */ 3359 sv = tmpNew; 3360 s = SvPV(sv, len); 3361 } 3362 t = s + len - 1; 3363 while (!*t) /* trailing '\0'? */ 3364 t--; 3365 while (t > s) { 3366 i = ((*t - '0') << 7) + m; 3367 *(t--) = '0' + (i % 10); 3368 m = i / 10; 3369 } 3370 return (sv); 3371 } 3372 3373 /* Explosives and implosives. */ 3374 3375 #if 'I' == 73 && 'J' == 74 3376 /* On an ASCII/ISO kind of system */ 3377 #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') 3378 #else 3379 /* 3380 Some other sort of character set - use memchr() so we don't match 3381 the null byte. 3382 */ 3383 #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') 3384 #endif 3385 3386 PP(pp_unpack) 3387 { 3388 dSP; 3389 dPOPPOPssrl; 3390 I32 start_sp_offset = SP - PL_stack_base; 3391 I32 gimme = GIMME_V; 3392 SV *sv; 3393 STRLEN llen; 3394 STRLEN rlen; 3395 register char *pat = SvPV(left, llen); 3396 register char *s = SvPV(right, rlen); 3397 char *strend = s + rlen; 3398 char *strbeg = s; 3399 register char *patend = pat + llen; 3400 I32 datumtype; 3401 register I32 len; 3402 register I32 bits; 3403 register char *str; 3404 3405 /* These must not be in registers: */ 3406 short ashort; 3407 int aint; 3408 long along; 3409 #ifdef HAS_QUAD 3410 Quad_t aquad; 3411 #endif 3412 U16 aushort; 3413 unsigned int auint; 3414 U32 aulong; 3415 #ifdef HAS_QUAD 3416 Uquad_t auquad; 3417 #endif 3418 char *aptr; 3419 float afloat; 3420 double adouble; 3421 I32 checksum = 0; 3422 register U32 culong; 3423 NV cdouble; 3424 int commas = 0; 3425 int star; 3426 #ifdef PERL_NATINT_PACK 3427 int natint; /* native integer */ 3428 int unatint; /* unsigned native integer */ 3429 #endif 3430 3431 if (gimme != G_ARRAY) { /* arrange to do first one only */ 3432 /*SUPPRESS 530*/ 3433 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; 3434 if (strchr("aAZbBhHP", *patend) || *pat == '%') { 3435 patend++; 3436 while (isDIGIT(*patend) || *patend == '*') 3437 patend++; 3438 } 3439 else 3440 patend++; 3441 } 3442 while (pat < patend) { 3443 reparse: 3444 datumtype = *pat++ & 0xFF; 3445 #ifdef PERL_NATINT_PACK 3446 natint = 0; 3447 #endif 3448 if (isSPACE(datumtype)) 3449 continue; 3450 if (datumtype == '#') { 3451 while (pat < patend && *pat != '\n') 3452 pat++; 3453 continue; 3454 } 3455 if (*pat == '!') { 3456 char *natstr = "sSiIlL"; 3457 3458 if (strchr(natstr, datumtype)) { 3459 #ifdef PERL_NATINT_PACK 3460 natint = 1; 3461 #endif 3462 pat++; 3463 } 3464 else 3465 DIE(aTHX_ "'!' allowed only after types %s", natstr); 3466 } 3467 star = 0; 3468 if (pat >= patend) 3469 len = 1; 3470 else if (*pat == '*') { 3471 len = strend - strbeg; /* long enough */ 3472 pat++; 3473 star = 1; 3474 } 3475 else if (isDIGIT(*pat)) { 3476 len = *pat++ - '0'; 3477 while (isDIGIT(*pat)) { 3478 len = (len * 10) + (*pat++ - '0'); 3479 if (len < 0) 3480 DIE(aTHX_ "Repeat count in unpack overflows"); 3481 } 3482 } 3483 else 3484 len = (datumtype != '@'); 3485 redo_switch: 3486 switch(datumtype) { 3487 default: 3488 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); 3489 case ',': /* grandfather in commas but with a warning */ 3490 if (commas++ == 0 && ckWARN(WARN_UNPACK)) 3491 Perl_warner(aTHX_ WARN_UNPACK, 3492 "Invalid type in unpack: '%c'", (int)datumtype); 3493 break; 3494 case '%': 3495 if (len == 1 && pat[-1] != '1') 3496 len = 16; 3497 checksum = len; 3498 culong = 0; 3499 cdouble = 0; 3500 if (pat < patend) 3501 goto reparse; 3502 break; 3503 case '@': 3504 if (len > strend - strbeg) 3505 DIE(aTHX_ "@ outside of string"); 3506 s = strbeg + len; 3507 break; 3508 case 'X': 3509 if (len > s - strbeg) 3510 DIE(aTHX_ "X outside of string"); 3511 s -= len; 3512 break; 3513 case 'x': 3514 if (len > strend - s) 3515 DIE(aTHX_ "x outside of string"); 3516 s += len; 3517 break; 3518 case '/': 3519 if (start_sp_offset >= SP - PL_stack_base) 3520 DIE(aTHX_ "/ must follow a numeric type"); 3521 datumtype = *pat++; 3522 if (*pat == '*') 3523 pat++; /* ignore '*' for compatibility with pack */ 3524 if (isDIGIT(*pat)) 3525 DIE(aTHX_ "/ cannot take a count" ); 3526 len = POPi; 3527 star = 0; 3528 goto redo_switch; 3529 case 'A': 3530 case 'Z': 3531 case 'a': 3532 if (len > strend - s) 3533 len = strend - s; 3534 if (checksum) 3535 goto uchar_checksum; 3536 sv = NEWSV(35, len); 3537 sv_setpvn(sv, s, len); 3538 s += len; 3539 if (datumtype == 'A' || datumtype == 'Z') { 3540 aptr = s; /* borrow register */ 3541 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ 3542 s = SvPVX(sv); 3543 while (*s) 3544 s++; 3545 } 3546 else { /* 'A' strips both nulls and spaces */ 3547 s = SvPVX(sv) + len - 1; 3548 while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) 3549 s--; 3550 *++s = '\0'; 3551 } 3552 SvCUR_set(sv, s - SvPVX(sv)); 3553 s = aptr; /* unborrow register */ 3554 } 3555 XPUSHs(sv_2mortal(sv)); 3556 break; 3557 case 'B': 3558 case 'b': 3559 if (star || len > (strend - s) * 8) 3560 len = (strend - s) * 8; 3561 if (checksum) { 3562 if (!PL_bitcount) { 3563 Newz(601, PL_bitcount, 256, char); 3564 for (bits = 1; bits < 256; bits++) { 3565 if (bits & 1) PL_bitcount[bits]++; 3566 if (bits & 2) PL_bitcount[bits]++; 3567 if (bits & 4) PL_bitcount[bits]++; 3568 if (bits & 8) PL_bitcount[bits]++; 3569 if (bits & 16) PL_bitcount[bits]++; 3570 if (bits & 32) PL_bitcount[bits]++; 3571 if (bits & 64) PL_bitcount[bits]++; 3572 if (bits & 128) PL_bitcount[bits]++; 3573 } 3574 } 3575 while (len >= 8) { 3576 culong += PL_bitcount[*(unsigned char*)s++]; 3577 len -= 8; 3578 } 3579 if (len) { 3580 bits = *s; 3581 if (datumtype == 'b') { 3582 while (len-- > 0) { 3583 if (bits & 1) culong++; 3584 bits >>= 1; 3585 } 3586 } 3587 else { 3588 while (len-- > 0) { 3589 if (bits & 128) culong++; 3590 bits <<= 1; 3591 } 3592 } 3593 } 3594 break; 3595 } 3596 sv = NEWSV(35, len + 1); 3597 SvCUR_set(sv, len); 3598 SvPOK_on(sv); 3599 str = SvPVX(sv); 3600 if (datumtype == 'b') { 3601 aint = len; 3602 for (len = 0; len < aint; len++) { 3603 if (len & 7) /*SUPPRESS 595*/ 3604 bits >>= 1; 3605 else 3606 bits = *s++; 3607 *str++ = '0' + (bits & 1); 3608 } 3609 } 3610 else { 3611 aint = len; 3612 for (len = 0; len < aint; len++) { 3613 if (len & 7) 3614 bits <<= 1; 3615 else 3616 bits = *s++; 3617 *str++ = '0' + ((bits & 128) != 0); 3618 } 3619 } 3620 *str = '\0'; 3621 XPUSHs(sv_2mortal(sv)); 3622 break; 3623 case 'H': 3624 case 'h': 3625 if (star || len > (strend - s) * 2) 3626 len = (strend - s) * 2; 3627 sv = NEWSV(35, len + 1); 3628 SvCUR_set(sv, len); 3629 SvPOK_on(sv); 3630 str = SvPVX(sv); 3631 if (datumtype == 'h') { 3632 aint = len; 3633 for (len = 0; len < aint; len++) { 3634 if (len & 1) 3635 bits >>= 4; 3636 else 3637 bits = *s++; 3638 *str++ = PL_hexdigit[bits & 15]; 3639 } 3640 } 3641 else { 3642 aint = len; 3643 for (len = 0; len < aint; len++) { 3644 if (len & 1) 3645 bits <<= 4; 3646 else 3647 bits = *s++; 3648 *str++ = PL_hexdigit[(bits >> 4) & 15]; 3649 } 3650 } 3651 *str = '\0'; 3652 XPUSHs(sv_2mortal(sv)); 3653 break; 3654 case 'c': 3655 if (len > strend - s) 3656 len = strend - s; 3657 if (checksum) { 3658 while (len-- > 0) { 3659 aint = *s++; 3660 if (aint >= 128) /* fake up signed chars */ 3661 aint -= 256; 3662 culong += aint; 3663 } 3664 } 3665 else { 3666 EXTEND(SP, len); 3667 EXTEND_MORTAL(len); 3668 while (len-- > 0) { 3669 aint = *s++; 3670 if (aint >= 128) /* fake up signed chars */ 3671 aint -= 256; 3672 sv = NEWSV(36, 0); 3673 sv_setiv(sv, (IV)aint); 3674 PUSHs(sv_2mortal(sv)); 3675 } 3676 } 3677 break; 3678 case 'C': 3679 if (len > strend - s) 3680 len = strend - s; 3681 if (checksum) { 3682 uchar_checksum: 3683 while (len-- > 0) { 3684 auint = *s++ & 255; 3685 culong += auint; 3686 } 3687 } 3688 else { 3689 EXTEND(SP, len); 3690 EXTEND_MORTAL(len); 3691 while (len-- > 0) { 3692 auint = *s++ & 255; 3693 sv = NEWSV(37, 0); 3694 sv_setiv(sv, (IV)auint); 3695 PUSHs(sv_2mortal(sv)); 3696 } 3697 } 3698 break; 3699 case 'U': 3700 if (len > strend - s) 3701 len = strend - s; 3702 if (checksum) { 3703 while (len-- > 0 && s < strend) { 3704 STRLEN alen; 3705 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); 3706 along = alen; 3707 s += along; 3708 if (checksum > 32) 3709 cdouble += (NV)auint; 3710 else 3711 culong += auint; 3712 } 3713 } 3714 else { 3715 EXTEND(SP, len); 3716 EXTEND_MORTAL(len); 3717 while (len-- > 0 && s < strend) { 3718 STRLEN alen; 3719 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0); 3720 along = alen; 3721 s += along; 3722 sv = NEWSV(37, 0); 3723 sv_setuv(sv, (UV)auint); 3724 PUSHs(sv_2mortal(sv)); 3725 } 3726 } 3727 break; 3728 case 's': 3729 #if SHORTSIZE == SIZE16 3730 along = (strend - s) / SIZE16; 3731 #else 3732 along = (strend - s) / (natint ? sizeof(short) : SIZE16); 3733 #endif 3734 if (len > along) 3735 len = along; 3736 if (checksum) { 3737 #if SHORTSIZE != SIZE16 3738 if (natint) { 3739 short ashort; 3740 while (len-- > 0) { 3741 COPYNN(s, &ashort, sizeof(short)); 3742 s += sizeof(short); 3743 culong += ashort; 3744 3745 } 3746 } 3747 else 3748 #endif 3749 { 3750 while (len-- > 0) { 3751 COPY16(s, &ashort); 3752 #if SHORTSIZE > SIZE16 3753 if (ashort > 32767) 3754 ashort -= 65536; 3755 #endif 3756 s += SIZE16; 3757 culong += ashort; 3758 } 3759 } 3760 } 3761 else { 3762 EXTEND(SP, len); 3763 EXTEND_MORTAL(len); 3764 #if SHORTSIZE != SIZE16 3765 if (natint) { 3766 short ashort; 3767 while (len-- > 0) { 3768 COPYNN(s, &ashort, sizeof(short)); 3769 s += sizeof(short); 3770 sv = NEWSV(38, 0); 3771 sv_setiv(sv, (IV)ashort); 3772 PUSHs(sv_2mortal(sv)); 3773 } 3774 } 3775 else 3776 #endif 3777 { 3778 while (len-- > 0) { 3779 COPY16(s, &ashort); 3780 #if SHORTSIZE > SIZE16 3781 if (ashort > 32767) 3782 ashort -= 65536; 3783 #endif 3784 s += SIZE16; 3785 sv = NEWSV(38, 0); 3786 sv_setiv(sv, (IV)ashort); 3787 PUSHs(sv_2mortal(sv)); 3788 } 3789 } 3790 } 3791 break; 3792 case 'v': 3793 case 'n': 3794 case 'S': 3795 #if SHORTSIZE == SIZE16 3796 along = (strend - s) / SIZE16; 3797 #else 3798 unatint = natint && datumtype == 'S'; 3799 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16); 3800 #endif 3801 if (len > along) 3802 len = along; 3803 if (checksum) { 3804 #if SHORTSIZE != SIZE16 3805 if (unatint) { 3806 unsigned short aushort; 3807 while (len-- > 0) { 3808 COPYNN(s, &aushort, sizeof(unsigned short)); 3809 s += sizeof(unsigned short); 3810 culong += aushort; 3811 } 3812 } 3813 else 3814 #endif 3815 { 3816 while (len-- > 0) { 3817 COPY16(s, &aushort); 3818 s += SIZE16; 3819 #ifdef HAS_NTOHS 3820 if (datumtype == 'n') 3821 aushort = PerlSock_ntohs(aushort); 3822 #endif 3823 #ifdef HAS_VTOHS 3824 if (datumtype == 'v') 3825 aushort = vtohs(aushort); 3826 #endif 3827 culong += aushort; 3828 } 3829 } 3830 } 3831 else { 3832 EXTEND(SP, len); 3833 EXTEND_MORTAL(len); 3834 #if SHORTSIZE != SIZE16 3835 if (unatint) { 3836 unsigned short aushort; 3837 while (len-- > 0) { 3838 COPYNN(s, &aushort, sizeof(unsigned short)); 3839 s += sizeof(unsigned short); 3840 sv = NEWSV(39, 0); 3841 sv_setiv(sv, (UV)aushort); 3842 PUSHs(sv_2mortal(sv)); 3843 } 3844 } 3845 else 3846 #endif 3847 { 3848 while (len-- > 0) { 3849 COPY16(s, &aushort); 3850 s += SIZE16; 3851 sv = NEWSV(39, 0); 3852 #ifdef HAS_NTOHS 3853 if (datumtype == 'n') 3854 aushort = PerlSock_ntohs(aushort); 3855 #endif 3856 #ifdef HAS_VTOHS 3857 if (datumtype == 'v') 3858 aushort = vtohs(aushort); 3859 #endif 3860 sv_setiv(sv, (UV)aushort); 3861 PUSHs(sv_2mortal(sv)); 3862 } 3863 } 3864 } 3865 break; 3866 case 'i': 3867 along = (strend - s) / sizeof(int); 3868 if (len > along) 3869 len = along; 3870 if (checksum) { 3871 while (len-- > 0) { 3872 Copy(s, &aint, 1, int); 3873 s += sizeof(int); 3874 if (checksum > 32) 3875 cdouble += (NV)aint; 3876 else 3877 culong += aint; 3878 } 3879 } 3880 else { 3881 EXTEND(SP, len); 3882 EXTEND_MORTAL(len); 3883 while (len-- > 0) { 3884 Copy(s, &aint, 1, int); 3885 s += sizeof(int); 3886 sv = NEWSV(40, 0); 3887 #ifdef __osf__ 3888 /* Without the dummy below unpack("i", pack("i",-1)) 3889 * return 0xFFffFFff instead of -1 for Digital Unix V4.0 3890 * cc with optimization turned on. 3891 * 3892 * The bug was detected in 3893 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E) 3894 * with optimization (-O4) turned on. 3895 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B) 3896 * does not have this problem even with -O4. 3897 * 3898 * This bug was reported as DECC_BUGS 1431 3899 * and tracked internally as GEM_BUGS 7775. 3900 * 3901 * The bug is fixed in 3902 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later 3903 * UNIX V4.0F support: DEC C V5.9-006 or later 3904 * UNIX V4.0E support: DEC C V5.8-011 or later 3905 * and also in DTK. 3906 * 3907 * See also few lines later for the same bug. 3908 */ 3909 (aint) ? 3910 sv_setiv(sv, (IV)aint) : 3911 #endif 3912 sv_setiv(sv, (IV)aint); 3913 PUSHs(sv_2mortal(sv)); 3914 } 3915 } 3916 break; 3917 case 'I': 3918 along = (strend - s) / sizeof(unsigned int); 3919 if (len > along) 3920 len = along; 3921 if (checksum) { 3922 while (len-- > 0) { 3923 Copy(s, &auint, 1, unsigned int); 3924 s += sizeof(unsigned int); 3925 if (checksum > 32) 3926 cdouble += (NV)auint; 3927 else 3928 culong += auint; 3929 } 3930 } 3931 else { 3932 EXTEND(SP, len); 3933 EXTEND_MORTAL(len); 3934 while (len-- > 0) { 3935 Copy(s, &auint, 1, unsigned int); 3936 s += sizeof(unsigned int); 3937 sv = NEWSV(41, 0); 3938 #ifdef __osf__ 3939 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) 3940 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF. 3941 * See details few lines earlier. */ 3942 (auint) ? 3943 sv_setuv(sv, (UV)auint) : 3944 #endif 3945 sv_setuv(sv, (UV)auint); 3946 PUSHs(sv_2mortal(sv)); 3947 } 3948 } 3949 break; 3950 case 'l': 3951 #if LONGSIZE == SIZE32 3952 along = (strend - s) / SIZE32; 3953 #else 3954 along = (strend - s) / (natint ? sizeof(long) : SIZE32); 3955 #endif 3956 if (len > along) 3957 len = along; 3958 if (checksum) { 3959 #if LONGSIZE != SIZE32 3960 if (natint) { 3961 while (len-- > 0) { 3962 COPYNN(s, &along, sizeof(long)); 3963 s += sizeof(long); 3964 if (checksum > 32) 3965 cdouble += (NV)along; 3966 else 3967 culong += along; 3968 } 3969 } 3970 else 3971 #endif 3972 { 3973 while (len-- > 0) { 3974 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32 3975 I32 along; 3976 #endif 3977 COPY32(s, &along); 3978 #if LONGSIZE > SIZE32 3979 if (along > 2147483647) 3980 along -= 4294967296; 3981 #endif 3982 s += SIZE32; 3983 if (checksum > 32) 3984 cdouble += (NV)along; 3985 else 3986 culong += along; 3987 } 3988 } 3989 } 3990 else { 3991 EXTEND(SP, len); 3992 EXTEND_MORTAL(len); 3993 #if LONGSIZE != SIZE32 3994 if (natint) { 3995 while (len-- > 0) { 3996 COPYNN(s, &along, sizeof(long)); 3997 s += sizeof(long); 3998 sv = NEWSV(42, 0); 3999 sv_setiv(sv, (IV)along); 4000 PUSHs(sv_2mortal(sv)); 4001 } 4002 } 4003 else 4004 #endif 4005 { 4006 while (len-- > 0) { 4007 #if LONGSIZE > SIZE32 && INTSIZE == SIZE32 4008 I32 along; 4009 #endif 4010 COPY32(s, &along); 4011 #if LONGSIZE > SIZE32 4012 if (along > 2147483647) 4013 along -= 4294967296; 4014 #endif 4015 s += SIZE32; 4016 sv = NEWSV(42, 0); 4017 sv_setiv(sv, (IV)along); 4018 PUSHs(sv_2mortal(sv)); 4019 } 4020 } 4021 } 4022 break; 4023 case 'V': 4024 case 'N': 4025 case 'L': 4026 #if LONGSIZE == SIZE32 4027 along = (strend - s) / SIZE32; 4028 #else 4029 unatint = natint && datumtype == 'L'; 4030 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32); 4031 #endif 4032 if (len > along) 4033 len = along; 4034 if (checksum) { 4035 #if LONGSIZE != SIZE32 4036 if (unatint) { 4037 unsigned long aulong; 4038 while (len-- > 0) { 4039 COPYNN(s, &aulong, sizeof(unsigned long)); 4040 s += sizeof(unsigned long); 4041 if (checksum > 32) 4042 cdouble += (NV)aulong; 4043 else 4044 culong += aulong; 4045 } 4046 } 4047 else 4048 #endif 4049 { 4050 while (len-- > 0) { 4051 COPY32(s, &aulong); 4052 s += SIZE32; 4053 #ifdef HAS_NTOHL 4054 if (datumtype == 'N') 4055 aulong = PerlSock_ntohl(aulong); 4056 #endif 4057 #ifdef HAS_VTOHL 4058 if (datumtype == 'V') 4059 aulong = vtohl(aulong); 4060 #endif 4061 if (checksum > 32) 4062 cdouble += (NV)aulong; 4063 else 4064 culong += aulong; 4065 } 4066 } 4067 } 4068 else { 4069 EXTEND(SP, len); 4070 EXTEND_MORTAL(len); 4071 #if LONGSIZE != SIZE32 4072 if (unatint) { 4073 unsigned long aulong; 4074 while (len-- > 0) { 4075 COPYNN(s, &aulong, sizeof(unsigned long)); 4076 s += sizeof(unsigned long); 4077 sv = NEWSV(43, 0); 4078 sv_setuv(sv, (UV)aulong); 4079 PUSHs(sv_2mortal(sv)); 4080 } 4081 } 4082 else 4083 #endif 4084 { 4085 while (len-- > 0) { 4086 COPY32(s, &aulong); 4087 s += SIZE32; 4088 #ifdef HAS_NTOHL 4089 if (datumtype == 'N') 4090 aulong = PerlSock_ntohl(aulong); 4091 #endif 4092 #ifdef HAS_VTOHL 4093 if (datumtype == 'V') 4094 aulong = vtohl(aulong); 4095 #endif 4096 sv = NEWSV(43, 0); 4097 sv_setuv(sv, (UV)aulong); 4098 PUSHs(sv_2mortal(sv)); 4099 } 4100 } 4101 } 4102 break; 4103 case 'p': 4104 along = (strend - s) / sizeof(char*); 4105 if (len > along) 4106 len = along; 4107 EXTEND(SP, len); 4108 EXTEND_MORTAL(len); 4109 while (len-- > 0) { 4110 if (sizeof(char*) > strend - s) 4111 break; 4112 else { 4113 Copy(s, &aptr, 1, char*); 4114 s += sizeof(char*); 4115 } 4116 sv = NEWSV(44, 0); 4117 if (aptr) 4118 sv_setpv(sv, aptr); 4119 PUSHs(sv_2mortal(sv)); 4120 } 4121 break; 4122 case 'w': 4123 EXTEND(SP, len); 4124 EXTEND_MORTAL(len); 4125 { 4126 UV auv = 0; 4127 U32 bytes = 0; 4128 4129 while ((len > 0) && (s < strend)) { 4130 auv = (auv << 7) | (*s & 0x7f); 4131 if (UTF8_IS_ASCII(*s++)) { 4132 bytes = 0; 4133 sv = NEWSV(40, 0); 4134 sv_setuv(sv, auv); 4135 PUSHs(sv_2mortal(sv)); 4136 len--; 4137 auv = 0; 4138 } 4139 else if (++bytes >= sizeof(UV)) { /* promote to string */ 4140 char *t; 4141 STRLEN n_a; 4142 4143 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); 4144 while (s < strend) { 4145 sv = mul128(sv, *s & 0x7f); 4146 if (!(*s++ & 0x80)) { 4147 bytes = 0; 4148 break; 4149 } 4150 } 4151 t = SvPV(sv, n_a); 4152 while (*t == '0') 4153 t++; 4154 sv_chop(sv, t); 4155 PUSHs(sv_2mortal(sv)); 4156 len--; 4157 auv = 0; 4158 } 4159 } 4160 if ((s >= strend) && bytes) 4161 DIE(aTHX_ "Unterminated compressed integer"); 4162 } 4163 break; 4164 case 'P': 4165 EXTEND(SP, 1); 4166 if (sizeof(char*) > strend - s) 4167 break; 4168 else { 4169 Copy(s, &aptr, 1, char*); 4170 s += sizeof(char*); 4171 } 4172 sv = NEWSV(44, 0); 4173 if (aptr) 4174 sv_setpvn(sv, aptr, len); 4175 PUSHs(sv_2mortal(sv)); 4176 break; 4177 #ifdef HAS_QUAD 4178 case 'q': 4179 along = (strend - s) / sizeof(Quad_t); 4180 if (len > along) 4181 len = along; 4182 EXTEND(SP, len); 4183 EXTEND_MORTAL(len); 4184 while (len-- > 0) { 4185 if (s + sizeof(Quad_t) > strend) 4186 aquad = 0; 4187 else { 4188 Copy(s, &aquad, 1, Quad_t); 4189 s += sizeof(Quad_t); 4190 } 4191 sv = NEWSV(42, 0); 4192 if (aquad >= IV_MIN && aquad <= IV_MAX) 4193 sv_setiv(sv, (IV)aquad); 4194 else 4195 sv_setnv(sv, (NV)aquad); 4196 PUSHs(sv_2mortal(sv)); 4197 } 4198 break; 4199 case 'Q': 4200 along = (strend - s) / sizeof(Quad_t); 4201 if (len > along) 4202 len = along; 4203 EXTEND(SP, len); 4204 EXTEND_MORTAL(len); 4205 while (len-- > 0) { 4206 if (s + sizeof(Uquad_t) > strend) 4207 auquad = 0; 4208 else { 4209 Copy(s, &auquad, 1, Uquad_t); 4210 s += sizeof(Uquad_t); 4211 } 4212 sv = NEWSV(43, 0); 4213 if (auquad <= UV_MAX) 4214 sv_setuv(sv, (UV)auquad); 4215 else 4216 sv_setnv(sv, (NV)auquad); 4217 PUSHs(sv_2mortal(sv)); 4218 } 4219 break; 4220 #endif 4221 /* float and double added gnb@melba.bby.oz.au 22/11/89 */ 4222 case 'f': 4223 case 'F': 4224 along = (strend - s) / sizeof(float); 4225 if (len > along) 4226 len = along; 4227 if (checksum) { 4228 while (len-- > 0) { 4229 Copy(s, &afloat, 1, float); 4230 s += sizeof(float); 4231 cdouble += afloat; 4232 } 4233 } 4234 else { 4235 EXTEND(SP, len); 4236 EXTEND_MORTAL(len); 4237 while (len-- > 0) { 4238 Copy(s, &afloat, 1, float); 4239 s += sizeof(float); 4240 sv = NEWSV(47, 0); 4241 sv_setnv(sv, (NV)afloat); 4242 PUSHs(sv_2mortal(sv)); 4243 } 4244 } 4245 break; 4246 case 'd': 4247 case 'D': 4248 along = (strend - s) / sizeof(double); 4249 if (len > along) 4250 len = along; 4251 if (checksum) { 4252 while (len-- > 0) { 4253 Copy(s, &adouble, 1, double); 4254 s += sizeof(double); 4255 cdouble += adouble; 4256 } 4257 } 4258 else { 4259 EXTEND(SP, len); 4260 EXTEND_MORTAL(len); 4261 while (len-- > 0) { 4262 Copy(s, &adouble, 1, double); 4263 s += sizeof(double); 4264 sv = NEWSV(48, 0); 4265 sv_setnv(sv, (NV)adouble); 4266 PUSHs(sv_2mortal(sv)); 4267 } 4268 } 4269 break; 4270 case 'u': 4271 /* MKS: 4272 * Initialise the decode mapping. By using a table driven 4273 * algorithm, the code will be character-set independent 4274 * (and just as fast as doing character arithmetic) 4275 */ 4276 if (PL_uudmap['M'] == 0) { 4277 int i; 4278 4279 for (i = 0; i < sizeof(PL_uuemap); i += 1) 4280 PL_uudmap[(U8)PL_uuemap[i]] = i; 4281 /* 4282 * Because ' ' and '`' map to the same value, 4283 * we need to decode them both the same. 4284 */ 4285 PL_uudmap[' '] = 0; 4286 } 4287 4288 along = (strend - s) * 3 / 4; 4289 sv = NEWSV(42, along); 4290 if (along) 4291 SvPOK_on(sv); 4292 while (s < strend && *s > ' ' && ISUUCHAR(*s)) { 4293 I32 a, b, c, d; 4294 char hunk[4]; 4295 4296 hunk[3] = '\0'; 4297 len = PL_uudmap[*(U8*)s++] & 077; 4298 while (len > 0) { 4299 if (s < strend && ISUUCHAR(*s)) 4300 a = PL_uudmap[*(U8*)s++] & 077; 4301 else 4302 a = 0; 4303 if (s < strend && ISUUCHAR(*s)) 4304 b = PL_uudmap[*(U8*)s++] & 077; 4305 else 4306 b = 0; 4307 if (s < strend && ISUUCHAR(*s)) 4308 c = PL_uudmap[*(U8*)s++] & 077; 4309 else 4310 c = 0; 4311 if (s < strend && ISUUCHAR(*s)) 4312 d = PL_uudmap[*(U8*)s++] & 077; 4313 else 4314 d = 0; 4315 hunk[0] = (a << 2) | (b >> 4); 4316 hunk[1] = (b << 4) | (c >> 2); 4317 hunk[2] = (c << 6) | d; 4318 sv_catpvn(sv, hunk, (len > 3) ? 3 : len); 4319 len -= 3; 4320 } 4321 if (*s == '\n') 4322 s++; 4323 else if (s[1] == '\n') /* possible checksum byte */ 4324 s += 2; 4325 } 4326 XPUSHs(sv_2mortal(sv)); 4327 break; 4328 } 4329 if (checksum) { 4330 sv = NEWSV(42, 0); 4331 if (strchr("fFdD", datumtype) || 4332 (checksum > 32 && strchr("iIlLNU", datumtype)) ) { 4333 NV trouble; 4334 4335 adouble = 1.0; 4336 while (checksum >= 16) { 4337 checksum -= 16; 4338 adouble *= 65536.0; 4339 } 4340 while (checksum >= 4) { 4341 checksum -= 4; 4342 adouble *= 16.0; 4343 } 4344 while (checksum--) 4345 adouble *= 2.0; 4346 along = (1 << checksum) - 1; 4347 while (cdouble < 0.0) 4348 cdouble += adouble; 4349 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; 4350 sv_setnv(sv, cdouble); 4351 } 4352 else { 4353 if (checksum < 32) { 4354 aulong = (1 << checksum) - 1; 4355 culong &= aulong; 4356 } 4357 sv_setuv(sv, (UV)culong); 4358 } 4359 XPUSHs(sv_2mortal(sv)); 4360 checksum = 0; 4361 } 4362 } 4363 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) 4364 PUSHs(&PL_sv_undef); 4365 RETURN; 4366 } 4367 4368 STATIC void 4369 S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) 4370 { 4371 char hunk[5]; 4372 4373 *hunk = PL_uuemap[len]; 4374 sv_catpvn(sv, hunk, 1); 4375 hunk[4] = '\0'; 4376 while (len > 2) { 4377 hunk[0] = PL_uuemap[(077 & (*s >> 2))]; 4378 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; 4379 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; 4380 hunk[3] = PL_uuemap[(077 & (s[2] & 077))]; 4381 sv_catpvn(sv, hunk, 4); 4382 s += 3; 4383 len -= 3; 4384 } 4385 if (len > 0) { 4386 char r = (len > 1 ? s[1] : '\0'); 4387 hunk[0] = PL_uuemap[(077 & (*s >> 2))]; 4388 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; 4389 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))]; 4390 hunk[3] = PL_uuemap[0]; 4391 sv_catpvn(sv, hunk, 4); 4392 } 4393 sv_catpvn(sv, "\n", 1); 4394 } 4395 4396 STATIC SV * 4397 S_is_an_int(pTHX_ char *s, STRLEN l) 4398 { 4399 STRLEN n_a; 4400 SV *result = newSVpvn(s, l); 4401 char *result_c = SvPV(result, n_a); /* convenience */ 4402 char *out = result_c; 4403 bool skip = 1; 4404 bool ignore = 0; 4405 4406 while (*s) { 4407 switch (*s) { 4408 case ' ': 4409 break; 4410 case '+': 4411 if (!skip) { 4412 SvREFCNT_dec(result); 4413 return (NULL); 4414 } 4415 break; 4416 case '0': 4417 case '1': 4418 case '2': 4419 case '3': 4420 case '4': 4421 case '5': 4422 case '6': 4423 case '7': 4424 case '8': 4425 case '9': 4426 skip = 0; 4427 if (!ignore) { 4428 *(out++) = *s; 4429 } 4430 break; 4431 case '.': 4432 ignore = 1; 4433 break; 4434 default: 4435 SvREFCNT_dec(result); 4436 return (NULL); 4437 } 4438 s++; 4439 } 4440 *(out++) = '\0'; 4441 SvCUR_set(result, out - result_c); 4442 return (result); 4443 } 4444 4445 /* pnum must be '\0' terminated */ 4446 STATIC int 4447 S_div128(pTHX_ SV *pnum, bool *done) 4448 { 4449 STRLEN len; 4450 char *s = SvPV(pnum, len); 4451 int m = 0; 4452 int r = 0; 4453 char *t = s; 4454 4455 *done = 1; 4456 while (*t) { 4457 int i; 4458 4459 i = m * 10 + (*t - '0'); 4460 m = i & 0x7F; 4461 r = (i >> 7); /* r < 10 */ 4462 if (r) { 4463 *done = 0; 4464 } 4465 *(t++) = '0' + r; 4466 } 4467 *(t++) = '\0'; 4468 SvCUR_set(pnum, (STRLEN) (t - s)); 4469 return (m); 4470 } 4471 4472 4473 PP(pp_pack) 4474 { 4475 dSP; dMARK; dORIGMARK; dTARGET; 4476 register SV *cat = TARG; 4477 register I32 items; 4478 STRLEN fromlen; 4479 register char *pat = SvPVx(*++MARK, fromlen); 4480 char *patcopy; 4481 register char *patend = pat + fromlen; 4482 register I32 len; 4483 I32 datumtype; 4484 SV *fromstr; 4485 /*SUPPRESS 442*/ 4486 static char null10[] = {0,0,0,0,0,0,0,0,0,0}; 4487 static char *space10 = " "; 4488 4489 /* These must not be in registers: */ 4490 char achar; 4491 I16 ashort; 4492 int aint; 4493 unsigned int auint; 4494 I32 along; 4495 U32 aulong; 4496 #ifdef HAS_QUAD 4497 Quad_t aquad; 4498 Uquad_t auquad; 4499 #endif 4500 char *aptr; 4501 float afloat; 4502 double adouble; 4503 int commas = 0; 4504 #ifdef PERL_NATINT_PACK 4505 int natint; /* native integer */ 4506 #endif 4507 4508 items = SP - MARK; 4509 MARK++; 4510 sv_setpvn(cat, "", 0); 4511 patcopy = pat; 4512 while (pat < patend) { 4513 SV *lengthcode = Nullsv; 4514 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no) 4515 datumtype = *pat++ & 0xFF; 4516 #ifdef PERL_NATINT_PACK 4517 natint = 0; 4518 #endif 4519 if (isSPACE(datumtype)) { 4520 patcopy++; 4521 continue; 4522 } 4523 if (datumtype == 'U' && pat == patcopy+1) 4524 SvUTF8_on(cat); 4525 if (datumtype == '#') { 4526 while (pat < patend && *pat != '\n') 4527 pat++; 4528 continue; 4529 } 4530 if (*pat == '!') { 4531 char *natstr = "sSiIlL"; 4532 4533 if (strchr(natstr, datumtype)) { 4534 #ifdef PERL_NATINT_PACK 4535 natint = 1; 4536 #endif 4537 pat++; 4538 } 4539 else 4540 DIE(aTHX_ "'!' allowed only after types %s", natstr); 4541 } 4542 if (*pat == '*') { 4543 len = strchr("@Xxu", datumtype) ? 0 : items; 4544 pat++; 4545 } 4546 else if (isDIGIT(*pat)) { 4547 len = *pat++ - '0'; 4548 while (isDIGIT(*pat)) { 4549 len = (len * 10) + (*pat++ - '0'); 4550 if (len < 0) 4551 DIE(aTHX_ "Repeat count in pack overflows"); 4552 } 4553 } 4554 else 4555 len = 1; 4556 if (*pat == '/') { 4557 ++pat; 4558 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*') 4559 DIE(aTHX_ "/ must be followed by a*, A* or Z*"); 4560 lengthcode = sv_2mortal(newSViv(sv_len(items > 0 4561 ? *MARK : &PL_sv_no) 4562 + (*pat == 'Z' ? 1 : 0))); 4563 } 4564 switch(datumtype) { 4565 default: 4566 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); 4567 case ',': /* grandfather in commas but with a warning */ 4568 if (commas++ == 0 && ckWARN(WARN_PACK)) 4569 Perl_warner(aTHX_ WARN_PACK, 4570 "Invalid type in pack: '%c'", (int)datumtype); 4571 break; 4572 case '%': 4573 DIE(aTHX_ "%% may only be used in unpack"); 4574 case '@': 4575 len -= SvCUR(cat); 4576 if (len > 0) 4577 goto grow; 4578 len = -len; 4579 if (len > 0) 4580 goto shrink; 4581 break; 4582 case 'X': 4583 shrink: 4584 if (SvCUR(cat) < len) 4585 DIE(aTHX_ "X outside of string"); 4586 SvCUR(cat) -= len; 4587 *SvEND(cat) = '\0'; 4588 break; 4589 case 'x': 4590 grow: 4591 while (len >= 10) { 4592 sv_catpvn(cat, null10, 10); 4593 len -= 10; 4594 } 4595 sv_catpvn(cat, null10, len); 4596 break; 4597 case 'A': 4598 case 'Z': 4599 case 'a': 4600 fromstr = NEXTFROM; 4601 aptr = SvPV(fromstr, fromlen); 4602 if (pat[-1] == '*') { 4603 len = fromlen; 4604 if (datumtype == 'Z') 4605 ++len; 4606 } 4607 if (fromlen >= len) { 4608 sv_catpvn(cat, aptr, len); 4609 if (datumtype == 'Z') 4610 *(SvEND(cat)-1) = '\0'; 4611 } 4612 else { 4613 sv_catpvn(cat, aptr, fromlen); 4614 len -= fromlen; 4615 if (datumtype == 'A') { 4616 while (len >= 10) { 4617 sv_catpvn(cat, space10, 10); 4618 len -= 10; 4619 } 4620 sv_catpvn(cat, space10, len); 4621 } 4622 else { 4623 while (len >= 10) { 4624 sv_catpvn(cat, null10, 10); 4625 len -= 10; 4626 } 4627 sv_catpvn(cat, null10, len); 4628 } 4629 } 4630 break; 4631 case 'B': 4632 case 'b': 4633 { 4634 register char *str; 4635 I32 saveitems; 4636 4637 fromstr = NEXTFROM; 4638 saveitems = items; 4639 str = SvPV(fromstr, fromlen); 4640 if (pat[-1] == '*') 4641 len = fromlen; 4642 aint = SvCUR(cat); 4643 SvCUR(cat) += (len+7)/8; 4644 SvGROW(cat, SvCUR(cat) + 1); 4645 aptr = SvPVX(cat) + aint; 4646 if (len > fromlen) 4647 len = fromlen; 4648 aint = len; 4649 items = 0; 4650 if (datumtype == 'B') { 4651 for (len = 0; len++ < aint;) { 4652 items |= *str++ & 1; 4653 if (len & 7) 4654 items <<= 1; 4655 else { 4656 *aptr++ = items & 0xff; 4657 items = 0; 4658 } 4659 } 4660 } 4661 else { 4662 for (len = 0; len++ < aint;) { 4663 if (*str++ & 1) 4664 items |= 128; 4665 if (len & 7) 4666 items >>= 1; 4667 else { 4668 *aptr++ = items & 0xff; 4669 items = 0; 4670 } 4671 } 4672 } 4673 if (aint & 7) { 4674 if (datumtype == 'B') 4675 items <<= 7 - (aint & 7); 4676 else 4677 items >>= 7 - (aint & 7); 4678 *aptr++ = items & 0xff; 4679 } 4680 str = SvPVX(cat) + SvCUR(cat); 4681 while (aptr <= str) 4682 *aptr++ = '\0'; 4683 4684 items = saveitems; 4685 } 4686 break; 4687 case 'H': 4688 case 'h': 4689 { 4690 register char *str; 4691 I32 saveitems; 4692 4693 fromstr = NEXTFROM; 4694 saveitems = items; 4695 str = SvPV(fromstr, fromlen); 4696 if (pat[-1] == '*') 4697 len = fromlen; 4698 aint = SvCUR(cat); 4699 SvCUR(cat) += (len+1)/2; 4700 SvGROW(cat, SvCUR(cat) + 1); 4701 aptr = SvPVX(cat) + aint; 4702 if (len > fromlen) 4703 len = fromlen; 4704 aint = len; 4705 items = 0; 4706 if (datumtype == 'H') { 4707 for (len = 0; len++ < aint;) { 4708 if (isALPHA(*str)) 4709 items |= ((*str++ & 15) + 9) & 15; 4710 else 4711 items |= *str++ & 15; 4712 if (len & 1) 4713 items <<= 4; 4714 else { 4715 *aptr++ = items & 0xff; 4716 items = 0; 4717 } 4718 } 4719 } 4720 else { 4721 for (len = 0; len++ < aint;) { 4722 if (isALPHA(*str)) 4723 items |= (((*str++ & 15) + 9) & 15) << 4; 4724 else 4725 items |= (*str++ & 15) << 4; 4726 if (len & 1) 4727 items >>= 4; 4728 else { 4729 *aptr++ = items & 0xff; 4730 items = 0; 4731 } 4732 } 4733 } 4734 if (aint & 1) 4735 *aptr++ = items & 0xff; 4736 str = SvPVX(cat) + SvCUR(cat); 4737 while (aptr <= str) 4738 *aptr++ = '\0'; 4739 4740 items = saveitems; 4741 } 4742 break; 4743 case 'C': 4744 case 'c': 4745 while (len-- > 0) { 4746 fromstr = NEXTFROM; 4747 aint = SvIV(fromstr); 4748 achar = aint; 4749 sv_catpvn(cat, &achar, sizeof(char)); 4750 } 4751 break; 4752 case 'U': 4753 while (len-- > 0) { 4754 fromstr = NEXTFROM; 4755 auint = SvUV(fromstr); 4756 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); 4757 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint) 4758 - SvPVX(cat)); 4759 } 4760 *SvEND(cat) = '\0'; 4761 break; 4762 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ 4763 case 'f': 4764 case 'F': 4765 while (len-- > 0) { 4766 fromstr = NEXTFROM; 4767 afloat = (float)SvNV(fromstr); 4768 sv_catpvn(cat, (char *)&afloat, sizeof (float)); 4769 } 4770 break; 4771 case 'd': 4772 case 'D': 4773 while (len-- > 0) { 4774 fromstr = NEXTFROM; 4775 adouble = (double)SvNV(fromstr); 4776 sv_catpvn(cat, (char *)&adouble, sizeof (double)); 4777 } 4778 break; 4779 case 'n': 4780 while (len-- > 0) { 4781 fromstr = NEXTFROM; 4782 ashort = (I16)SvIV(fromstr); 4783 #ifdef HAS_HTONS 4784 ashort = PerlSock_htons(ashort); 4785 #endif 4786 CAT16(cat, &ashort); 4787 } 4788 break; 4789 case 'v': 4790 while (len-- > 0) { 4791 fromstr = NEXTFROM; 4792 ashort = (I16)SvIV(fromstr); 4793 #ifdef HAS_HTOVS 4794 ashort = htovs(ashort); 4795 #endif 4796 CAT16(cat, &ashort); 4797 } 4798 break; 4799 case 'S': 4800 #if SHORTSIZE != SIZE16 4801 if (natint) { 4802 unsigned short aushort; 4803 4804 while (len-- > 0) { 4805 fromstr = NEXTFROM; 4806 aushort = SvUV(fromstr); 4807 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); 4808 } 4809 } 4810 else 4811 #endif 4812 { 4813 U16 aushort; 4814 4815 while (len-- > 0) { 4816 fromstr = NEXTFROM; 4817 aushort = (U16)SvUV(fromstr); 4818 CAT16(cat, &aushort); 4819 } 4820 4821 } 4822 break; 4823 case 's': 4824 #if SHORTSIZE != SIZE16 4825 if (natint) { 4826 short ashort; 4827 4828 while (len-- > 0) { 4829 fromstr = NEXTFROM; 4830 ashort = SvIV(fromstr); 4831 sv_catpvn(cat, (char *)&ashort, sizeof(short)); 4832 } 4833 } 4834 else 4835 #endif 4836 { 4837 while (len-- > 0) { 4838 fromstr = NEXTFROM; 4839 ashort = (I16)SvIV(fromstr); 4840 CAT16(cat, &ashort); 4841 } 4842 } 4843 break; 4844 case 'I': 4845 while (len-- > 0) { 4846 fromstr = NEXTFROM; 4847 auint = SvUV(fromstr); 4848 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); 4849 } 4850 break; 4851 case 'w': 4852 while (len-- > 0) { 4853 fromstr = NEXTFROM; 4854 adouble = Perl_floor(SvNV(fromstr)); 4855 4856 if (adouble < 0) 4857 DIE(aTHX_ "Cannot compress negative numbers"); 4858 4859 if ( 4860 #if UVSIZE > 4 && UVSIZE >= NVSIZE 4861 adouble <= 0xffffffff 4862 #else 4863 # ifdef CXUX_BROKEN_CONSTANT_CONVERT 4864 adouble <= UV_MAX_cxux 4865 # else 4866 adouble <= UV_MAX 4867 # endif 4868 #endif 4869 ) 4870 { 4871 char buf[1 + sizeof(UV)]; 4872 char *in = buf + sizeof(buf); 4873 UV auv = U_V(adouble); 4874 4875 do { 4876 *--in = (auv & 0x7f) | 0x80; 4877 auv >>= 7; 4878 } while (auv); 4879 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ 4880 sv_catpvn(cat, in, (buf + sizeof(buf)) - in); 4881 } 4882 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ 4883 char *from, *result, *in; 4884 SV *norm; 4885 STRLEN len; 4886 bool done; 4887 4888 /* Copy string and check for compliance */ 4889 from = SvPV(fromstr, len); 4890 if ((norm = is_an_int(from, len)) == NULL) 4891 DIE(aTHX_ "can compress only unsigned integer"); 4892 4893 New('w', result, len, char); 4894 in = result + len; 4895 done = FALSE; 4896 while (!done) 4897 *--in = div128(norm, &done) | 0x80; 4898 result[len - 1] &= 0x7F; /* clear continue bit */ 4899 sv_catpvn(cat, in, (result + len) - in); 4900 Safefree(result); 4901 SvREFCNT_dec(norm); /* free norm */ 4902 } 4903 else if (SvNOKp(fromstr)) { 4904 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ 4905 char *in = buf + sizeof(buf); 4906 4907 do { 4908 double next = floor(adouble / 128); 4909 *--in = (unsigned char)(adouble - (next * 128)) | 0x80; 4910 if (in <= buf) /* this cannot happen ;-) */ 4911 DIE(aTHX_ "Cannot compress integer"); 4912 in--; 4913 adouble = next; 4914 } while (adouble > 0); 4915 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ 4916 sv_catpvn(cat, in, (buf + sizeof(buf)) - in); 4917 } 4918 else 4919 DIE(aTHX_ "Cannot compress non integer"); 4920 } 4921 break; 4922 case 'i': 4923 while (len-- > 0) { 4924 fromstr = NEXTFROM; 4925 aint = SvIV(fromstr); 4926 sv_catpvn(cat, (char*)&aint, sizeof(int)); 4927 } 4928 break; 4929 case 'N': 4930 while (len-- > 0) { 4931 fromstr = NEXTFROM; 4932 aulong = SvUV(fromstr); 4933 #ifdef HAS_HTONL 4934 aulong = PerlSock_htonl(aulong); 4935 #endif 4936 CAT32(cat, &aulong); 4937 } 4938 break; 4939 case 'V': 4940 while (len-- > 0) { 4941 fromstr = NEXTFROM; 4942 aulong = SvUV(fromstr); 4943 #ifdef HAS_HTOVL 4944 aulong = htovl(aulong); 4945 #endif 4946 CAT32(cat, &aulong); 4947 } 4948 break; 4949 case 'L': 4950 #if LONGSIZE != SIZE32 4951 if (natint) { 4952 unsigned long aulong; 4953 4954 while (len-- > 0) { 4955 fromstr = NEXTFROM; 4956 aulong = SvUV(fromstr); 4957 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); 4958 } 4959 } 4960 else 4961 #endif 4962 { 4963 while (len-- > 0) { 4964 fromstr = NEXTFROM; 4965 aulong = SvUV(fromstr); 4966 CAT32(cat, &aulong); 4967 } 4968 } 4969 break; 4970 case 'l': 4971 #if LONGSIZE != SIZE32 4972 if (natint) { 4973 long along; 4974 4975 while (len-- > 0) { 4976 fromstr = NEXTFROM; 4977 along = SvIV(fromstr); 4978 sv_catpvn(cat, (char *)&along, sizeof(long)); 4979 } 4980 } 4981 else 4982 #endif 4983 { 4984 while (len-- > 0) { 4985 fromstr = NEXTFROM; 4986 along = SvIV(fromstr); 4987 CAT32(cat, &along); 4988 } 4989 } 4990 break; 4991 #ifdef HAS_QUAD 4992 case 'Q': 4993 while (len-- > 0) { 4994 fromstr = NEXTFROM; 4995 auquad = (Uquad_t)SvUV(fromstr); 4996 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); 4997 } 4998 break; 4999 case 'q': 5000 while (len-- > 0) { 5001 fromstr = NEXTFROM; 5002 aquad = (Quad_t)SvIV(fromstr); 5003 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); 5004 } 5005 break; 5006 #endif 5007 case 'P': 5008 len = 1; /* assume SV is correct length */ 5009 /* FALL THROUGH */ 5010 case 'p': 5011 while (len-- > 0) { 5012 fromstr = NEXTFROM; 5013 if (fromstr == &PL_sv_undef) 5014 aptr = NULL; 5015 else { 5016 STRLEN n_a; 5017 /* XXX better yet, could spirit away the string to 5018 * a safe spot and hang on to it until the result 5019 * of pack() (and all copies of the result) are 5020 * gone. 5021 */ 5022 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) 5023 || (SvPADTMP(fromstr) 5024 && !SvREADONLY(fromstr)))) 5025 { 5026 Perl_warner(aTHX_ WARN_PACK, 5027 "Attempt to pack pointer to temporary value"); 5028 } 5029 if (SvPOK(fromstr) || SvNIOK(fromstr)) 5030 aptr = SvPV(fromstr,n_a); 5031 else 5032 aptr = SvPV_force(fromstr,n_a); 5033 } 5034 sv_catpvn(cat, (char*)&aptr, sizeof(char*)); 5035 } 5036 break; 5037 case 'u': 5038 fromstr = NEXTFROM; 5039 aptr = SvPV(fromstr, fromlen); 5040 SvGROW(cat, fromlen * 4 / 3); 5041 if (len <= 1) 5042 len = 45; 5043 else 5044 len = len / 3 * 3; 5045 while (fromlen > 0) { 5046 I32 todo; 5047 5048 if (fromlen > len) 5049 todo = len; 5050 else 5051 todo = fromlen; 5052 doencodes(cat, aptr, todo); 5053 fromlen -= todo; 5054 aptr += todo; 5055 } 5056 break; 5057 } 5058 } 5059 SvSETMAGIC(cat); 5060 SP = ORIGMARK; 5061 PUSHs(cat); 5062 RETURN; 5063 } 5064 #undef NEXTFROM 5065 5066 5067 PP(pp_split) 5068 { 5069 dSP; dTARG; 5070 AV *ary; 5071 register IV limit = POPi; /* note, negative is forever */ 5072 SV *sv = POPs; 5073 STRLEN len; 5074 register char *s = SvPV(sv, len); 5075 bool do_utf8 = DO_UTF8(sv); 5076 char *strend = s + len; 5077 register PMOP *pm; 5078 register REGEXP *rx; 5079 register SV *dstr; 5080 register char *m; 5081 I32 iters = 0; 5082 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s); 5083 I32 maxiters = slen + 10; 5084 I32 i; 5085 char *orig; 5086 I32 origlimit = limit; 5087 I32 realarray = 0; 5088 I32 base; 5089 AV *oldstack = PL_curstack; 5090 I32 gimme = GIMME_V; 5091 I32 oldsave = PL_savestack_ix; 5092 I32 make_mortal = 1; 5093 MAGIC *mg = (MAGIC *) NULL; 5094 5095 #ifdef DEBUGGING 5096 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); 5097 #else 5098 pm = (PMOP*)POPs; 5099 #endif 5100 if (!pm || !s) 5101 DIE(aTHX_ "panic: pp_split"); 5102 rx = pm->op_pmregexp; 5103 5104 TAINT_IF((pm->op_pmflags & PMf_LOCALE) && 5105 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); 5106 5107 if (pm->op_pmreplroot) { 5108 #ifdef USE_ITHREADS 5109 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); 5110 #else 5111 ary = GvAVn((GV*)pm->op_pmreplroot); 5112 #endif 5113 } 5114 else if (gimme != G_ARRAY) 5115 #ifdef USE_THREADS 5116 ary = (AV*)PL_curpad[0]; 5117 #else 5118 ary = GvAVn(PL_defgv); 5119 #endif /* USE_THREADS */ 5120 else 5121 ary = Nullav; 5122 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { 5123 realarray = 1; 5124 PUTBACK; 5125 av_extend(ary,0); 5126 av_clear(ary); 5127 SPAGAIN; 5128 if ((mg = SvTIED_mg((SV*)ary, 'P'))) { 5129 PUSHMARK(SP); 5130 XPUSHs(SvTIED_obj((SV*)ary, mg)); 5131 } 5132 else { 5133 if (!AvREAL(ary)) { 5134 AvREAL_on(ary); 5135 AvREIFY_off(ary); 5136 for (i = AvFILLp(ary); i >= 0; i--) 5137 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */ 5138 } 5139 /* temporarily switch stacks */ 5140 SWITCHSTACK(PL_curstack, ary); 5141 make_mortal = 0; 5142 } 5143 } 5144 base = SP - PL_stack_base; 5145 orig = s; 5146 if (pm->op_pmflags & PMf_SKIPWHITE) { 5147 if (pm->op_pmflags & PMf_LOCALE) { 5148 while (isSPACE_LC(*s)) 5149 s++; 5150 } 5151 else { 5152 while (isSPACE(*s)) 5153 s++; 5154 } 5155 } 5156 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { 5157 SAVEINT(PL_multiline); 5158 PL_multiline = pm->op_pmflags & PMf_MULTILINE; 5159 } 5160 5161 if (!limit) 5162 limit = maxiters + 2; 5163 if (pm->op_pmflags & PMf_WHITE) { 5164 while (--limit) { 5165 m = s; 5166 while (m < strend && 5167 !((pm->op_pmflags & PMf_LOCALE) 5168 ? isSPACE_LC(*m) : isSPACE(*m))) 5169 ++m; 5170 if (m >= strend) 5171 break; 5172 5173 dstr = NEWSV(30, m-s); 5174 sv_setpvn(dstr, s, m-s); 5175 if (make_mortal) 5176 sv_2mortal(dstr); 5177 if (do_utf8) 5178 (void)SvUTF8_on(dstr); 5179 XPUSHs(dstr); 5180 5181 s = m + 1; 5182 while (s < strend && 5183 ((pm->op_pmflags & PMf_LOCALE) 5184 ? isSPACE_LC(*s) : isSPACE(*s))) 5185 ++s; 5186 } 5187 } 5188 else if (strEQ("^", rx->precomp)) { 5189 while (--limit) { 5190 /*SUPPRESS 530*/ 5191 for (m = s; m < strend && *m != '\n'; m++) ; 5192 m++; 5193 if (m >= strend) 5194 break; 5195 dstr = NEWSV(30, m-s); 5196 sv_setpvn(dstr, s, m-s); 5197 if (make_mortal) 5198 sv_2mortal(dstr); 5199 if (do_utf8) 5200 (void)SvUTF8_on(dstr); 5201 XPUSHs(dstr); 5202 s = m; 5203 } 5204 } 5205 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens 5206 && (rx->reganch & ROPT_CHECK_ALL) 5207 && !(rx->reganch & ROPT_ANCH)) { 5208 int tail = (rx->reganch & RE_INTUIT_TAIL); 5209 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx); 5210 5211 len = rx->minlen; 5212 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) { 5213 STRLEN n_a; 5214 char c = *SvPV(csv, n_a); 5215 while (--limit) { 5216 /*SUPPRESS 530*/ 5217 for (m = s; m < strend && *m != c; m++) ; 5218 if (m >= strend) 5219 break; 5220 dstr = NEWSV(30, m-s); 5221 sv_setpvn(dstr, s, m-s); 5222 if (make_mortal) 5223 sv_2mortal(dstr); 5224 if (do_utf8) 5225 (void)SvUTF8_on(dstr); 5226 XPUSHs(dstr); 5227 /* The rx->minlen is in characters but we want to step 5228 * s ahead by bytes. */ 5229 if (do_utf8) 5230 s = (char*)utf8_hop((U8*)m, len); 5231 else 5232 s = m + len; /* Fake \n at the end */ 5233 } 5234 } 5235 else { 5236 #ifndef lint 5237 while (s < strend && --limit && 5238 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, 5239 csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) 5240 #endif 5241 { 5242 dstr = NEWSV(31, m-s); 5243 sv_setpvn(dstr, s, m-s); 5244 if (make_mortal) 5245 sv_2mortal(dstr); 5246 if (do_utf8) 5247 (void)SvUTF8_on(dstr); 5248 XPUSHs(dstr); 5249 /* The rx->minlen is in characters but we want to step 5250 * s ahead by bytes. */ 5251 if (do_utf8) 5252 s = (char*)utf8_hop((U8*)m, len); 5253 else 5254 s = m + len; /* Fake \n at the end */ 5255 } 5256 } 5257 } 5258 else { 5259 maxiters += slen * rx->nparens; 5260 while (s < strend && --limit 5261 /* && (!rx->check_substr 5262 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend, 5263 0, NULL)))) 5264 */ && CALLREGEXEC(aTHX_ rx, s, strend, orig, 5265 1 /* minend */, sv, NULL, 0)) 5266 { 5267 TAINT_IF(RX_MATCH_TAINTED(rx)); 5268 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { 5269 m = s; 5270 s = orig; 5271 orig = rx->subbeg; 5272 s = orig + (m - s); 5273 strend = s + (strend - m); 5274 } 5275 m = rx->startp[0] + orig; 5276 dstr = NEWSV(32, m-s); 5277 sv_setpvn(dstr, s, m-s); 5278 if (make_mortal) 5279 sv_2mortal(dstr); 5280 if (do_utf8) 5281 (void)SvUTF8_on(dstr); 5282 XPUSHs(dstr); 5283 if (rx->nparens) { 5284 for (i = 1; i <= rx->nparens; i++) { 5285 s = rx->startp[i] + orig; 5286 m = rx->endp[i] + orig; 5287 if (m && s) { 5288 dstr = NEWSV(33, m-s); 5289 sv_setpvn(dstr, s, m-s); 5290 } 5291 else 5292 dstr = NEWSV(33, 0); 5293 if (make_mortal) 5294 sv_2mortal(dstr); 5295 if (do_utf8) 5296 (void)SvUTF8_on(dstr); 5297 XPUSHs(dstr); 5298 } 5299 } 5300 s = rx->endp[0] + orig; 5301 } 5302 } 5303 5304 LEAVE_SCOPE(oldsave); 5305 iters = (SP - PL_stack_base) - base; 5306 if (iters > maxiters) 5307 DIE(aTHX_ "Split loop"); 5308 5309 /* keep field after final delim? */ 5310 if (s < strend || (iters && origlimit)) { 5311 STRLEN l = strend - s; 5312 dstr = NEWSV(34, l); 5313 sv_setpvn(dstr, s, l); 5314 if (make_mortal) 5315 sv_2mortal(dstr); 5316 if (do_utf8) 5317 (void)SvUTF8_on(dstr); 5318 XPUSHs(dstr); 5319 iters++; 5320 } 5321 else if (!origlimit) { 5322 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) 5323 iters--, SP--; 5324 } 5325 5326 if (realarray) { 5327 if (!mg) { 5328 SWITCHSTACK(ary, oldstack); 5329 if (SvSMAGICAL(ary)) { 5330 PUTBACK; 5331 mg_set((SV*)ary); 5332 SPAGAIN; 5333 } 5334 if (gimme == G_ARRAY) { 5335 EXTEND(SP, iters); 5336 Copy(AvARRAY(ary), SP + 1, iters, SV*); 5337 SP += iters; 5338 RETURN; 5339 } 5340 } 5341 else { 5342 PUTBACK; 5343 ENTER; 5344 call_method("PUSH",G_SCALAR|G_DISCARD); 5345 LEAVE; 5346 SPAGAIN; 5347 if (gimme == G_ARRAY) { 5348 /* EXTEND should not be needed - we just popped them */ 5349 EXTEND(SP, iters); 5350 for (i=0; i < iters; i++) { 5351 SV **svp = av_fetch(ary, i, FALSE); 5352 PUSHs((svp) ? *svp : &PL_sv_undef); 5353 } 5354 RETURN; 5355 } 5356 } 5357 } 5358 else { 5359 if (gimme == G_ARRAY) 5360 RETURN; 5361 } 5362 if (iters || !pm->op_pmreplroot) { 5363 GETTARGET; 5364 PUSHi(iters); 5365 RETURN; 5366 } 5367 RETPUSHUNDEF; 5368 } 5369 5370 #ifdef USE_THREADS 5371 void 5372 Perl_unlock_condpair(pTHX_ void *svv) 5373 { 5374 MAGIC *mg = mg_find((SV*)svv, 'm'); 5375 5376 if (!mg) 5377 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); 5378 MUTEX_LOCK(MgMUTEXP(mg)); 5379 if (MgOWNER(mg) != thr) 5380 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); 5381 MgOWNER(mg) = 0; 5382 COND_SIGNAL(MgOWNERCONDP(mg)); 5383 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", 5384 PTR2UV(thr), PTR2UV(svv));) 5385 MUTEX_UNLOCK(MgMUTEXP(mg)); 5386 } 5387 #endif /* USE_THREADS */ 5388 5389 PP(pp_lock) 5390 { 5391 dSP; 5392 dTOPss; 5393 SV *retsv = sv; 5394 #ifdef USE_THREADS 5395 sv_lock(sv); 5396 #endif /* USE_THREADS */ 5397 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV 5398 || SvTYPE(retsv) == SVt_PVCV) { 5399 retsv = refto(retsv); 5400 } 5401 SETs(retsv); 5402 RETURN; 5403 } 5404 5405 PP(pp_threadsv) 5406 { 5407 #ifdef USE_THREADS 5408 dSP; 5409 EXTEND(SP, 1); 5410 if (PL_op->op_private & OPpLVAL_INTRO) 5411 PUSHs(*save_threadsv(PL_op->op_targ)); 5412 else 5413 PUSHs(THREADSV(PL_op->op_targ)); 5414 RETURN; 5415 #else 5416 DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); 5417 #endif /* USE_THREADS */ 5418 } 5419