pp.c

   1 /*    pp.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
  17
  18 /*
  19  * The compiler on Concurrent CX/UX systems has a subtle bug which only
  20  * seems to show up when compiling pp.c - it generates the wrong double
  21  * precision constant value for (double)UV_MAX when used inline in the body
  22  * of the code below, so this makes a static variable up front (which the
  23  * compiler seems to get correct) and uses it in place of UV_MAX below.
  24  */
  25 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
  26 static double UV_MAX_cxux = ((double)UV_MAX);
  27 #endif
  28
  29 /*
  30  * Types used in bitwise operations.
  31  *
  32  * Normally we'd just use IV and UV.  However, some hardware and
  33  * software combinations (e.g. Alpha and current OSF/1) don't have a
  34  * floating-point type to use for NV that has adequate bits to fully
  35  * hold an IV/UV.  (In other words, sizeof(long) == sizeof(double).)
  36  *
  37  * It just so happens that "int" is the right size almost everywhere.
  38  */
  39 typedef int IBW;
  40 typedef unsigned UBW;
  41
  42 /*
  43  * Mask used after bitwise operations.
  44  *
  45  * There is at least one realm (Cray word machines) that doesn't
  46  * have an integral type (except char) small enough to be represented
  47  * in a double without loss; that is, it has no 32-bit type.
  48  */
  49 #if LONGSIZE > 4  && defined(_CRAY) && !defined(_CRAYMPP)
  50 #  define BW_BITS  32
  51 #  define BW_MASK  ((1 << BW_BITS) - 1)
  52 #  define BW_SIGN  (1 << (BW_BITS - 1))
  53 #  define BWi(i)  (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
  54 #  define BWu(u)  ((u) & BW_MASK)
  55 #else
  56 #  define BWi(i)  (i)
  57 #  define BWu(u)  (u)
  58 #endif
  59
  60 /*
  61  * Offset for integer pack/unpack.
  62  *
  63  * On architectures where I16 and I32 aren't really 16 and 32 bits,
  64  * which for now are all Crays, pack and unpack have to play games.
  65  */
  66
  67 /*
  68  * These values are required for portability of pack() output.
  69  * If they're not right on your machine, then pack() and unpack()
  70  * wouldn't work right anyway; you'll need to apply the Cray hack.
  71  * (I'd like to check them with #if, but you can't use sizeof() in
  72  * the preprocessor.)  --???
  73  */
  74 /*
  75     The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
  76     defines are now in config.h.  --Andy Dougherty  April 1998
  77  */
  78 #define SIZE16 2
  79 #define SIZE32 4
  80
  81 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
  82 #  if BYTEORDER == 0x12345678
  83 #    define OFF16(p)    (char*)(p)
  84 #    define OFF32(p)    (char*)(p)
  85 #  else
  86 #    if BYTEORDER == 0x87654321
  87 #      define OFF16(p)  ((char*)(p) + (sizeof(U16) - SIZE16))
  88 #      define OFF32(p)  ((char*)(p) + (sizeof(U32) - SIZE32))
  89 #    else
  90        }}}} bad cray byte order
  91 #    endif
  92 #  endif
  93 #  define COPY16(s,p)  (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
  94 #  define COPY32(s,p)  (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
  95 #  define CAT16(sv,p)  sv_catpvn(sv, OFF16(p), SIZE16)
  96 #  define CAT32(sv,p)  sv_catpvn(sv, OFF32(p), SIZE32)
  97 #else
  98 #  define COPY16(s,p)  Copy(s, p, SIZE16, char)
  99 #  define COPY32(s,p)  Copy(s, p, SIZE32, char)
 100 #  define CAT16(sv,p)  sv_catpvn(sv, (char*)(p), SIZE16)
 101 #  define CAT32(sv,p)  sv_catpvn(sv, (char*)(p), SIZE32)
 102 #endif
 103
 104 static void doencodes _((SV* sv, char* s, I32 len));
 105 static SV* refto _((SV* sv));
 106 static U32 seed _((void));
 107
 108 static bool srand_called = FALSE;
 109
 110 /* variations on pp_null */
 111
 112 #ifdef I_UNISTD
 113 #include <unistd.h>
 114 #endif
 115
 116 /* XXX I can't imagine anyone who doesn't have this actually _needs_
 117    it, since pid_t is an integral type.
 118    --AD  2/20/1998
 119 */
 120 #ifdef NEED_GETPID_PROTO
 121 extern Pid_t getpid (void);
 122 #endif
 123
 124 PP(pp_stub)
 125 {
 126     djSP;
 127     if (GIMME_V == G_SCALAR)
 128         XPUSHs(&sv_undef);
 129     RETURN;
 130 }
 131
 132 PP(pp_scalar)
 133 {
 134     return NORMAL;
 135 }
 136
 137 /* Pushy stuff. */
 138
 139 PP(pp_padav)
 140 {
 141     djSP; dTARGET;
 142     if (op->op_private & OPpLVAL_INTRO)
 143         SAVECLEARSV(curpad[op->op_targ]);
 144     EXTEND(SP, 1);
 145     if (op->op_flags & OPf_REF) {
 146         PUSHs(TARG);
 147         RETURN;
 148     }
 149     if (GIMME == G_ARRAY) {
 150         I32 maxarg = AvFILL((AV*)TARG) + 1;
 151         EXTEND(SP, maxarg);
 152         if (SvMAGICAL(TARG)) {
 153             U32 i;
 154             for (i=0; i < maxarg; i++) {
 155                 SV **svp = av_fetch((AV*)TARG, i, FALSE);
 156                 SP[i+1] = (svp) ? *svp : &sv_undef;
 157             }
 158         }
 159         else {
 160             Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
 161         }
 162         SP += maxarg;
 163     }
 164     else {
 165         SV* sv = sv_newmortal();
 166         I32 maxarg = AvFILL((AV*)TARG) + 1;
 167         sv_setiv(sv, maxarg);
 168         PUSHs(sv);
 169     }
 170     RETURN;
 171 }
 172
 173 PP(pp_padhv)
 174 {
 175     djSP; dTARGET;
 176     I32 gimme;
 177
 178     XPUSHs(TARG);
 179     if (op->op_private & OPpLVAL_INTRO)
 180         SAVECLEARSV(curpad[op->op_targ]);
 181     if (op->op_flags & OPf_REF)
 182         RETURN;
 183     gimme = GIMME_V;
 184     if (gimme == G_ARRAY) {
 185         RETURNOP(do_kv(ARGS));
 186     }
 187     else if (gimme == G_SCALAR) {
 188         SV* sv = sv_newmortal();
 189         if (HvFILL((HV*)TARG))
 190             sv_setpvf(sv, "%ld/%ld",
 191                       (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
 192         else
 193             sv_setiv(sv, 0);
 194         SETs(sv);
 195     }
 196     RETURN;
 197 }
 198
 199 PP(pp_padany)
 200 {
 201     DIE("NOT IMPL LINE %d",__LINE__);
 202 }
 203
 204 /* Translations. */
 205
 206 PP(pp_rv2gv)
 207 {
 208     djSP; dTOPss;
 209
 210     if (SvROK(sv)) {
 211       wasref:
 212         sv = SvRV(sv);
 213         if (SvTYPE(sv) == SVt_PVIO) {
 214             GV *gv = (GV*) sv_newmortal();
 215             gv_init(gv, 0, "", 0, 0);
 216             GvIOp(gv) = (IO *)sv;
 217             (void)SvREFCNT_inc(sv);
 218             sv = (SV*) gv;
 219         } else if (SvTYPE(sv) != SVt_PVGV)
 220             DIE("Not a GLOB reference");
 221     }
 222     else {
 223         if (SvTYPE(sv) != SVt_PVGV) {
 224             char *sym;
 225
 226             if (SvGMAGICAL(sv)) {
 227                 mg_get(sv);
 228                 if (SvROK(sv))
 229                     goto wasref;
 230             }
 231             if (!SvOK(sv)) {
 232                 if (op->op_flags & OPf_REF ||
 233                     op->op_private & HINT_STRICT_REFS)
 234                     DIE(no_usym, "a symbol");
 235                 if (dowarn)
 236                     warn(warn_uninit);
 237                 RETSETUNDEF;
 238             }
 239             sym = SvPV(sv, na);
 240             if (op->op_private & HINT_STRICT_REFS)
 241                 DIE(no_symref, sym, "a symbol");
 242             sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
 243         }
 244     }
 245     if (op->op_private & OPpLVAL_INTRO)
 246         save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
 247     SETs(sv);
 248     RETURN;
 249 }
 250
 251 PP(pp_rv2sv)
 252 {
 253     djSP; dTOPss;
 254
 255     if (SvROK(sv)) {
 256       wasref:
 257         sv = SvRV(sv);
 258         switch (SvTYPE(sv)) {
 259         case SVt_PVAV:
 260         case SVt_PVHV:
 261         case SVt_PVCV:
 262             DIE("Not a SCALAR reference");
 263         }
 264     }
 265     else {
 266         GV *gv = (GV*)sv;
 267         char *sym;
 268
 269         if (SvTYPE(gv) != SVt_PVGV) {
 270             if (SvGMAGICAL(sv)) {
 271                 mg_get(sv);
 272                 if (SvROK(sv))
 273                     goto wasref;
 274             }
 275             if (!SvOK(sv)) {
 276                 if (op->op_flags & OPf_REF ||
 277                     op->op_private & HINT_STRICT_REFS)
 278                     DIE(no_usym, "a SCALAR");
 279                 if (dowarn)
 280                     warn(warn_uninit);
 281                 RETSETUNDEF;
 282             }
 283             sym = SvPV(sv, na);
 284             if (op->op_private & HINT_STRICT_REFS)
 285                 DIE(no_symref, sym, "a SCALAR");
 286             gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
 287         }
 288         sv = GvSV(gv);
 289     }
 290     if (op->op_flags & OPf_MOD) {
 291         if (op->op_private & OPpLVAL_INTRO)
 292             sv = save_scalar((GV*)TOPs);
 293         else if (op->op_private & OPpDEREF)
 294             vivify_ref(sv, op->op_private & OPpDEREF);
 295     }
 296     SETs(sv);
 297     RETURN;
 298 }
 299
 300 PP(pp_av2arylen)
 301 {
 302     djSP;
 303     AV *av = (AV*)TOPs;
 304     SV *sv = AvARYLEN(av);
 305     if (!sv) {
 306         AvARYLEN(av) = sv = NEWSV(0,0);
 307         sv_upgrade(sv, SVt_IV);
 308         sv_magic(sv, (SV*)av, '#', Nullch, 0);
 309     }
 310     SETs(sv);
 311     RETURN;
 312 }
 313
 314 PP(pp_pos)
 315 {
 316     djSP; dTARGET; dPOPss;
 317
 318     if (op->op_flags & OPf_MOD) {
 319         if (SvTYPE(TARG) < SVt_PVLV) {
 320             sv_upgrade(TARG, SVt_PVLV);
 321             sv_magic(TARG, Nullsv, '.', Nullch, 0);
 322         }
 323
 324         LvTYPE(TARG) = '.';
 325         LvTARG(TARG) = sv;
 326         PUSHs(TARG);    /* no SvSETMAGIC */
 327         RETURN;
 328     }
 329     else {
 330         MAGIC* mg;
 331
 332         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
 333             mg = mg_find(sv, 'g');
 334             if (mg && mg->mg_len >= 0) {
 335                 PUSHi(mg->mg_len + curcop->cop_arybase);
 336                 RETURN;
 337             }
 338         }
 339         RETPUSHUNDEF;
 340     }
 341 }
 342
 343 PP(pp_rv2cv)
 344 {
 345     djSP;
 346     GV *gv;
 347     HV *stash;
 348
 349     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
 350     /* (But not in defined().) */
 351     CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
 352     if (cv) {
 353         if (CvCLONE(cv))
 354             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 355     }
 356     else
 357         cv = (CV*)&sv_undef;
 358     SETs((SV*)cv);
 359     RETURN;
 360 }
 361
 362 PP(pp_prototype)
 363 {
 364     djSP;
 365     CV *cv;
 366     HV *stash;
 367     GV *gv;
 368     SV *ret;
 369
 370     ret = &sv_undef;
 371     if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
 372         char *s = SvPVX(TOPs);
 373         if (strnEQ(s, "CORE::", 6)) {
 374             int code;
 375
 376             code = keyword(s + 6, SvCUR(TOPs) - 6);
 377             if (code < 0) {     /* Overridable. */
 378 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
 379                 int i = 0, n = 0, seen_question = 0;
 380                 I32 oa;
 381                 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
 382
 383                 while (i < MAXO) {      /* The slow way. */
 384                     if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
 385                         goto found;
 386                     i++;
 387                 }
 388                 goto nonesuch;          /* Should not happen... */
 389               found:
 390                 oa = opargs[i] >> OASHIFT;
 391                 while (oa) {
 392                     if (oa & OA_OPTIONAL) {
 393                         seen_question = 1;
 394                         str[n++] = ';';
 395                     } else if (seen_question)
 396                         goto set;       /* XXXX system, exec */
 397                     if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
 398                         && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
 399                         str[n++] = '\\';
 400                     }
 401                     /* What to do with R ((un)tie, tied, (sys)read, recv)? */
 402                     str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
 403                     oa = oa >> 4;
 404                 }
 405                 str[n++] = '\0';
 406                 ret = sv_2mortal(newSVpv(str, n - 1));
 407             } else if (code)            /* Non-Overridable */
 408                 goto set;
 409             else {                      /* None such */
 410               nonesuch:
 411                 croak("Cannot find an opnumber for \"%s\"", s+6);
 412             }
 413         }
 414     }
 415     cv = sv_2cv(TOPs, &stash, &gv, FALSE);
 416     if (cv && SvPOK(cv))
 417         ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
 418   set:
 419     SETs(ret);
 420     RETURN;
 421 }
 422
 423 PP(pp_anoncode)
 424 {
 425     djSP;
 426     CV* cv = (CV*)curpad[op->op_targ];
 427     if (CvCLONE(cv))
 428         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
 429     EXTEND(SP,1);
 430     PUSHs((SV*)cv);
 431     RETURN;
 432 }
 433
 434 PP(pp_srefgen)
 435 {
 436     djSP;
 437     *SP = refto(*SP);
 438     RETURN;
 439 }
 440
 441 PP(pp_refgen)
 442 {
 443     djSP; dMARK;
 444     if (GIMME != G_ARRAY) {
 445         if (++MARK <= SP)
 446             *MARK = *SP;
 447         else
 448             *MARK = &sv_undef;
 449         *MARK = refto(*MARK);
 450         SP = MARK;
 451         RETURN;
 452     }
 453     EXTEND_MORTAL(SP - MARK);
 454     while (++MARK <= SP)
 455         *MARK = refto(*MARK);
 456     RETURN;
 457 }
 458
 459 static SV*
 460 refto(SV *sv)
 461 {
 462     SV* rv;
 463
 464     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
 465         if (LvTARGLEN(sv))
 466             vivify_defelem(sv);
 467         if (!(sv = LvTARG(sv)))
 468             sv = &sv_undef;
 469     }
 470     else if (SvPADTMP(sv))
 471         sv = newSVsv(sv);
 472     else {
 473         SvTEMP_off(sv);
 474         (void)SvREFCNT_inc(sv);
 475     }
 476     rv = sv_newmortal();
 477     sv_upgrade(rv, SVt_RV);
 478     SvRV(rv) = sv;
 479     SvROK_on(rv);
 480     return rv;
 481 }
 482
 483 PP(pp_ref)
 484 {
 485     djSP; dTARGET;
 486     SV *sv;
 487     char *pv;
 488
 489     sv = POPs;
 490
 491     if (sv && SvGMAGICAL(sv))
 492         mg_get(sv);
 493
 494     if (!sv || !SvROK(sv))
 495         RETPUSHNO;
 496
 497     sv = SvRV(sv);
 498     pv = sv_reftype(sv,TRUE);
 499     PUSHp(pv, strlen(pv));
 500     RETURN;
 501 }
 502
 503 PP(pp_bless)
 504 {
 505     djSP;
 506     HV *stash;
 507
 508     if (MAXARG == 1)
 509         stash = curcop->cop_stash;
 510     else
 511         stash = gv_stashsv(POPs, TRUE);
 512
 513     (void)sv_bless(TOPs, stash);
 514     RETURN;
 515 }
 516
 517 PP(pp_gelem)
 518 {
 519     GV *gv;
 520     SV *sv;
 521     SV *ref;
 522     char *elem;
 523     djSP;
 524
 525     sv = POPs;
 526     elem = SvPV(sv, na);
 527     gv = (GV*)POPs;
 528     ref = Nullsv;
 529     sv = Nullsv;
 530     switch (elem ? *elem : '\0')
 531     {
 532     case 'A':
 533         if (strEQ(elem, "ARRAY"))
 534             ref = (SV*)GvAV(gv);
 535         break;
 536     case 'C':
 537         if (strEQ(elem, "CODE"))
 538             ref = (SV*)GvCVu(gv);
 539         break;
 540     case 'F':
 541         if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
 542             ref = (SV*)GvIOp(gv);
 543         break;
 544     case 'G':
 545         if (strEQ(elem, "GLOB"))
 546             ref = (SV*)gv;
 547         break;
 548     case 'H':
 549         if (strEQ(elem, "HASH"))
 550             ref = (SV*)GvHV(gv);
 551         break;
 552     case 'I':
 553         if (strEQ(elem, "IO"))
 554             ref = (SV*)GvIOp(gv);
 555         break;
 556     case 'N':
 557         if (strEQ(elem, "NAME"))
 558             sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
 559         break;
 560     case 'P':
 561         if (strEQ(elem, "PACKAGE"))
 562             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 563         break;
 564     case 'S':
 565         if (strEQ(elem, "SCALAR"))
 566             ref = GvSV(gv);
 567         break;
 568     }
 569     if (ref)
 570         sv = newRV(ref);
 571     if (sv)
 572         sv_2mortal(sv);
 573     else
 574         sv = &sv_undef;
 575     XPUSHs(sv);
 576     RETURN;
 577 }
 578
 579 /* Pattern matching */
 580
 581 PP(pp_study)
 582 {
 583     djSP; dPOPss;
 584     register UNOP *unop = cUNOP;
 585     register unsigned char *s;
 586     register I32 pos;
 587     register I32 ch;
 588     register I32 *sfirst;
 589     register I32 *snext;
 590     STRLEN len;
 591
 592     if(unop->op_first && unop->op_first->op_type == OP_PUSHRE) {
 593         PMOP *pm = (PMOP *)unop->op_first;
 594         SV *rv = sv_newmortal();
 595         sv = newSVrv(rv, "Regexp");
 596         sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
 597         RETURNX(PUSHs(rv));
 598     }
 599
 600     if (sv == lastscream) {
 601         if (SvSCREAM(sv))
 602             RETPUSHYES;
 603     }
 604     else {
 605         if (lastscream) {
 606             SvSCREAM_off(lastscream);
 607             SvREFCNT_dec(lastscream);
 608         }
 609         lastscream = SvREFCNT_inc(sv);
 610     }
 611
 612     s = (unsigned char*)(SvPV(sv, len));
 613     pos = len;
 614     if (pos <= 0)
 615         RETPUSHNO;
 616     if (pos > maxscream) {
 617         if (maxscream < 0) {
 618             maxscream = pos + 80;
 619             New(301, screamfirst, 256, I32);
 620             New(302, screamnext, maxscream, I32);
 621         }
 622         else {
 623             maxscream = pos + pos / 4;
 624             Renew(screamnext, maxscream, I32);
 625         }
 626     }
 627
 628     sfirst = screamfirst;
 629     snext = screamnext;
 630
 631     if (!sfirst || !snext)
 632         DIE("do_study: out of memory");
 633
 634     for (ch = 256; ch; --ch)
 635         *sfirst++ = -1;
 636     sfirst -= 256;
 637
 638     while (--pos >= 0) {
 639         ch = s[pos];
 640         if (sfirst[ch] >= 0)
 641             snext[pos] = sfirst[ch] - pos;
 642         else
 643             snext[pos] = -pos;
 644         sfirst[ch] = pos;
 645     }
 646
 647     SvSCREAM_on(sv);
 648     sv_magic(sv, Nullsv, 'g', Nullch, 0);       /* piggyback on m//g magic */
 649     RETPUSHYES;
 650 }
 651
 652 PP(pp_trans)
 653 {
 654     djSP; dTARG;
 655     SV *sv;
 656
 657     if (op->op_flags & OPf_STACKED)
 658         sv = POPs;
 659     else {
 660         sv = DEFSV;
 661         EXTEND(SP,1);
 662     }
 663     TARG = sv_newmortal();
 664     PUSHi(do_trans(sv, op));
 665     RETURN;
 666 }
 667
 668 /* Lvalue operators. */
 669
 670 PP(pp_schop)
 671 {
 672     djSP; dTARGET;
 673     do_chop(TARG, TOPs);
 674     SETTARG;
 675     RETURN;
 676 }
 677
 678 PP(pp_chop)
 679 {
 680     djSP; dMARK; dTARGET;
 681     while (SP > MARK)
 682         do_chop(TARG, POPs);
 683     PUSHTARG;
 684     RETURN;
 685 }
 686
 687 PP(pp_schomp)
 688 {
 689     djSP; dTARGET;
 690     SETi(do_chomp(TOPs));
 691     RETURN;
 692 }
 693
 694 PP(pp_chomp)
 695 {
 696     djSP; dMARK; dTARGET;
 697     register I32 count = 0;
 698
 699     while (SP > MARK)
 700         count += do_chomp(POPs);
 701     PUSHi(count);
 702     RETURN;
 703 }
 704
 705 PP(pp_defined)
 706 {
 707     djSP;
 708     register SV* sv;
 709
 710     sv = POPs;
 711     if (!sv || !SvANY(sv))
 712         RETPUSHNO;
 713     switch (SvTYPE(sv)) {
 714     case SVt_PVAV:
 715         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
 716             RETPUSHYES;
 717         break;
 718     case SVt_PVHV:
 719         if (HvARRAY(sv) || SvGMAGICAL(sv))
 720             RETPUSHYES;
 721         break;
 722     case SVt_PVCV:
 723         if (CvROOT(sv) || CvXSUB(sv))
 724             RETPUSHYES;
 725         break;
 726     default:
 727         if (SvGMAGICAL(sv))
 728             mg_get(sv);
 729         if (SvOK(sv))
 730             RETPUSHYES;
 731     }
 732     RETPUSHNO;
 733 }
 734
 735 PP(pp_undef)
 736 {
 737     djSP;
 738     SV *sv;
 739
 740     if (!op->op_private) {
 741         EXTEND(SP, 1);
 742         RETPUSHUNDEF;
 743     }
 744
 745     sv = POPs;
 746     if (!sv)
 747         RETPUSHUNDEF;
 748
 749     if (SvTHINKFIRST(sv)) {
 750         if (SvREADONLY(sv))
 751             RETPUSHUNDEF;
 752         if (SvROK(sv))
 753             sv_unref(sv);
 754     }
 755
 756     switch (SvTYPE(sv)) {
 757     case SVt_NULL:
 758         break;
 759     case SVt_PVAV:
 760         av_undef((AV*)sv);
 761         break;
 762     case SVt_PVHV:
 763         hv_undef((HV*)sv);
 764         break;
 765     case SVt_PVCV:
 766         if (cv_const_sv((CV*)sv))
 767             warn("Constant subroutine %s undefined",
 768                  CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
 769         /* FALL THROUGH */
 770     case SVt_PVFM:
 771         { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
 772           cv_undef((CV*)sv);
 773           CvGV((CV*)sv) = gv; }   /* let user-undef'd sub keep its identity */
 774         break;
 775     case SVt_PVGV:
 776         if (SvFAKE(sv))
 777             SvSetMagicSV(sv, &sv_undef);
 778         else {
 779             GP *gp;
 780             gp_free((GV*)sv);
 781             Newz(602, gp, 1, GP);
 782             GvGP(sv) = gp_ref(gp);
 783             GvSV(sv) = NEWSV(72,0);
 784             GvLINE(sv) = curcop->cop_line;
 785             GvEGV(sv) = (GV*)sv;
 786             GvMULTI_on(sv);
 787         }
 788         break;
 789     default:
 790         if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
 791             (void)SvOOK_off(sv);
 792             Safefree(SvPVX(sv));
 793             SvPV_set(sv, Nullch);
 794             SvLEN_set(sv, 0);
 795         }
 796         (void)SvOK_off(sv);
 797         SvSETMAGIC(sv);
 798     }
 799
 800     RETPUSHUNDEF;
 801 }
 802
 803 PP(pp_predec)
 804 {
 805     djSP;
 806     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 807         croak(no_modify);
 808     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 809         SvIVX(TOPs) != IV_MIN)
 810     {
 811         --SvIVX(TOPs);
 812         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 813     }
 814     else
 815         sv_dec(TOPs);
 816     SvSETMAGIC(TOPs);
 817     return NORMAL;
 818 }
 819
 820 PP(pp_postinc)
 821 {
 822     djSP; dTARGET;
 823     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 824         croak(no_modify);
 825     sv_setsv(TARG, TOPs);
 826     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 827         SvIVX(TOPs) != IV_MAX)
 828     {
 829         ++SvIVX(TOPs);
 830         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 831     }
 832     else
 833         sv_inc(TOPs);
 834     SvSETMAGIC(TOPs);
 835     if (!SvOK(TARG))
 836         sv_setiv(TARG, 0);
 837     SETs(TARG);
 838     return NORMAL;
 839 }
 840
 841 PP(pp_postdec)
 842 {
 843     djSP; dTARGET;
 844     if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 845         croak(no_modify);
 846     sv_setsv(TARG, TOPs);
 847     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 848         SvIVX(TOPs) != IV_MIN)
 849     {
 850         --SvIVX(TOPs);
 851         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 852     }
 853     else
 854         sv_dec(TOPs);
 855     SvSETMAGIC(TOPs);
 856     SETs(TARG);
 857     return NORMAL;
 858 }
 859
 860 /* Ordinary operators. */
 861
 862 PP(pp_pow)
 863 {
 864     djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
 865     {
 866       dPOPTOPnnrl;
 867       SETn( pow( left, right) );
 868       RETURN;
 869     }
 870 }
 871
 872 PP(pp_multiply)
 873 {
 874     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
 875     {
 876       dPOPTOPnnrl;
 877       SETn( left * right );
 878       RETURN;
 879     }
 880 }
 881
 882 PP(pp_divide)
 883 {
 884     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
 885     {
 886       dPOPPOPnnrl;
 887       double value;
 888       if (right == 0.0)
 889         DIE("Illegal division by zero");
 890 #ifdef SLOPPYDIVIDE
 891       /* insure that 20./5. == 4. */
 892       {
 893         IV k;
 894         if ((double)I_V(left)  == left &&
 895             (double)I_V(right) == right &&
 896             (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
 897             value = k;
 898         } else {
 899             value = left / right;
 900         }
 901       }
 902 #else
 903       value = left / right;
 904 #endif
 905       PUSHn( value );
 906       RETURN;
 907     }
 908 }
 909
 910 PP(pp_modulo)
 911 {
 912     djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
 913     {
 914       UV left;
 915       UV right;
 916       bool left_neg;
 917       bool right_neg;
 918       UV ans;
 919
 920       if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 921         IV i = SvIVX(POPs);
 922         right = (right_neg = (i < 0)) ? -i : i;
 923       }
 924       else {
 925         double n = POPn;
 926         right = U_V((right_neg = (n < 0)) ? -n : n);
 927       }
 928
 929       if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
 930         IV i = SvIVX(POPs);
 931         left = (left_neg = (i < 0)) ? -i : i;
 932       }
 933       else {
 934         double n = POPn;
 935         left = U_V((left_neg = (n < 0)) ? -n : n);
 936       }
 937
 938       if (!right)
 939         DIE("Illegal modulus zero");
 940
 941       ans = left % right;
 942       if ((left_neg != right_neg) && ans)
 943         ans = right - ans;
 944       if (right_neg) {
 945         /* XXX may warn: unary minus operator applied to unsigned type */
 946         /* could change -foo to be (~foo)+1 instead     */
 947         if (ans <= ~((UV)IV_MAX)+1)
 948           sv_setiv(TARG, ~ans+1);
 949         else
 950           sv_setnv(TARG, -(double)ans);
 951       }
 952       else
 953         sv_setuv(TARG, ans);
 954       PUSHTARG;
 955       RETURN;
 956     }
 957 }
 958
 959 PP(pp_repeat)
 960 {
 961   djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
 962   {
 963     register I32 count = POPi;
 964     if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
 965         dMARK;
 966         I32 items = SP - MARK;
 967         I32 max;
 968
 969         max = items * count;
 970         MEXTEND(MARK, max);
 971         if (count > 1) {
 972             while (SP > MARK) {
 973                 if (*SP)
 974                     SvTEMP_off((*SP));
 975                 SP--;
 976             }
 977             MARK++;
 978             repeatcpy((char*)(MARK + items), (char*)MARK,
 979                 items * sizeof(SV*), count - 1);
 980             SP += max;
 981         }
 982         else if (count <= 0)
 983             SP -= items;
 984     }
 985     else {      /* Note: mark already snarfed by pp_list */
 986         SV *tmpstr;
 987         STRLEN len;
 988
 989         tmpstr = POPs;
 990         if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
 991             if (SvREADONLY(tmpstr) && curcop != &compiling)
 992                 DIE("Can't x= to readonly value");
 993             if (SvROK(tmpstr))
 994                 sv_unref(tmpstr);
 995         }
 996         SvSetSV(TARG, tmpstr);
 997         SvPV_force(TARG, len);
 998         if (count != 1) {
 999             if (count < 1)
1000                 SvCUR_set(TARG, 0);
1001             else {
1002                 SvGROW(TARG, (count * len) + 1);
1003                 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1004                 SvCUR(TARG) *= count;
1005             }
1006             *SvEND(TARG) = '\0';
1007         }
1008         (void)SvPOK_only(TARG);
1009         PUSHTARG;
1010     }
1011     RETURN;
1012   }
1013 }
1014
1015 PP(pp_subtract)
1016 {
1017     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1018     {
1019       dPOPTOPnnrl_ul;
1020       SETn( left - right );
1021       RETURN;
1022     }
1023 }
1024
1025 PP(pp_left_shift)
1026 {
1027     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1028     {
1029       IBW shift = POPi;
1030       if (op->op_private & HINT_INTEGER) {
1031         IBW i = TOPi;
1032         i = BWi(i) << shift;
1033         SETi(BWi(i));
1034       }
1035       else {
1036         UBW u = TOPu;
1037         u <<= shift;
1038         SETu(BWu(u));
1039       }
1040       RETURN;
1041     }
1042 }
1043
1044 PP(pp_right_shift)
1045 {
1046     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1047     {
1048       IBW shift = POPi;
1049       if (op->op_private & HINT_INTEGER) {
1050         IBW i = TOPi;
1051         i = BWi(i) >> shift;
1052         SETi(BWi(i));
1053       }
1054       else {
1055         UBW u = TOPu;
1056         u >>= shift;
1057         SETu(BWu(u));
1058       }
1059       RETURN;
1060     }
1061 }
1062
1063 PP(pp_lt)
1064 {
1065     djSP; tryAMAGICbinSET(lt,0);
1066     {
1067       dPOPnv;
1068       SETs(boolSV(TOPn < value));
1069       RETURN;
1070     }
1071 }
1072
1073 PP(pp_gt)
1074 {
1075     djSP; tryAMAGICbinSET(gt,0);
1076     {
1077       dPOPnv;
1078       SETs(boolSV(TOPn > value));
1079       RETURN;
1080     }
1081 }
1082
1083 PP(pp_le)
1084 {
1085     djSP; tryAMAGICbinSET(le,0);
1086     {
1087       dPOPnv;
1088       SETs(boolSV(TOPn <= value));
1089       RETURN;
1090     }
1091 }
1092
1093 PP(pp_ge)
1094 {
1095     djSP; tryAMAGICbinSET(ge,0);
1096     {
1097       dPOPnv;
1098       SETs(boolSV(TOPn >= value));
1099       RETURN;
1100     }
1101 }
1102
1103 PP(pp_ne)
1104 {
1105     djSP; tryAMAGICbinSET(ne,0);
1106     {
1107       dPOPnv;
1108       SETs(boolSV(TOPn != value));
1109       RETURN;
1110     }
1111 }
1112
1113 PP(pp_ncmp)
1114 {
1115     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1116     {
1117       dPOPTOPnnrl;
1118       I32 value;
1119
1120       if (left == right)
1121         value = 0;
1122       else if (left < right)
1123         value = -1;
1124       else if (left > right)
1125         value = 1;
1126       else {
1127         SETs(&sv_undef);
1128         RETURN;
1129       }
1130       SETi(value);
1131       RETURN;
1132     }
1133 }
1134
1135 PP(pp_slt)
1136 {
1137     djSP; tryAMAGICbinSET(slt,0);
1138     {
1139       dPOPTOPssrl;
1140       int cmp = ((op->op_private & OPpLOCALE)
1141                  ? sv_cmp_locale(left, right)
1142                  : sv_cmp(left, right));
1143       SETs(boolSV(cmp < 0));
1144       RETURN;
1145     }
1146 }
1147
1148 PP(pp_sgt)
1149 {
1150     djSP; tryAMAGICbinSET(sgt,0);
1151     {
1152       dPOPTOPssrl;
1153       int cmp = ((op->op_private & OPpLOCALE)
1154                  ? sv_cmp_locale(left, right)
1155                  : sv_cmp(left, right));
1156       SETs(boolSV(cmp > 0));
1157       RETURN;
1158     }
1159 }
1160
1161 PP(pp_sle)
1162 {
1163     djSP; tryAMAGICbinSET(sle,0);
1164     {
1165       dPOPTOPssrl;
1166       int cmp = ((op->op_private & OPpLOCALE)
1167                  ? sv_cmp_locale(left, right)
1168                  : sv_cmp(left, right));
1169       SETs(boolSV(cmp <= 0));
1170       RETURN;
1171     }
1172 }
1173
1174 PP(pp_sge)
1175 {
1176     djSP; tryAMAGICbinSET(sge,0);
1177     {
1178       dPOPTOPssrl;
1179       int cmp = ((op->op_private & OPpLOCALE)
1180                  ? sv_cmp_locale(left, right)
1181                  : sv_cmp(left, right));
1182       SETs(boolSV(cmp >= 0));
1183       RETURN;
1184     }
1185 }
1186
1187 PP(pp_seq)
1188 {
1189     djSP; tryAMAGICbinSET(seq,0);
1190     {
1191       dPOPTOPssrl;
1192       SETs(boolSV(sv_eq(left, right)));
1193       RETURN;
1194     }
1195 }
1196
1197 PP(pp_sne)
1198 {
1199     djSP; tryAMAGICbinSET(sne,0);
1200     {
1201       dPOPTOPssrl;
1202       SETs(boolSV(!sv_eq(left, right)));
1203       RETURN;
1204     }
1205 }
1206
1207 PP(pp_scmp)
1208 {
1209     djSP; dTARGET;  tryAMAGICbin(scmp,0);
1210     {
1211       dPOPTOPssrl;
1212       int cmp = ((op->op_private & OPpLOCALE)
1213                  ? sv_cmp_locale(left, right)
1214                  : sv_cmp(left, right));
1215       SETi( cmp );
1216       RETURN;
1217     }
1218 }
1219
1220 PP(pp_bit_and)
1221 {
1222     djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
1223     {
1224       dPOPTOPssrl;
1225       if (SvNIOKp(left) || SvNIOKp(right)) {
1226         if (op->op_private & HINT_INTEGER) {
1227           IBW value = SvIV(left) & SvIV(right);
1228           SETi(BWi(value));
1229         }
1230         else {
1231           UBW value = SvUV(left) & SvUV(right);
1232           SETu(BWu(value));
1233         }
1234       }
1235       else {
1236         do_vop(op->op_type, TARG, left, right);
1237         SETTARG;
1238       }
1239       RETURN;
1240     }
1241 }
1242
1243 PP(pp_bit_xor)
1244 {
1245     djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
1246     {
1247       dPOPTOPssrl;
1248       if (SvNIOKp(left) || SvNIOKp(right)) {
1249         if (op->op_private & HINT_INTEGER) {
1250           IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1251           SETi(BWi(value));
1252         }
1253         else {
1254           UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1255           SETu(BWu(value));
1256         }
1257       }
1258       else {
1259         do_vop(op->op_type, TARG, left, right);
1260         SETTARG;
1261       }
1262       RETURN;
1263     }
1264 }
1265
1266 PP(pp_bit_or)
1267 {
1268     djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
1269     {
1270       dPOPTOPssrl;
1271       if (SvNIOKp(left) || SvNIOKp(right)) {
1272         if (op->op_private & HINT_INTEGER) {
1273           IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1274           SETi(BWi(value));
1275         }
1276         else {
1277           UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1278           SETu(BWu(value));
1279         }
1280       }
1281       else {
1282         do_vop(op->op_type, TARG, left, right);
1283         SETTARG;
1284       }
1285       RETURN;
1286     }
1287 }
1288
1289 PP(pp_negate)
1290 {
1291     djSP; dTARGET; tryAMAGICun(neg);
1292     {
1293         dTOPss;
1294         if (SvGMAGICAL(sv))
1295             mg_get(sv);
1296         if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
1297             SETi(-SvIVX(sv));
1298         else if (SvNIOKp(sv))
1299             SETn(-SvNV(sv));
1300         else if (SvPOKp(sv)) {
1301             STRLEN len;
1302             char *s = SvPV(sv, len);
1303             if (isIDFIRST(*s)) {
1304                 sv_setpvn(TARG, "-", 1);
1305                 sv_catsv(TARG, sv);
1306             }
1307             else if (*s == '+' || *s == '-') {
1308                 sv_setsv(TARG, sv);
1309                 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
1310             }
1311             else
1312                 sv_setnv(TARG, -SvNV(sv));
1313             SETTARG;
1314         }
1315         else
1316             SETn(-SvNV(sv));
1317     }
1318     RETURN;
1319 }
1320
1321 PP(pp_not)
1322 {
1323 #ifdef OVERLOAD
1324     djSP; tryAMAGICunSET(not);
1325 #endif /* OVERLOAD */
1326     *stack_sp = boolSV(!SvTRUE(*stack_sp));
1327     return NORMAL;
1328 }
1329
1330 PP(pp_complement)
1331 {
1332     djSP; dTARGET; tryAMAGICun(compl);
1333     {
1334       dTOPss;
1335       if (SvNIOKp(sv)) {
1336         if (op->op_private & HINT_INTEGER) {
1337           IBW value = ~SvIV(sv);
1338           SETi(BWi(value));
1339         }
1340         else {
1341           UBW value = ~SvUV(sv);
1342           SETu(BWu(value));
1343         }
1344       }
1345       else {
1346         register char *tmps;
1347         register long *tmpl;
1348         register I32 anum;
1349         STRLEN len;
1350
1351         SvSetSV(TARG, sv);
1352         tmps = SvPV_force(TARG, len);
1353         anum = len;
1354 #ifdef LIBERAL
1355         for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1356             *tmps = ~*tmps;
1357         tmpl = (long*)tmps;
1358         for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1359             *tmpl = ~*tmpl;
1360         tmps = (char*)tmpl;
1361 #endif
1362         for ( ; anum > 0; anum--, tmps++)
1363             *tmps = ~*tmps;
1364
1365         SETs(TARG);
1366       }
1367       RETURN;
1368     }
1369 }
1370
1371 /* integer versions of some of the above */
1372
1373 PP(pp_i_multiply)
1374 {
1375     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1376     {
1377       dPOPTOPiirl;
1378       SETi( left * right );
1379       RETURN;
1380     }
1381 }
1382
1383 PP(pp_i_divide)
1384 {
1385     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1386     {
1387       dPOPiv;
1388       if (value == 0)
1389         DIE("Illegal division by zero");
1390       value = POPi / value;
1391       PUSHi( value );
1392       RETURN;
1393     }
1394 }
1395
1396 PP(pp_i_modulo)
1397 {
1398     djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
1399     {
1400       dPOPTOPiirl;
1401       if (!right)
1402         DIE("Illegal modulus zero");
1403       SETi( left % right );
1404       RETURN;
1405     }
1406 }
1407
1408 PP(pp_i_add)
1409 {
1410     djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
1411     {
1412       dPOPTOPiirl;
1413       SETi( left + right );
1414       RETURN;
1415     }
1416 }
1417
1418 PP(pp_i_subtract)
1419 {
1420     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
1421     {
1422       dPOPTOPiirl;
1423       SETi( left - right );
1424       RETURN;
1425     }
1426 }
1427
1428 PP(pp_i_lt)
1429 {
1430     djSP; tryAMAGICbinSET(lt,0);
1431     {
1432       dPOPTOPiirl;
1433       SETs(boolSV(left < right));
1434       RETURN;
1435     }
1436 }
1437
1438 PP(pp_i_gt)
1439 {
1440     djSP; tryAMAGICbinSET(gt,0);
1441     {
1442       dPOPTOPiirl;
1443       SETs(boolSV(left > right));
1444       RETURN;
1445     }
1446 }
1447
1448 PP(pp_i_le)
1449 {
1450     djSP; tryAMAGICbinSET(le,0);
1451     {
1452       dPOPTOPiirl;
1453       SETs(boolSV(left <= right));
1454       RETURN;
1455     }
1456 }
1457
1458 PP(pp_i_ge)
1459 {
1460     djSP; tryAMAGICbinSET(ge,0);
1461     {
1462       dPOPTOPiirl;
1463       SETs(boolSV(left >= right));
1464       RETURN;
1465     }
1466 }
1467
1468 PP(pp_i_eq)
1469 {
1470     djSP; tryAMAGICbinSET(eq,0);
1471     {
1472       dPOPTOPiirl;
1473       SETs(boolSV(left == right));
1474       RETURN;
1475     }
1476 }
1477
1478 PP(pp_i_ne)
1479 {
1480     djSP; tryAMAGICbinSET(ne,0);
1481     {
1482       dPOPTOPiirl;
1483       SETs(boolSV(left != right));
1484       RETURN;
1485     }
1486 }
1487
1488 PP(pp_i_ncmp)
1489 {
1490     djSP; dTARGET; tryAMAGICbin(ncmp,0);
1491     {
1492       dPOPTOPiirl;
1493       I32 value;
1494
1495       if (left > right)
1496         value = 1;
1497       else if (left < right)
1498         value = -1;
1499       else
1500         value = 0;
1501       SETi(value);
1502       RETURN;
1503     }
1504 }
1505
1506 PP(pp_i_negate)
1507 {
1508     djSP; dTARGET; tryAMAGICun(neg);
1509     SETi(-TOPi);
1510     RETURN;
1511 }
1512
1513 /* High falutin' math. */
1514
1515 PP(pp_atan2)
1516 {
1517     djSP; dTARGET; tryAMAGICbin(atan2,0);
1518     {
1519       dPOPTOPnnrl;
1520       SETn(atan2(left, right));
1521       RETURN;
1522     }
1523 }
1524
1525 PP(pp_sin)
1526 {
1527     djSP; dTARGET; tryAMAGICun(sin);
1528     {
1529       double value;
1530       value = POPn;
1531       value = sin(value);
1532       XPUSHn(value);
1533       RETURN;
1534     }
1535 }
1536
1537 PP(pp_cos)
1538 {
1539     djSP; dTARGET; tryAMAGICun(cos);
1540     {
1541       double value;
1542       value = POPn;
1543       value = cos(value);
1544       XPUSHn(value);
1545       RETURN;
1546     }
1547 }
1548
1549 PP(pp_rand)
1550 {
1551     djSP; dTARGET;
1552     double value;
1553     if (MAXARG < 1)
1554         value = 1.0;
1555     else
1556         value = POPn;
1557     if (value == 0.0)
1558         value = 1.0;
1559     if (!srand_called) {
1560         (void)srand((unsigned)seed());
1561         srand_called = TRUE;
1562     }
1563 #if RANDBITS == 31
1564     value = rand() * value / 2147483648.0;
1565 #else
1566 #if RANDBITS == 16
1567     value = rand() * value / 65536.0;
1568 #else
1569 #if RANDBITS == 15
1570     value = rand() * value / 32768.0;
1571 #else
1572     value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
1573 #endif
1574 #endif
1575 #endif
1576     XPUSHn(value);
1577     RETURN;
1578 }
1579
1580 PP(pp_srand)
1581 {
1582     djSP;
1583     UV anum;
1584     if (MAXARG < 1)
1585         anum = seed();
1586     else
1587         anum = POPu;
1588     (void)srand((unsigned)anum);
1589     srand_called = TRUE;
1590     EXTEND(SP, 1);
1591     RETPUSHYES;
1592 }
1593
1594 static U32
1595 seed(void)
1596 {
1597     /*
1598      * This is really just a quick hack which grabs various garbage
1599      * values.  It really should be a real hash algorithm which
1600      * spreads the effect of every input bit onto every output bit,
1601      * if someone who knows about such tings would bother to write it.
1602      * Might be a good idea to add that function to CORE as well.
1603      * No numbers below come from careful analysis or anyting here,
1604      * except they are primes and SEED_C1 > 1E6 to get a full-width
1605      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
1606      * probably be bigger too.
1607      */
1608 #if RANDBITS > 16
1609 #  define SEED_C1       1000003
1610 #define   SEED_C4       73819
1611 #else
1612 #  define SEED_C1       25747
1613 #define   SEED_C4       20639
1614 #endif
1615 #define   SEED_C2       3
1616 #define   SEED_C3       269
1617 #define   SEED_C5       26107
1618
1619     dTHR;
1620     U32 u;
1621 #ifdef VMS
1622 #  include <starlet.h>
1623     /* when[] = (low 32 bits, high 32 bits) of time since epoch
1624      * in 100-ns units, typically incremented ever 10 ms.        */
1625     unsigned int when[2];
1626     _ckvmssts(sys$gettim(when));
1627     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
1628 #else
1629 #  ifdef HAS_GETTIMEOFDAY
1630     struct timeval when;
1631     gettimeofday(&when,(struct timezone *) 0);
1632     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
1633 #  else
1634     Time_t when;
1635     (void)time(&when);
1636     u = (U32)SEED_C1 * when;
1637 #  endif
1638 #endif
1639     u += SEED_C3 * (U32)getpid();
1640     u += SEED_C4 * (U32)(UV)stack_sp;
1641 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
1642     u += SEED_C5 * (U32)(UV)&when;
1643 #endif
1644     return u;
1645 }
1646
1647 PP(pp_exp)
1648 {
1649     djSP; dTARGET; tryAMAGICun(exp);
1650     {
1651       double value;
1652       value = POPn;
1653       value = exp(value);
1654       XPUSHn(value);
1655       RETURN;
1656     }
1657 }
1658
1659 PP(pp_log)
1660 {
1661     djSP; dTARGET; tryAMAGICun(log);
1662     {
1663       double value;
1664       value = POPn;
1665       if (value <= 0.0) {
1666         SET_NUMERIC_STANDARD();
1667         DIE("Can't take log of %g", value);
1668       }
1669       value = log(value);
1670       XPUSHn(value);
1671       RETURN;
1672     }
1673 }
1674
1675 PP(pp_sqrt)
1676 {
1677     djSP; dTARGET; tryAMAGICun(sqrt);
1678     {
1679       double value;
1680       value = POPn;
1681       if (value < 0.0) {
1682         SET_NUMERIC_STANDARD();
1683         DIE("Can't take sqrt of %g", value);
1684       }
1685       value = sqrt(value);
1686       XPUSHn(value);
1687       RETURN;
1688     }
1689 }
1690
1691 PP(pp_int)
1692 {
1693     djSP; dTARGET;
1694     {
1695       double value = TOPn;
1696       IV iv;
1697
1698       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1699         iv = SvIVX(TOPs);
1700         SETi(iv);
1701       }
1702       else {
1703         if (value >= 0.0)
1704           (void)modf(value, &value);
1705         else {
1706           (void)modf(-value, &value);
1707           value = -value;
1708         }
1709         iv = I_V(value);
1710         if (iv == value)
1711           SETi(iv);
1712         else
1713           SETn(value);
1714       }
1715     }
1716     RETURN;
1717 }
1718
1719 PP(pp_abs)
1720 {
1721     djSP; dTARGET; tryAMAGICun(abs);
1722     {
1723       double value = TOPn;
1724       IV iv;
1725
1726       if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1727           (iv = SvIVX(TOPs)) != IV_MIN) {
1728         if (iv < 0)
1729           iv = -iv;
1730         SETi(iv);
1731       }
1732       else {
1733         if (value < 0.0)
1734             value = -value;
1735         SETn(value);
1736       }
1737     }
1738     RETURN;
1739 }
1740
1741 PP(pp_hex)
1742 {
1743     djSP; dTARGET;
1744     char *tmps;
1745     I32 argtype;
1746
1747     tmps = POPp;
1748     XPUSHu(scan_hex(tmps, 99, &argtype));
1749     RETURN;
1750 }
1751
1752 PP(pp_oct)
1753 {
1754     djSP; dTARGET;
1755     UV value;
1756     I32 argtype;
1757     char *tmps;
1758
1759     tmps = POPp;
1760     while (*tmps && isSPACE(*tmps))
1761         tmps++;
1762     if (*tmps == '0')
1763         tmps++;
1764     if (*tmps == 'x')
1765         value = scan_hex(++tmps, 99, &argtype);
1766     else
1767         value = scan_oct(tmps, 99, &argtype);
1768     XPUSHu(value);
1769     RETURN;
1770 }
1771
1772 /* String stuff. */
1773
1774 PP(pp_length)
1775 {
1776     djSP; dTARGET;
1777     SETi( sv_len(TOPs) );
1778     RETURN;
1779 }
1780
1781 PP(pp_substr)
1782 {
1783     djSP; dTARGET;
1784     SV *sv;
1785     I32 len;
1786     STRLEN curlen;
1787     I32 pos;
1788     I32 rem;
1789     I32 fail;
1790     I32 lvalue = op->op_flags & OPf_MOD;
1791     char *tmps;
1792     I32 arybase = curcop->cop_arybase;
1793
1794     SvTAINTED_off(TARG);                        /* decontaminate */
1795     if (MAXARG > 2)
1796         len = POPi;
1797     pos = POPi;
1798     sv = POPs;
1799     PUTBACK;
1800     tmps = SvPV(sv, curlen);
1801     if (pos >= arybase) {
1802         pos -= arybase;
1803         rem = curlen-pos;
1804         fail = rem;
1805         if (MAXARG > 2) {
1806             if (len < 0) {
1807                 rem += len;
1808                 if (rem < 0)
1809                     rem = 0;
1810             }
1811             else if (rem > len)
1812                      rem = len;
1813         }
1814     }
1815     else {
1816         pos += curlen;
1817         if (MAXARG < 3)
1818             rem = curlen;
1819         else if (len >= 0) {
1820             rem = pos+len;
1821             if (rem > (I32)curlen)
1822                 rem = curlen;
1823         }
1824         else {
1825             rem = curlen+len;
1826             if (rem < pos)
1827                 rem = pos;
1828         }
1829         if (pos < 0)
1830             pos = 0;
1831         fail = rem;
1832         rem -= pos;
1833     }
1834     if (fail < 0) {
1835         if (dowarn || lvalue)
1836             warn("substr outside of string");
1837         RETPUSHUNDEF;
1838     }
1839     else {
1840         tmps += pos;
1841         sv_setpvn(TARG, tmps, rem);
1842         if (lvalue) {                   /* it's an lvalue! */
1843             if (!SvGMAGICAL(sv)) {
1844                 if (SvROK(sv)) {
1845                     SvPV_force(sv,na);
1846                     if (dowarn)
1847                         warn("Attempt to use reference as lvalue in substr");
1848                 }
1849                 if (SvOK(sv))           /* is it defined ? */
1850                     (void)SvPOK_only(sv);
1851                 else
1852                     sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
1853             }
1854
1855             if (SvTYPE(TARG) < SVt_PVLV) {
1856                 sv_upgrade(TARG, SVt_PVLV);
1857                 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
1858             }
1859
1860             LvTYPE(TARG) = 'x';
1861             LvTARG(TARG) = sv;
1862             LvTARGOFF(TARG) = pos;
1863             LvTARGLEN(TARG) = rem;
1864         }
1865     }
1866     SPAGAIN;
1867     PUSHs(TARG);                /* avoid SvSETMAGIC here */
1868     RETURN;
1869 }
1870
1871 PP(pp_vec)
1872 {
1873     djSP; dTARGET;
1874     register I32 size = POPi;
1875     register I32 offset = POPi;
1876     register SV *src = POPs;
1877     I32 lvalue = op->op_flags & OPf_MOD;
1878     STRLEN srclen;
1879     unsigned char *s = (unsigned char*)SvPV(src, srclen);
1880     unsigned long retnum;
1881     I32 len;
1882
1883     SvTAINTED_off(TARG);                        /* decontaminate */
1884     offset *= size;             /* turn into bit offset */
1885     len = (offset + size + 7) / 8;
1886     if (offset < 0 || size < 1)
1887         retnum = 0;
1888     else {
1889         if (lvalue) {                      /* it's an lvalue! */
1890             if (SvTYPE(TARG) < SVt_PVLV) {
1891                 sv_upgrade(TARG, SVt_PVLV);
1892                 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
1893             }
1894
1895             LvTYPE(TARG) = 'v';
1896             LvTARG(TARG) = src;
1897             LvTARGOFF(TARG) = offset;
1898             LvTARGLEN(TARG) = size;
1899         }
1900         if (len > srclen) {
1901             if (size <= 8)
1902                 retnum = 0;
1903             else {
1904                 offset >>= 3;
1905                 if (size == 16) {
1906                     if (offset >= srclen)
1907                         retnum = 0;
1908                     else
1909                         retnum = (unsigned long) s[offset] << 8;
1910                 }
1911                 else if (size == 32) {
1912                     if (offset >= srclen)
1913                         retnum = 0;
1914                     else if (offset + 1 >= srclen)
1915                         retnum = (unsigned long) s[offset] << 24;
1916                     else if (offset + 2 >= srclen)
1917                         retnum = ((unsigned long) s[offset] << 24) +
1918                             ((unsigned long) s[offset + 1] << 16);
1919                     else
1920                         retnum = ((unsigned long) s[offset] << 24) +
1921                             ((unsigned long) s[offset + 1] << 16) +
1922                             (s[offset + 2] << 8);
1923                 }
1924             }
1925         }
1926         else if (size < 8)
1927             retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1928         else {
1929             offset >>= 3;
1930             if (size == 8)
1931                 retnum = s[offset];
1932             else if (size == 16)
1933                 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1934             else if (size == 32)
1935                 retnum = ((unsigned long) s[offset] << 24) +
1936                         ((unsigned long) s[offset + 1] << 16) +
1937                         (s[offset + 2] << 8) + s[offset+3];
1938         }
1939     }
1940
1941     sv_setuv(TARG, (UV)retnum);
1942     PUSHs(TARG);
1943     RETURN;
1944 }
1945
1946 PP(pp_index)
1947 {
1948     djSP; dTARGET;
1949     SV *big;
1950     SV *little;
1951     I32 offset;
1952     I32 retval;
1953     char *tmps;
1954     char *tmps2;
1955     STRLEN biglen;
1956     I32 arybase = curcop->cop_arybase;
1957
1958     if (MAXARG < 3)
1959         offset = 0;
1960     else
1961         offset = POPi - arybase;
1962     little = POPs;
1963     big = POPs;
1964     tmps = SvPV(big, biglen);
1965     if (offset < 0)
1966         offset = 0;
1967     else if (offset > biglen)
1968         offset = biglen;
1969     if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
1970       (unsigned char*)tmps + biglen, little)))
1971         retval = -1 + arybase;
1972     else
1973         retval = tmps2 - tmps + arybase;
1974     PUSHi(retval);
1975     RETURN;
1976 }
1977
1978 PP(pp_rindex)
1979 {
1980     djSP; dTARGET;
1981     SV *big;
1982     SV *little;
1983     STRLEN blen;
1984     STRLEN llen;
1985     SV *offstr;
1986     I32 offset;
1987     I32 retval;
1988     char *tmps;
1989     char *tmps2;
1990     I32 arybase = curcop->cop_arybase;
1991
1992     if (MAXARG >= 3)
1993         offstr = POPs;
1994     little = POPs;
1995     big = POPs;
1996     tmps2 = SvPV(little, llen);
1997     tmps = SvPV(big, blen);
1998     if (MAXARG < 3)
1999         offset = blen;
2000     else
2001         offset = SvIV(offstr) - arybase + llen;
2002     if (offset < 0)
2003         offset = 0;
2004     else if (offset > blen)
2005         offset = blen;
2006     if (!(tmps2 = rninstr(tmps,  tmps  + offset,
2007                           tmps2, tmps2 + llen)))
2008         retval = -1 + arybase;
2009     else
2010         retval = tmps2 - tmps + arybase;
2011     PUSHi(retval);
2012     RETURN;
2013 }
2014
2015 PP(pp_sprintf)
2016 {
2017     djSP; dMARK; dORIGMARK; dTARGET;
2018 #ifdef USE_LOCALE_NUMERIC
2019     if (op->op_private & OPpLOCALE)
2020         SET_NUMERIC_LOCAL();
2021     else
2022         SET_NUMERIC_STANDARD();
2023 #endif
2024     do_sprintf(TARG, SP-MARK, MARK+1);
2025     TAINT_IF(SvTAINTED(TARG));
2026     SP = ORIGMARK;
2027     PUSHTARG;
2028     RETURN;
2029 }
2030
2031 PP(pp_ord)
2032 {
2033     djSP; dTARGET;
2034     I32 value;
2035     char *tmps;
2036
2037 #ifndef I286
2038     tmps = POPp;
2039     value = (I32) (*tmps & 255);
2040 #else
2041     I32 anum;
2042     tmps = POPp;
2043     anum = (I32) *tmps;
2044     value = (I32) (anum & 255);
2045 #endif
2046     XPUSHi(value);
2047     RETURN;
2048 }
2049
2050 PP(pp_chr)
2051 {
2052     djSP; dTARGET;
2053     char *tmps;
2054
2055     (void)SvUPGRADE(TARG,SVt_PV);
2056     SvGROW(TARG,2);
2057     SvCUR_set(TARG, 1);
2058     tmps = SvPVX(TARG);
2059     *tmps++ = POPi;
2060     *tmps = '\0';
2061     (void)SvPOK_only(TARG);
2062     XPUSHs(TARG);
2063     RETURN;
2064 }
2065
2066 PP(pp_crypt)
2067 {
2068     djSP; dTARGET; dPOPTOPssrl;
2069 #ifdef HAS_CRYPT
2070     char *tmps = SvPV(left, na);
2071 #ifdef FCRYPT
2072     sv_setpv(TARG, fcrypt(tmps, SvPV(right, na)));
2073 #else
2074     sv_setpv(TARG, crypt(tmps, SvPV(right, na)));
2075 #endif
2076 #else
2077     DIE(
2078       "The crypt() function is unimplemented due to excessive paranoia.");
2079 #endif
2080     SETs(TARG);
2081     RETURN;
2082 }
2083
2084 PP(pp_ucfirst)
2085 {
2086     djSP;
2087     SV *sv = TOPs;
2088     register char *s;
2089
2090     if (!SvPADTMP(sv)) {
2091         dTARGET;
2092         sv_setsv(TARG, sv);
2093         sv = TARG;
2094         SETs(sv);
2095     }
2096     s = SvPV_force(sv, na);
2097     if (*s) {
2098         if (op->op_private & OPpLOCALE) {
2099             TAINT;
2100             SvTAINTED_on(sv);
2101             *s = toUPPER_LC(*s);
2102         }
2103         else
2104             *s = toUPPER(*s);
2105     }
2106
2107     RETURN;
2108 }
2109
2110 PP(pp_lcfirst)
2111 {
2112     djSP;
2113     SV *sv = TOPs;
2114     register char *s;
2115
2116     if (!SvPADTMP(sv)) {
2117         dTARGET;
2118         sv_setsv(TARG, sv);
2119         sv = TARG;
2120         SETs(sv);
2121     }
2122     s = SvPV_force(sv, na);
2123     if (*s) {
2124         if (op->op_private & OPpLOCALE) {
2125             TAINT;
2126             SvTAINTED_on(sv);
2127             *s = toLOWER_LC(*s);
2128         }
2129         else
2130             *s = toLOWER(*s);
2131     }
2132
2133     SETs(sv);
2134     RETURN;
2135 }
2136
2137 PP(pp_uc)
2138 {
2139     djSP;
2140     SV *sv = TOPs;
2141     register char *s;
2142     STRLEN len;
2143
2144     if (!SvPADTMP(sv)) {
2145         dTARGET;
2146         sv_setsv(TARG, sv);
2147         sv = TARG;
2148         SETs(sv);
2149     }
2150
2151     s = SvPV_force(sv, len);
2152     if (len) {
2153         register char *send = s + len;
2154
2155         if (op->op_private & OPpLOCALE) {
2156             TAINT;
2157             SvTAINTED_on(sv);
2158             for (; s < send; s++)
2159                 *s = toUPPER_LC(*s);
2160         }
2161         else {
2162             for (; s < send; s++)
2163                 *s = toUPPER(*s);
2164         }
2165     }
2166     RETURN;
2167 }
2168
2169 PP(pp_lc)
2170 {
2171     djSP;
2172     SV *sv = TOPs;
2173     register char *s;
2174     STRLEN len;
2175
2176     if (!SvPADTMP(sv)) {
2177         dTARGET;
2178         sv_setsv(TARG, sv);
2179         sv = TARG;
2180         SETs(sv);
2181     }
2182
2183     s = SvPV_force(sv, len);
2184     if (len) {
2185         register char *send = s + len;
2186
2187         if (op->op_private & OPpLOCALE) {
2188             TAINT;
2189             SvTAINTED_on(sv);
2190             for (; s < send; s++)
2191                 *s = toLOWER_LC(*s);
2192         }
2193         else {
2194             for (; s < send; s++)
2195                 *s = toLOWER(*s);
2196         }
2197     }
2198     RETURN;
2199 }
2200
2201 PP(pp_quotemeta)
2202 {
2203     djSP; dTARGET;
2204     SV *sv = TOPs;
2205     STRLEN len;
2206     register char *s = SvPV(sv,len);
2207     register char *d;
2208
2209     if (len) {
2210         (void)SvUPGRADE(TARG, SVt_PV);
2211         SvGROW(TARG, (len * 2) + 1);
2212         d = SvPVX(TARG);
2213         while (len--) {
2214             if (!isALNUM(*s))
2215                 *d++ = '\\';
2216             *d++ = *s++;
2217         }
2218         *d = '\0';
2219         SvCUR_set(TARG, d - SvPVX(TARG));
2220         (void)SvPOK_only(TARG);
2221     }
2222     else
2223         sv_setpvn(TARG, s, len);
2224     SETs(TARG);
2225     RETURN;
2226 }
2227
2228 /* Arrays. */
2229
2230 PP(pp_aslice)
2231 {
2232     djSP; dMARK; dORIGMARK;
2233     register SV** svp;
2234     register AV* av = (AV*)POPs;
2235     register I32 lval = op->op_flags & OPf_MOD;
2236     I32 arybase = curcop->cop_arybase;
2237     I32 elem;
2238
2239     if (SvTYPE(av) == SVt_PVAV) {
2240         if (lval && op->op_private & OPpLVAL_INTRO) {
2241             I32 max = -1;
2242             for (svp = MARK + 1; svp <= SP; svp++) {
2243                 elem = SvIVx(*svp);
2244                 if (elem > max)
2245                     max = elem;
2246             }
2247             if (max > AvMAX(av))
2248                 av_extend(av, max);
2249         }
2250         while (++MARK <= SP) {
2251             elem = SvIVx(*MARK);
2252
2253             if (elem > 0)
2254                 elem -= arybase;
2255             svp = av_fetch(av, elem, lval);
2256             if (lval) {
2257                 if (!svp || *svp == &sv_undef)
2258                     DIE(no_aelem, elem);
2259                 if (op->op_private & OPpLVAL_INTRO)
2260                     save_aelem(av, elem, svp);
2261             }
2262             *MARK = svp ? *svp : &sv_undef;
2263         }
2264     }
2265     if (GIMME != G_ARRAY) {
2266         MARK = ORIGMARK;
2267         *++MARK = *SP;
2268         SP = MARK;
2269     }
2270     RETURN;
2271 }
2272
2273 /* Associative arrays. */
2274
2275 PP(pp_each)
2276 {
2277     djSP; dTARGET;
2278     HV *hash = (HV*)POPs;
2279     HE *entry;
2280     I32 gimme = GIMME_V;
2281     I32 realhv = (SvTYPE(hash) == SVt_PVHV);
2282
2283     PUTBACK;
2284     /* might clobber stack_sp */
2285     entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
2286     SPAGAIN;
2287
2288     EXTEND(SP, 2);
2289     if (entry) {
2290         PUSHs(hv_iterkeysv(entry));     /* won't clobber stack_sp */
2291         if (gimme == G_ARRAY) {
2292             PUTBACK;
2293             /* might clobber stack_sp */
2294             sv_setsv(TARG, realhv ?
2295                      hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
2296             SPAGAIN;
2297             PUSHs(TARG);
2298         }
2299     }
2300     else if (gimme == G_SCALAR)
2301         RETPUSHUNDEF;
2302
2303     RETURN;
2304 }
2305
2306 PP(pp_values)
2307 {
2308     return do_kv(ARGS);
2309 }
2310
2311 PP(pp_keys)
2312 {
2313     return do_kv(ARGS);
2314 }
2315
2316 PP(pp_delete)
2317 {
2318     djSP;
2319     I32 gimme = GIMME_V;
2320     I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
2321     SV *sv;
2322     HV *hv;
2323
2324     if (op->op_private & OPpSLICE) {
2325         dMARK; dORIGMARK;
2326         U32 hvtype;
2327         hv = (HV*)POPs;
2328         hvtype = SvTYPE(hv);
2329         while (++MARK <= SP) {
2330             if (hvtype == SVt_PVHV)
2331                 sv = hv_delete_ent(hv, *MARK, discard, 0);
2332             else if (hvtype == SVt_PVAV)
2333                 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2334             else
2335                 DIE("Not a HASH reference");
2336             *MARK = sv ? sv : &sv_undef;
2337         }
2338         if (discard)
2339             SP = ORIGMARK;
2340         else if (gimme == G_SCALAR) {
2341             MARK = ORIGMARK;
2342             *++MARK = *SP;
2343             SP = MARK;
2344         }
2345     }
2346     else {
2347         SV *keysv = POPs;
2348         hv = (HV*)POPs;
2349         if (SvTYPE(hv) == SVt_PVHV)
2350             sv = hv_delete_ent(hv, keysv, discard, 0);
2351         else if (SvTYPE(hv) == SVt_PVAV)
2352             sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2353         else
2354             DIE("Not a HASH reference");
2355         if (!sv)
2356             sv = &sv_undef;
2357         if (!discard)
2358             PUSHs(sv);
2359     }
2360     RETURN;
2361 }
2362
2363 PP(pp_exists)
2364 {
2365     djSP;
2366     SV *tmpsv = POPs;
2367     HV *hv = (HV*)POPs;
2368     if (SvTYPE(hv) == SVt_PVHV) {
2369         if (hv_exists_ent(hv, tmpsv, 0))
2370             RETPUSHYES;
2371     } else if (SvTYPE(hv) == SVt_PVAV) {
2372         if (avhv_exists_ent((AV*)hv, tmpsv, 0))
2373             RETPUSHYES;
2374     } else {
2375         DIE("Not a HASH reference");
2376     }
2377     RETPUSHNO;
2378 }
2379
2380 PP(pp_hslice)
2381 {
2382     djSP; dMARK; dORIGMARK;
2383     register HE *he;
2384     register HV *hv = (HV*)POPs;
2385     register I32 lval = op->op_flags & OPf_MOD;
2386     I32 realhv = (SvTYPE(hv) == SVt_PVHV);
2387
2388     if (realhv || SvTYPE(hv) == SVt_PVAV) {
2389         while (++MARK <= SP) {
2390             SV *keysv = *MARK;
2391             SV **svp;
2392             if (realhv) {
2393                 he = hv_fetch_ent(hv, keysv, lval, 0);
2394                 svp = he ? &HeVAL(he) : 0;
2395             } else {
2396                 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
2397             }
2398             if (lval) {
2399                 if (!he || HeVAL(he) == &sv_undef)
2400                     DIE(no_helem, SvPV(keysv, na));
2401                 if (op->op_private & OPpLVAL_INTRO)
2402                     save_helem(hv, keysv, &HeVAL(he));
2403             }
2404             *MARK = he ? HeVAL(he) : &sv_undef;
2405         }
2406     }
2407     if (GIMME != G_ARRAY) {
2408         MARK = ORIGMARK;
2409         *++MARK = *SP;
2410         SP = MARK;
2411     }
2412     RETURN;
2413 }
2414
2415 /* List operators. */
2416
2417 PP(pp_list)
2418 {
2419     djSP; dMARK;
2420     if (GIMME != G_ARRAY) {
2421         if (++MARK <= SP)
2422             *MARK = *SP;                /* unwanted list, return last item */
2423         else
2424             *MARK = &sv_undef;
2425         SP = MARK;
2426     }
2427     RETURN;
2428 }
2429
2430 PP(pp_lslice)
2431 {
2432     djSP;
2433     SV **lastrelem = stack_sp;
2434     SV **lastlelem = stack_base + POPMARK;
2435     SV **firstlelem = stack_base + POPMARK + 1;
2436     register SV **firstrelem = lastlelem + 1;
2437     I32 arybase = curcop->cop_arybase;
2438     I32 lval = op->op_flags & OPf_MOD;
2439     I32 is_something_there = lval;
2440
2441     register I32 max = lastrelem - lastlelem;
2442     register SV **lelem;
2443     register I32 ix;
2444
2445     if (GIMME != G_ARRAY) {
2446         ix = SvIVx(*lastlelem);
2447         if (ix < 0)
2448             ix += max;
2449         else
2450             ix -= arybase;
2451         if (ix < 0 || ix >= max)
2452             *firstlelem = &sv_undef;
2453         else
2454             *firstlelem = firstrelem[ix];
2455         SP = firstlelem;
2456         RETURN;
2457     }
2458
2459     if (max == 0) {
2460         SP = firstlelem - 1;
2461         RETURN;
2462     }
2463
2464     for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
2465         ix = SvIVx(*lelem);
2466         if (ix < 0) {
2467             ix += max;
2468             if (ix < 0)
2469                 *lelem = &sv_undef;
2470             else if (!(*lelem = firstrelem[ix]))
2471                 *lelem = &sv_undef;
2472         }
2473         else {
2474             ix -= arybase;
2475             if (ix >= max || !(*lelem = firstrelem[ix]))
2476                 *lelem = &sv_undef;
2477         }
2478         if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
2479             is_something_there = TRUE;
2480     }
2481     if (is_something_there)
2482         SP = lastlelem;
2483     else
2484         SP = firstlelem - 1;
2485     RETURN;
2486 }
2487
2488 PP(pp_anonlist)
2489 {
2490     djSP; dMARK; dORIGMARK;
2491     I32 items = SP - MARK;
2492     SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2493     SP = ORIGMARK;              /* av_make() might realloc stack_sp */
2494     XPUSHs(av);
2495     RETURN;
2496 }
2497
2498 PP(pp_anonhash)
2499 {
2500     djSP; dMARK; dORIGMARK;
2501     HV* hv = (HV*)sv_2mortal((SV*)newHV());
2502
2503     while (MARK < SP) {
2504         SV* key = *++MARK;
2505         SV *val = NEWSV(46, 0);
2506         if (MARK < SP)
2507             sv_setsv(val, *++MARK);
2508         else if (dowarn)
2509             warn("Odd number of elements in hash assignment");
2510         (void)hv_store_ent(hv,key,val,0);
2511     }
2512     SP = ORIGMARK;
2513     XPUSHs((SV*)hv);
2514     RETURN;
2515 }
2516
2517 PP(pp_splice)
2518 {
2519     djSP; dMARK; dORIGMARK;
2520     register AV *ary = (AV*)*++MARK;
2521     register SV **src;
2522     register SV **dst;
2523     register I32 i;
2524     register I32 offset;
2525     register I32 length;
2526     I32 newlen;
2527     I32 after;
2528     I32 diff;
2529     SV **tmparyval = 0;
2530     MAGIC *mg;
2531
2532     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2533         *MARK-- = mg->mg_obj;
2534         PUSHMARK(MARK);
2535         PUTBACK;
2536         ENTER;
2537         perl_call_method("SPLICE",GIMME_V);
2538         LEAVE;
2539         SPAGAIN;
2540         RETURN;
2541     }
2542
2543     SP++;
2544
2545     if (++MARK < SP) {
2546         offset = i = SvIVx(*MARK);
2547         if (offset < 0)
2548             offset += AvFILLp(ary) + 1;
2549         else
2550             offset -= curcop->cop_arybase;
2551         if (offset < 0)
2552             DIE(no_aelem, i);
2553         if (++MARK < SP) {
2554             length = SvIVx(*MARK++);
2555             if (length < 0)
2556                 length = 0;
2557         }
2558         else
2559             length = AvMAX(ary) + 1;            /* close enough to infinity */
2560     }
2561     else {
2562         offset = 0;
2563         length = AvMAX(ary) + 1;
2564     }
2565     if (offset > AvFILLp(ary) + 1)
2566         offset = AvFILLp(ary) + 1;
2567     after = AvFILLp(ary) + 1 - (offset + length);
2568     if (after < 0) {                            /* not that much array */
2569         length += after;                        /* offset+length now in array */
2570         after = 0;
2571         if (!AvALLOC(ary))
2572             av_extend(ary, 0);
2573     }
2574
2575     /* At this point, MARK .. SP-1 is our new LIST */
2576
2577     newlen = SP - MARK;
2578     diff = newlen - length;
2579     if (newlen && !AvREAL(ary)) {
2580         if (AvREIFY(ary))
2581             av_reify(ary);
2582         else
2583             assert(AvREAL(ary));                /* would leak, so croak */
2584     }
2585
2586     if (diff < 0) {                             /* shrinking the area */
2587         if (newlen) {
2588             New(451, tmparyval, newlen, SV*);   /* so remember insertion */
2589             Copy(MARK, tmparyval, newlen, SV*);
2590         }
2591
2592         MARK = ORIGMARK + 1;
2593         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2594             MEXTEND(MARK, length);
2595             Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2596             if (AvREAL(ary)) {
2597                 EXTEND_MORTAL(length);
2598                 for (i = length, dst = MARK; i; i--) {
2599                     if (!SvIMMORTAL(*dst))
2600                         sv_2mortal(*dst);       /* free them eventualy */
2601                     dst++;
2602                 }
2603             }
2604             MARK += length - 1;
2605         }
2606         else {
2607             *MARK = AvARRAY(ary)[offset+length-1];
2608             if (AvREAL(ary)) {
2609                 if (!SvIMMORTAL(*MARK))
2610                     sv_2mortal(*MARK);
2611                 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2612                     SvREFCNT_dec(*dst++);       /* free them now */
2613             }
2614         }
2615         AvFILLp(ary) += diff;
2616
2617         /* pull up or down? */
2618
2619         if (offset < after) {                   /* easier to pull up */
2620             if (offset) {                       /* esp. if nothing to pull */
2621                 src = &AvARRAY(ary)[offset-1];
2622                 dst = src - diff;               /* diff is negative */
2623                 for (i = offset; i > 0; i--)    /* can't trust Copy */
2624                     *dst-- = *src--;
2625             }
2626             dst = AvARRAY(ary);
2627             SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2628             AvMAX(ary) += diff;
2629         }
2630         else {
2631             if (after) {                        /* anything to pull down? */
2632                 src = AvARRAY(ary) + offset + length;
2633                 dst = src + diff;               /* diff is negative */
2634                 Move(src, dst, after, SV*);
2635             }
2636             dst = &AvARRAY(ary)[AvFILLp(ary)+1];
2637                                                 /* avoid later double free */
2638         }
2639         i = -diff;
2640         while (i)
2641             dst[--i] = &sv_undef;
2642
2643         if (newlen) {
2644             for (src = tmparyval, dst = AvARRAY(ary) + offset;
2645               newlen; newlen--) {
2646                 *dst = NEWSV(46, 0);
2647                 sv_setsv(*dst++, *src++);
2648             }
2649             Safefree(tmparyval);
2650         }
2651     }
2652     else {                                      /* no, expanding (or same) */
2653         if (length) {
2654             New(452, tmparyval, length, SV*);   /* so remember deletion */
2655             Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
2656         }
2657
2658         if (diff > 0) {                         /* expanding */
2659
2660             /* push up or down? */
2661
2662             if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
2663                 if (offset) {
2664                     src = AvARRAY(ary);
2665                     dst = src - diff;
2666                     Move(src, dst, offset, SV*);
2667                 }
2668                 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
2669                 AvMAX(ary) += diff;
2670                 AvFILLp(ary) += diff;
2671             }
2672             else {
2673                 if (AvFILLp(ary) + diff >= AvMAX(ary))  /* oh, well */
2674                     av_extend(ary, AvFILLp(ary) + diff);
2675                 AvFILLp(ary) += diff;
2676
2677                 if (after) {
2678                     dst = AvARRAY(ary) + AvFILLp(ary);
2679                     src = dst - diff;
2680                     for (i = after; i; i--) {
2681                         *dst-- = *src--;
2682                     }
2683                 }
2684             }
2685         }
2686
2687         for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
2688             *dst = NEWSV(46, 0);
2689             sv_setsv(*dst++, *src++);
2690         }
2691         MARK = ORIGMARK + 1;
2692         if (GIMME == G_ARRAY) {                 /* copy return vals to stack */
2693             if (length) {
2694                 Copy(tmparyval, MARK, length, SV*);
2695                 if (AvREAL(ary)) {
2696                     EXTEND_MORTAL(length);
2697                     for (i = length, dst = MARK; i; i--) {
2698                         if (!SvIMMORTAL(*dst))
2699                             sv_2mortal(*dst);   /* free them eventualy */
2700                         dst++;
2701                     }
2702                 }
2703                 Safefree(tmparyval);
2704             }
2705             MARK += length - 1;
2706         }
2707         else if (length--) {
2708             *MARK = tmparyval[length];
2709             if (AvREAL(ary)) {
2710                 if (!SvIMMORTAL(*MARK))
2711                     sv_2mortal(*MARK);
2712                 while (length-- > 0)
2713                     SvREFCNT_dec(tmparyval[length]);
2714             }
2715             Safefree(tmparyval);
2716         }
2717         else
2718             *MARK = &sv_undef;
2719     }
2720     SP = MARK;
2721     RETURN;
2722 }
2723
2724 PP(pp_push)
2725 {
2726     djSP; dMARK; dORIGMARK; dTARGET;
2727     register AV *ary = (AV*)*++MARK;
2728     register SV *sv = &sv_undef;
2729     MAGIC *mg;
2730
2731     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2732         *MARK-- = mg->mg_obj;
2733         PUSHMARK(MARK);
2734         PUTBACK;
2735         ENTER;
2736         perl_call_method("PUSH",G_SCALAR|G_DISCARD);
2737         LEAVE;
2738         SPAGAIN;
2739     }
2740     else {
2741         /* Why no pre-extend of ary here ? */
2742         for (++MARK; MARK <= SP; MARK++) {
2743             sv = NEWSV(51, 0);
2744             if (*MARK)
2745                 sv_setsv(sv, *MARK);
2746             av_push(ary, sv);
2747         }
2748     }
2749     SP = ORIGMARK;
2750     PUSHi( AvFILL(ary) + 1 );
2751     RETURN;
2752 }
2753
2754 PP(pp_pop)
2755 {
2756     djSP;
2757     AV *av = (AV*)POPs;
2758     SV *sv = av_pop(av);
2759     if (!SvIMMORTAL(sv) && AvREAL(av))
2760         (void)sv_2mortal(sv);
2761     PUSHs(sv);
2762     RETURN;
2763 }
2764
2765 PP(pp_shift)
2766 {
2767     djSP;
2768     AV *av = (AV*)POPs;
2769     SV *sv = av_shift(av);
2770     EXTEND(SP, 1);
2771     if (!sv)
2772         RETPUSHUNDEF;
2773     if (!SvIMMORTAL(sv) && AvREAL(av))
2774         (void)sv_2mortal(sv);
2775     PUSHs(sv);
2776     RETURN;
2777 }
2778
2779 PP(pp_unshift)
2780 {
2781     djSP; dMARK; dORIGMARK; dTARGET;
2782     register AV *ary = (AV*)*++MARK;
2783     register SV *sv;
2784     register I32 i = 0;
2785     MAGIC *mg;
2786
2787     if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
2788         *MARK-- = mg->mg_obj;
2789         PUSHMARK(MARK);
2790         PUTBACK;
2791         ENTER;
2792         perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
2793         LEAVE;
2794         SPAGAIN;
2795     }
2796     else {
2797         av_unshift(ary, SP - MARK);
2798         while (MARK < SP) {
2799             sv = NEWSV(27, 0);
2800             sv_setsv(sv, *++MARK);
2801             (void)av_store(ary, i++, sv);
2802         }
2803     }
2804     SP = ORIGMARK;
2805     PUSHi( AvFILL(ary) + 1 );
2806     RETURN;
2807 }
2808
2809 PP(pp_reverse)
2810 {
2811     djSP; dMARK;
2812     register SV *tmp;
2813     SV **oldsp = SP;
2814
2815     if (GIMME == G_ARRAY) {
2816         MARK++;
2817         while (MARK < SP) {
2818             tmp = *MARK;
2819             *MARK++ = *SP;
2820             *SP-- = tmp;
2821         }
2822         SP = oldsp;
2823     }
2824     else {
2825         register char *up;
2826         register char *down;
2827         register I32 tmp;
2828         dTARGET;
2829         STRLEN len;
2830
2831         if (SP - MARK > 1)
2832             do_join(TARG, &sv_no, MARK, SP);
2833         else
2834             sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
2835         up = SvPV_force(TARG, len);
2836         if (len > 1) {
2837             down = SvPVX(TARG) + len - 1;
2838             while (down > up) {
2839                 tmp = *up;
2840                 *up++ = *down;
2841                 *down-- = tmp;
2842             }
2843             (void)SvPOK_only(TARG);
2844         }
2845         SP = MARK + 1;
2846         SETTARG;
2847     }
2848     RETURN;
2849 }
2850
2851 static SV      *
2852 mul128(SV *sv, U8 m)
2853 {
2854   STRLEN          len;
2855   char           *s = SvPV(sv, len);
2856   char           *t;
2857   U32             i = 0;
2858
2859   if (!strnEQ(s, "0000", 4)) {  /* need to grow sv */
2860     SV             *tmpNew = newSVpv("0000000000", 10);
2861
2862     sv_catsv(tmpNew, sv);
2863     SvREFCNT_dec(sv);           /* free old sv */
2864     sv = tmpNew;
2865     s = SvPV(sv, len);
2866   }
2867   t = s + len - 1;
2868   while (!*t)                   /* trailing '\0'? */
2869     t--;
2870   while (t > s) {
2871     i = ((*t - '0') << 7) + m;
2872     *(t--) = '0' + (i % 10);
2873     m = i / 10;
2874   }
2875   return (sv);
2876 }
2877
2878 /* Explosives and implosives. */
2879
2880 PP(pp_unpack)
2881 {
2882     djSP;
2883     dPOPPOPssrl;
2884     SV **oldsp = SP;
2885     I32 gimme = GIMME_V;
2886     SV *sv;
2887     STRLEN llen;
2888     STRLEN rlen;
2889     register char *pat = SvPV(left, llen);
2890     register char *s = SvPV(right, rlen);
2891     char *strend = s + rlen;
2892     char *strbeg = s;
2893     register char *patend = pat + llen;
2894     I32 datumtype;
2895     register I32 len;
2896     register I32 bits;
2897
2898     /* These must not be in registers: */
2899     I16 ashort;
2900     int aint;
2901     I32 along;
2902 #ifdef HAS_QUAD
2903     Quad_t aquad;
2904 #endif
2905     U16 aushort;
2906     unsigned int auint;
2907     U32 aulong;
2908 #ifdef HAS_QUAD
2909     unsigned Quad_t auquad;
2910 #endif
2911     char *aptr;
2912     float afloat;
2913     double adouble;
2914     I32 checksum = 0;
2915     register U32 culong;
2916     double cdouble;
2917     static char* bitcount = 0;
2918     int commas = 0;
2919
2920     if (gimme != G_ARRAY) {             /* arrange to do first one only */
2921         /*SUPPRESS 530*/
2922         for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
2923         if (strchr("aAbBhHP", *patend) || *pat == '%') {
2924             patend++;
2925             while (isDIGIT(*patend) || *patend == '*')
2926                 patend++;
2927         }
2928         else
2929             patend++;
2930     }
2931     while (pat < patend) {
2932       reparse:
2933         datumtype = *pat++ & 0xFF;
2934         if (isSPACE(datumtype))
2935             continue;
2936         if (pat >= patend)
2937             len = 1;
2938         else if (*pat == '*') {
2939             len = strend - strbeg;      /* long enough */
2940             pat++;
2941         }
2942         else if (isDIGIT(*pat)) {
2943             len = *pat++ - '0';
2944             while (isDIGIT(*pat))
2945                 len = (len * 10) + (*pat++ - '0');
2946         }
2947         else
2948             len = (datumtype != '@');
2949         switch(datumtype) {
2950         default:
2951             croak("Invalid type in unpack: '%c'", (int)datumtype);
2952         case ',': /* grandfather in commas but with a warning */
2953             if (commas++ == 0 && dowarn)
2954                 warn("Invalid type in unpack: '%c'", (int)datumtype);
2955             break;
2956         case '%':
2957             if (len == 1 && pat[-1] != '1')
2958                 len = 16;
2959             checksum = len;
2960             culong = 0;
2961             cdouble = 0;
2962             if (pat < patend)
2963                 goto reparse;
2964             break;
2965         case '@':
2966             if (len > strend - strbeg)
2967                 DIE("@ outside of string");
2968             s = strbeg + len;
2969             break;
2970         case 'X':
2971             if (len > s - strbeg)
2972                 DIE("X outside of string");
2973             s -= len;
2974             break;
2975         case 'x':
2976             if (len > strend - s)
2977                 DIE("x outside of string");
2978             s += len;
2979             break;
2980         case 'A':
2981         case 'a':
2982             if (len > strend - s)
2983                 len = strend - s;
2984             if (checksum)
2985                 goto uchar_checksum;
2986             sv = NEWSV(35, len);
2987             sv_setpvn(sv, s, len);
2988             s += len;
2989             if (datumtype == 'A') {
2990                 aptr = s;       /* borrow register */
2991                 s = SvPVX(sv) + len - 1;
2992                 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
2993                     s--;
2994                 *++s = '\0';
2995                 SvCUR_set(sv, s - SvPVX(sv));
2996                 s = aptr;       /* unborrow register */
2997             }
2998             XPUSHs(sv_2mortal(sv));
2999             break;
3000         case 'B':
3001         case 'b':
3002             if (pat[-1] == '*' || len > (strend - s) * 8)
3003                 len = (strend - s) * 8;
3004             if (checksum) {
3005                 if (!bitcount) {
3006                     Newz(601, bitcount, 256, char);
3007                     for (bits = 1; bits < 256; bits++) {
3008                         if (bits & 1)   bitcount[bits]++;
3009                         if (bits & 2)   bitcount[bits]++;
3010                         if (bits & 4)   bitcount[bits]++;
3011                         if (bits & 8)   bitcount[bits]++;
3012                         if (bits & 16)  bitcount[bits]++;
3013                         if (bits & 32)  bitcount[bits]++;
3014                         if (bits & 64)  bitcount[bits]++;
3015                         if (bits & 128) bitcount[bits]++;
3016                     }
3017                 }
3018                 while (len >= 8) {
3019                     culong += bitcount[*(unsigned char*)s++];
3020                     len -= 8;
3021                 }
3022                 if (len) {
3023                     bits = *s;
3024                     if (datumtype == 'b') {
3025                         while (len-- > 0) {
3026                             if (bits & 1) culong++;
3027                             bits >>= 1;
3028                         }
3029                     }
3030                     else {
3031                         while (len-- > 0) {
3032                             if (bits & 128) culong++;
3033                             bits <<= 1;
3034                         }
3035                     }
3036                 }
3037                 break;
3038             }
3039             sv = NEWSV(35, len + 1);
3040             SvCUR_set(sv, len);
3041             SvPOK_on(sv);
3042             aptr = pat;                 /* borrow register */
3043             pat = SvPVX(sv);
3044             if (datumtype == 'b') {
3045                 aint = len;
3046                 for (len = 0; len < aint; len++) {
3047                     if (len & 7)                /*SUPPRESS 595*/
3048                         bits >>= 1;
3049                     else
3050                         bits = *s++;
3051                     *pat++ = '0' + (bits & 1);
3052                 }
3053             }
3054             else {
3055                 aint = len;
3056                 for (len = 0; len < aint; len++) {
3057                     if (len & 7)
3058                         bits <<= 1;
3059                     else
3060                         bits = *s++;
3061                     *pat++ = '0' + ((bits & 128) != 0);
3062                 }
3063             }
3064             *pat = '\0';
3065             pat = aptr;                 /* unborrow register */
3066             XPUSHs(sv_2mortal(sv));
3067             break;
3068         case 'H':
3069         case 'h':
3070             if (pat[-1] == '*' || len > (strend - s) * 2)
3071                 len = (strend - s) * 2;
3072             sv = NEWSV(35, len + 1);
3073             SvCUR_set(sv, len);
3074             SvPOK_on(sv);
3075             aptr = pat;                 /* borrow register */
3076             pat = SvPVX(sv);
3077             if (datumtype == 'h') {
3078                 aint = len;
3079                 for (len = 0; len < aint; len++) {
3080                     if (len & 1)
3081                         bits >>= 4;
3082                     else
3083                         bits = *s++;
3084                     *pat++ = hexdigit[bits & 15];
3085                 }
3086             }
3087             else {
3088                 aint = len;
3089                 for (len = 0; len < aint; len++) {
3090                     if (len & 1)
3091                         bits <<= 4;
3092                     else
3093                         bits = *s++;
3094                     *pat++ = hexdigit[(bits >> 4) & 15];
3095                 }
3096             }
3097             *pat = '\0';
3098             pat = aptr;                 /* unborrow register */
3099             XPUSHs(sv_2mortal(sv));
3100             break;
3101         case 'c':
3102             if (len > strend - s)
3103                 len = strend - s;
3104             if (checksum) {
3105                 while (len-- > 0) {
3106                     aint = *s++;
3107                     if (aint >= 128)    /* fake up signed chars */
3108                         aint -= 256;
3109                     culong += aint;
3110                 }
3111             }
3112             else {
3113                 EXTEND(SP, len);
3114                 EXTEND_MORTAL(len);
3115                 while (len-- > 0) {
3116                     aint = *s++;
3117                     if (aint >= 128)    /* fake up signed chars */
3118                         aint -= 256;
3119                     sv = NEWSV(36, 0);
3120                     sv_setiv(sv, (IV)aint);
3121                     PUSHs(sv_2mortal(sv));
3122                 }
3123             }
3124             break;
3125         case 'C':
3126             if (len > strend - s)
3127                 len = strend - s;
3128             if (checksum) {
3129               uchar_checksum:
3130                 while (len-- > 0) {
3131                     auint = *s++ & 255;
3132                     culong += auint;
3133                 }
3134             }
3135             else {
3136                 EXTEND(SP, len);
3137                 EXTEND_MORTAL(len);
3138                 while (len-- > 0) {
3139                     auint = *s++ & 255;
3140                     sv = NEWSV(37, 0);
3141                     sv_setiv(sv, (IV)auint);
3142                     PUSHs(sv_2mortal(sv));
3143                 }
3144             }
3145             break;
3146         case 's':
3147             along = (strend - s) / SIZE16;
3148             if (len > along)
3149                 len = along;
3150             if (checksum) {
3151                 while (len-- > 0) {
3152                     COPY16(s, &ashort);
3153                     s += SIZE16;
3154                     culong += ashort;
3155                 }
3156             }
3157             else {
3158                 EXTEND(SP, len);
3159                 EXTEND_MORTAL(len);
3160                 while (len-- > 0) {
3161                     COPY16(s, &ashort);
3162                     s += SIZE16;
3163                     sv = NEWSV(38, 0);
3164                     sv_setiv(sv, (IV)ashort);
3165                     PUSHs(sv_2mortal(sv));
3166                 }
3167             }
3168             break;
3169         case 'v':
3170         case 'n':
3171         case 'S':
3172             along = (strend - s) / SIZE16;
3173             if (len > along)
3174                 len = along;
3175             if (checksum) {
3176                 while (len-- > 0) {
3177                     COPY16(s, &aushort);
3178                     s += SIZE16;
3179 #ifdef HAS_NTOHS
3180                     if (datumtype == 'n')
3181                         aushort = PerlSock_ntohs(aushort);
3182 #endif
3183 #ifdef HAS_VTOHS
3184                     if (datumtype == 'v')
3185                         aushort = vtohs(aushort);
3186 #endif
3187                     culong += aushort;
3188                 }
3189             }
3190             else {
3191                 EXTEND(SP, len);
3192                 EXTEND_MORTAL(len);
3193                 while (len-- > 0) {
3194                     COPY16(s, &aushort);
3195                     s += SIZE16;
3196                     sv = NEWSV(39, 0);
3197 #ifdef HAS_NTOHS
3198                     if (datumtype == 'n')
3199                         aushort = PerlSock_ntohs(aushort);
3200 #endif
3201 #ifdef HAS_VTOHS
3202                     if (datumtype == 'v')
3203                         aushort = vtohs(aushort);
3204 #endif
3205                     sv_setiv(sv, (IV)aushort);
3206                     PUSHs(sv_2mortal(sv));
3207                 }
3208             }
3209             break;
3210         case 'i':
3211             along = (strend - s) / sizeof(int);
3212             if (len > along)
3213                 len = along;
3214             if (checksum) {
3215                 while (len-- > 0) {
3216                     Copy(s, &aint, 1, int);
3217                     s += sizeof(int);
3218                     if (checksum > 32)
3219                         cdouble += (double)aint;
3220                     else
3221                         culong += aint;
3222                 }
3223             }
3224             else {
3225                 EXTEND(SP, len);
3226                 EXTEND_MORTAL(len);
3227                 while (len-- > 0) {
3228                     Copy(s, &aint, 1, int);
3229                     s += sizeof(int);
3230                     sv = NEWSV(40, 0);
3231 #ifdef __osf__
3232                     /* Without the dummy below unpack("i", pack("i",-1))
3233                      * return 0xFFffFFff instead of -1 for Digital Unix V4.0
3234                      * cc with optimization turned on */
3235                     (aint) ?
3236                         sv_setiv(sv, (IV)aint) :
3237 #endif
3238                     sv_setiv(sv, (IV)aint);
3239                     PUSHs(sv_2mortal(sv));
3240                 }
3241             }
3242             break;
3243         case 'I':
3244             along = (strend - s) / sizeof(unsigned int);
3245             if (len > along)
3246                 len = along;
3247             if (checksum) {
3248                 while (len-- > 0) {
3249                     Copy(s, &auint, 1, unsigned int);
3250                     s += sizeof(unsigned int);
3251                     if (checksum > 32)
3252                         cdouble += (double)auint;
3253                     else
3254                         culong += auint;
3255                 }
3256             }
3257             else {
3258                 EXTEND(SP, len);
3259                 EXTEND_MORTAL(len);
3260                 while (len-- > 0) {
3261                     Copy(s, &auint, 1, unsigned int);
3262                     s += sizeof(unsigned int);
3263                     sv = NEWSV(41, 0);
3264                     sv_setuv(sv, (UV)auint);
3265                     PUSHs(sv_2mortal(sv));
3266                 }
3267             }
3268             break;
3269         case 'l':
3270             along = (strend - s) / SIZE32;
3271             if (len > along)
3272                 len = along;
3273             if (checksum) {
3274                 while (len-- > 0) {
3275                     COPY32(s, &along);
3276                     s += SIZE32;
3277                     if (checksum > 32)
3278                         cdouble += (double)along;
3279                     else
3280                         culong += along;
3281                 }
3282             }
3283             else {
3284                 EXTEND(SP, len);
3285                 EXTEND_MORTAL(len);
3286                 while (len-- > 0) {
3287                     COPY32(s, &along);
3288                     s += SIZE32;
3289                     sv = NEWSV(42, 0);
3290                     sv_setiv(sv, (IV)along);
3291                     PUSHs(sv_2mortal(sv));
3292                 }
3293             }
3294             break;
3295         case 'V':
3296         case 'N':
3297         case 'L':
3298             along = (strend - s) / SIZE32;
3299             if (len > along)
3300                 len = along;
3301             if (checksum) {
3302                 while (len-- > 0) {
3303                     COPY32(s, &aulong);
3304                     s += SIZE32;
3305 #ifdef HAS_NTOHL
3306                     if (datumtype == 'N')
3307                         aulong = PerlSock_ntohl(aulong);
3308 #endif
3309 #ifdef HAS_VTOHL
3310                     if (datumtype == 'V')
3311                         aulong = vtohl(aulong);
3312 #endif
3313                     if (checksum > 32)
3314                         cdouble += (double)aulong;
3315                     else
3316                         culong += aulong;
3317                 }
3318             }
3319             else {
3320                 EXTEND(SP, len);
3321                 EXTEND_MORTAL(len);
3322                 while (len-- > 0) {
3323                     COPY32(s, &aulong);
3324                     s += SIZE32;
3325 #ifdef HAS_NTOHL
3326                     if (datumtype == 'N')
3327                         aulong = PerlSock_ntohl(aulong);
3328 #endif
3329 #ifdef HAS_VTOHL
3330                     if (datumtype == 'V')
3331                         aulong = vtohl(aulong);
3332 #endif
3333                     sv = NEWSV(43, 0);
3334                     sv_setuv(sv, (UV)aulong);
3335                     PUSHs(sv_2mortal(sv));
3336                 }
3337             }
3338             break;
3339         case 'p':
3340             along = (strend - s) / sizeof(char*);
3341             if (len > along)
3342                 len = along;
3343             EXTEND(SP, len);
3344             EXTEND_MORTAL(len);
3345             while (len-- > 0) {
3346                 if (sizeof(char*) > strend - s)
3347                     break;
3348                 else {
3349                     Copy(s, &aptr, 1, char*);
3350                     s += sizeof(char*);
3351                 }
3352                 sv = NEWSV(44, 0);
3353                 if (aptr)
3354                     sv_setpv(sv, aptr);
3355                 PUSHs(sv_2mortal(sv));
3356             }
3357             break;
3358         case 'w':
3359             EXTEND(SP, len);
3360             EXTEND_MORTAL(len);
3361             {
3362                 UV auv = 0;
3363                 U32 bytes = 0;
3364
3365                 while ((len > 0) && (s < strend)) {
3366                     auv = (auv << 7) | (*s & 0x7f);
3367                     if (!(*s++ & 0x80)) {
3368                         bytes = 0;
3369                         sv = NEWSV(40, 0);
3370                         sv_setuv(sv, auv);
3371                         PUSHs(sv_2mortal(sv));
3372                         len--;
3373                         auv = 0;
3374                     }
3375                     else if (++bytes >= sizeof(UV)) {   /* promote to string */
3376                         char *t;
3377
3378                         sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
3379                         while (s < strend) {
3380                             sv = mul128(sv, *s & 0x7f);
3381                             if (!(*s++ & 0x80)) {
3382                                 bytes = 0;
3383                                 break;
3384                             }
3385                         }
3386                         t = SvPV(sv, na);
3387                         while (*t == '0')
3388                             t++;
3389                         sv_chop(sv, t);
3390                         PUSHs(sv_2mortal(sv));
3391                         len--;
3392                         auv = 0;
3393                     }
3394                 }
3395                 if ((s >= strend) && bytes)
3396                     croak("Unterminated compressed integer");
3397             }
3398             break;
3399         case 'P':
3400             EXTEND(SP, 1);
3401             if (sizeof(char*) > strend - s)
3402                 break;
3403             else {
3404                 Copy(s, &aptr, 1, char*);
3405                 s += sizeof(char*);
3406             }
3407             sv = NEWSV(44, 0);
3408             if (aptr)
3409                 sv_setpvn(sv, aptr, len);
3410             PUSHs(sv_2mortal(sv));
3411             break;
3412 #ifdef HAS_QUAD
3413         case 'q':
3414             EXTEND(SP, len);
3415             EXTEND_MORTAL(len);
3416             while (len-- > 0) {
3417                 if (s + sizeof(Quad_t) > strend)
3418                     aquad = 0;
3419                 else {
3420                     Copy(s, &aquad, 1, Quad_t);
3421                     s += sizeof(Quad_t);
3422                 }
3423                 sv = NEWSV(42, 0);
3424                 if (aquad >= IV_MIN && aquad <= IV_MAX)
3425                     sv_setiv(sv, (IV)aquad);
3426                 else
3427                     sv_setnv(sv, (double)aquad);
3428                 PUSHs(sv_2mortal(sv));
3429             }
3430             break;
3431         case 'Q':
3432             EXTEND(SP, len);
3433             EXTEND_MORTAL(len);
3434             while (len-- > 0) {
3435                 if (s + sizeof(unsigned Quad_t) > strend)
3436                     auquad = 0;
3437                 else {
3438                     Copy(s, &auquad, 1, unsigned Quad_t);
3439                     s += sizeof(unsigned Quad_t);
3440                 }
3441                 sv = NEWSV(43, 0);
3442                 if (aquad <= UV_MAX)
3443                     sv_setuv(sv, (UV)auquad);
3444                 else
3445                     sv_setnv(sv, (double)auquad);
3446                 PUSHs(sv_2mortal(sv));
3447             }
3448             break;
3449 #endif
3450         /* float and double added gnb@melba.bby.oz.au 22/11/89 */
3451         case 'f':
3452         case 'F':
3453             along = (strend - s) / sizeof(float);
3454             if (len > along)
3455                 len = along;
3456             if (checksum) {
3457                 while (len-- > 0) {
3458                     Copy(s, &afloat, 1, float);
3459                     s += sizeof(float);
3460                     cdouble += afloat;
3461                 }
3462             }
3463             else {
3464                 EXTEND(SP, len);
3465                 EXTEND_MORTAL(len);
3466                 while (len-- > 0) {
3467                     Copy(s, &afloat, 1, float);
3468                     s += sizeof(float);
3469                     sv = NEWSV(47, 0);
3470                     sv_setnv(sv, (double)afloat);
3471                     PUSHs(sv_2mortal(sv));
3472                 }
3473             }
3474             break;
3475         case 'd':
3476         case 'D':
3477             along = (strend - s) / sizeof(double);
3478             if (len > along)
3479                 len = along;
3480             if (checksum) {
3481                 while (len-- > 0) {
3482                     Copy(s, &adouble, 1, double);
3483                     s += sizeof(double);
3484                     cdouble += adouble;
3485                 }
3486             }
3487             else {
3488                 EXTEND(SP, len);
3489                 EXTEND_MORTAL(len);
3490                 while (len-- > 0) {
3491                     Copy(s, &adouble, 1, double);
3492                     s += sizeof(double);
3493                     sv = NEWSV(48, 0);
3494                     sv_setnv(sv, (double)adouble);
3495                     PUSHs(sv_2mortal(sv));
3496                 }
3497             }
3498             break;
3499         case 'u':
3500             along = (strend - s) * 3 / 4;
3501             sv = NEWSV(42, along);
3502             if (along)
3503                 SvPOK_on(sv);
3504             while (s < strend && *s > ' ' && *s < 'a') {
3505                 I32 a, b, c, d;
3506                 char hunk[4];
3507
3508                 hunk[3] = '\0';
3509                 len = (*s++ - ' ') & 077;
3510                 while (len > 0) {
3511                     if (s < strend && *s >= ' ')
3512                         a = (*s++ - ' ') & 077;
3513                     else
3514                         a = 0;
3515                     if (s < strend && *s >= ' ')
3516                         b = (*s++ - ' ') & 077;
3517                     else
3518                         b = 0;
3519                     if (s < strend && *s >= ' ')
3520                         c = (*s++ - ' ') & 077;
3521                     else
3522                         c = 0;
3523                     if (s < strend && *s >= ' ')
3524                         d = (*s++ - ' ') & 077;
3525                     else
3526                         d = 0;
3527                     hunk[0] = (a << 2) | (b >> 4);
3528                     hunk[1] = (b << 4) | (c >> 2);
3529                     hunk[2] = (c << 6) | d;
3530                     sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
3531                     len -= 3;
3532                 }
3533                 if (*s == '\n')
3534                     s++;
3535                 else if (s[1] == '\n')          /* possible checksum byte */
3536                     s += 2;
3537             }
3538             XPUSHs(sv_2mortal(sv));
3539             break;
3540         }
3541         if (checksum) {
3542             sv = NEWSV(42, 0);
3543             if (strchr("fFdD", datumtype) ||
3544               (checksum > 32 && strchr("iIlLN", datumtype)) ) {
3545                 double trouble;
3546
3547                 adouble = 1.0;
3548                 while (checksum >= 16) {
3549                     checksum -= 16;
3550                     adouble *= 65536.0;
3551                 }
3552                 while (checksum >= 4) {
3553                     checksum -= 4;
3554                     adouble *= 16.0;
3555                 }
3556                 while (checksum--)
3557                     adouble *= 2.0;
3558                 along = (1 << checksum) - 1;
3559                 while (cdouble < 0.0)
3560                     cdouble += adouble;
3561                 cdouble = modf(cdouble / adouble, &trouble) * adouble;
3562                 sv_setnv(sv, cdouble);
3563             }
3564             else {
3565                 if (checksum < 32) {
3566                     aulong = (1 << checksum) - 1;
3567                     culong &= aulong;
3568                 }
3569                 sv_setuv(sv, (UV)culong);
3570             }
3571             XPUSHs(sv_2mortal(sv));
3572             checksum = 0;
3573         }
3574     }
3575     if (SP == oldsp && gimme == G_SCALAR)
3576         PUSHs(&sv_undef);
3577     RETURN;
3578 }
3579
3580 static void
3581 doencodes(register SV *sv, register char *s, register I32 len)
3582 {
3583     char hunk[5];
3584
3585     *hunk = len + ' ';
3586     sv_catpvn(sv, hunk, 1);
3587     hunk[4] = '\0';
3588     while (len > 0) {
3589         hunk[0] = ' ' + (077 & (*s >> 2));
3590         hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
3591         hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
3592         hunk[3] = ' ' + (077 & (s[2] & 077));
3593         sv_catpvn(sv, hunk, 4);
3594         s += 3;
3595         len -= 3;
3596     }
3597     for (s = SvPVX(sv); *s; s++) {
3598         if (*s == ' ')
3599             *s = '`';
3600     }
3601     sv_catpvn(sv, "\n", 1);
3602 }
3603
3604 static SV      *
3605 is_an_int(char *s, STRLEN l)
3606 {
3607   SV             *result = newSVpv("", l);
3608   char           *result_c = SvPV(result, na);  /* convenience */
3609   char           *out = result_c;
3610   bool            skip = 1;
3611   bool            ignore = 0;
3612
3613   while (*s) {
3614     switch (*s) {
3615     case ' ':
3616       break;
3617     case '+':
3618       if (!skip) {
3619         SvREFCNT_dec(result);
3620         return (NULL);
3621       }
3622       break;
3623     case '0':
3624     case '1':
3625     case '2':
3626     case '3':
3627     case '4':
3628     case '5':
3629     case '6':
3630     case '7':
3631     case '8':
3632     case '9':
3633       skip = 0;
3634       if (!ignore) {
3635         *(out++) = *s;
3636       }
3637       break;
3638     case '.':
3639       ignore = 1;
3640       break;
3641     default:
3642       SvREFCNT_dec(result);
3643       return (NULL);
3644     }
3645     s++;
3646   }
3647   *(out++) = '\0';
3648   SvCUR_set(result, out - result_c);
3649   return (result);
3650 }
3651
3652 static int
3653 div128(SV *pnum, bool *done)
3654                                             /* must be '\0' terminated */
3655
3656 {
3657   STRLEN          len;
3658   char           *s = SvPV(pnum, len);
3659   int             m = 0;
3660   int             r = 0;
3661   char           *t = s;
3662
3663   *done = 1;
3664   while (*t) {
3665     int             i;
3666
3667     i = m * 10 + (*t - '0');
3668     m = i & 0x7F;
3669     r = (i >> 7);               /* r < 10 */
3670     if (r) {
3671       *done = 0;
3672     }
3673     *(t++) = '0' + r;
3674   }
3675   *(t++) = '\0';
3676   SvCUR_set(pnum, (STRLEN) (t - s));
3677   return (m);
3678 }
3679
3680
3681 PP(pp_pack)
3682 {
3683     djSP; dMARK; dORIGMARK; dTARGET;
3684     register SV *cat = TARG;
3685     register I32 items;
3686     STRLEN fromlen;
3687     register char *pat = SvPVx(*++MARK, fromlen);
3688     register char *patend = pat + fromlen;
3689     register I32 len;
3690     I32 datumtype;
3691     SV *fromstr;
3692     /*SUPPRESS 442*/
3693     static char null10[] = {0,0,0,0,0,0,0,0,0,0};
3694     static char *space10 = "          ";
3695
3696     /* These must not be in registers: */
3697     char achar;
3698     I16 ashort;
3699     int aint;
3700     unsigned int auint;
3701     I32 along;
3702     U32 aulong;
3703 #ifdef HAS_QUAD
3704     Quad_t aquad;
3705     unsigned Quad_t auquad;
3706 #endif
3707     char *aptr;
3708     float afloat;
3709     double adouble;
3710     int commas = 0;
3711
3712     items = SP - MARK;
3713     MARK++;
3714     sv_setpvn(cat, "", 0);
3715     while (pat < patend) {
3716 #define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
3717         datumtype = *pat++ & 0xFF;
3718         if (isSPACE(datumtype))
3719             continue;
3720         if (*pat == '*') {
3721             len = strchr("@Xxu", datumtype) ? 0 : items;
3722             pat++;
3723         }
3724         else if (isDIGIT(*pat)) {
3725             len = *pat++ - '0';
3726             while (isDIGIT(*pat))
3727                 len = (len * 10) + (*pat++ - '0');
3728         }
3729         else
3730             len = 1;
3731         switch(datumtype) {
3732         default:
3733             croak("Invalid type in pack: '%c'", (int)datumtype);
3734         case ',': /* grandfather in commas but with a warning */
3735             if (commas++ == 0 && dowarn)
3736                 warn("Invalid type in pack: '%c'", (int)datumtype);
3737             break;
3738         case '%':
3739             DIE("%% may only be used in unpack");
3740         case '@':
3741             len -= SvCUR(cat);
3742             if (len > 0)
3743                 goto grow;
3744             len = -len;
3745             if (len > 0)
3746                 goto shrink;
3747             break;
3748         case 'X':
3749           shrink:
3750             if (SvCUR(cat) < len)
3751                 DIE("X outside of string");
3752             SvCUR(cat) -= len;
3753             *SvEND(cat) = '\0';
3754             break;
3755         case 'x':
3756           grow:
3757             while (len >= 10) {
3758                 sv_catpvn(cat, null10, 10);
3759                 len -= 10;
3760             }
3761             sv_catpvn(cat, null10, len);
3762             break;
3763         case 'A':
3764         case 'a':
3765             fromstr = NEXTFROM;
3766             aptr = SvPV(fromstr, fromlen);
3767             if (pat[-1] == '*')
3768                 len = fromlen;
3769             if (fromlen > len)
3770                 sv_catpvn(cat, aptr, len);
3771             else {
3772                 sv_catpvn(cat, aptr, fromlen);
3773                 len -= fromlen;
3774                 if (datumtype == 'A') {
3775                     while (len >= 10) {
3776                         sv_catpvn(cat, space10, 10);
3777                         len -= 10;
3778                     }
3779                     sv_catpvn(cat, space10, len);
3780                 }
3781                 else {
3782                     while (len >= 10) {
3783                         sv_catpvn(cat, null10, 10);
3784                         len -= 10;
3785                     }
3786                     sv_catpvn(cat, null10, len);
3787                 }
3788             }
3789             break;
3790         case 'B':
3791         case 'b':
3792             {
3793                 char *savepat = pat;
3794                 I32 saveitems;
3795
3796                 fromstr = NEXTFROM;
3797                 saveitems = items;
3798                 aptr = SvPV(fromstr, fromlen);
3799                 if (pat[-1] == '*')
3800                     len = fromlen;
3801                 pat = aptr;
3802                 aint = SvCUR(cat);
3803                 SvCUR(cat) += (len+7)/8;
3804                 SvGROW(cat, SvCUR(cat) + 1);
3805                 aptr = SvPVX(cat) + aint;
3806                 if (len > fromlen)
3807                     len = fromlen;
3808                 aint = len;
3809                 items = 0;
3810                 if (datumtype == 'B') {
3811                     for (len = 0; len++ < aint;) {
3812                         items |= *pat++ & 1;
3813                         if (len & 7)
3814                             items <<= 1;
3815                         else {
3816                             *aptr++ = items & 0xff;
3817                             items = 0;
3818                         }
3819                     }
3820                 }
3821                 else {
3822                     for (len = 0; len++ < aint;) {
3823                         if (*pat++ & 1)
3824                             items |= 128;
3825                         if (len & 7)
3826                             items >>= 1;
3827                         else {
3828                             *aptr++ = items & 0xff;
3829                             items = 0;
3830                         }
3831                     }
3832                 }
3833                 if (aint & 7) {
3834                     if (datumtype == 'B')
3835                         items <<= 7 - (aint & 7);
3836                     else
3837                         items >>= 7 - (aint & 7);
3838                     *aptr++ = items & 0xff;
3839                 }
3840                 pat = SvPVX(cat) + SvCUR(cat);
3841                 while (aptr <= pat)
3842                     *aptr++ = '\0';
3843
3844                 pat = savepat;
3845                 items = saveitems;
3846             }
3847             break;
3848         case 'H':
3849         case 'h':
3850             {
3851                 char *savepat = pat;
3852                 I32 saveitems;
3853
3854                 fromstr = NEXTFROM;
3855                 saveitems = items;
3856                 aptr = SvPV(fromstr, fromlen);
3857                 if (pat[-1] == '*')
3858                     len = fromlen;
3859                 pat = aptr;
3860                 aint = SvCUR(cat);
3861                 SvCUR(cat) += (len+1)/2;
3862                 SvGROW(cat, SvCUR(cat) + 1);
3863                 aptr = SvPVX(cat) + aint;
3864                 if (len > fromlen)
3865                     len = fromlen;
3866                 aint = len;
3867                 items = 0;
3868                 if (datumtype == 'H') {
3869                     for (len = 0; len++ < aint;) {
3870                         if (isALPHA(*pat))
3871                             items |= ((*pat++ & 15) + 9) & 15;
3872                         else
3873                             items |= *pat++ & 15;
3874                         if (len & 1)
3875                             items <<= 4;
3876                         else {
3877                             *aptr++ = items & 0xff;
3878                             items = 0;
3879                         }
3880                     }
3881                 }
3882                 else {
3883                     for (len = 0; len++ < aint;) {
3884                         if (isALPHA(*pat))
3885                             items |= (((*pat++ & 15) + 9) & 15) << 4;
3886                         else
3887                             items |= (*pat++ & 15) << 4;
3888                         if (len & 1)
3889                             items >>= 4;
3890                         else {
3891                             *aptr++ = items & 0xff;
3892                             items = 0;
3893                         }
3894                     }
3895                 }
3896                 if (aint & 1)
3897                     *aptr++ = items & 0xff;
3898                 pat = SvPVX(cat) + SvCUR(cat);
3899                 while (aptr <= pat)
3900                     *aptr++ = '\0';
3901
3902                 pat = savepat;
3903                 items = saveitems;
3904             }
3905             break;
3906         case 'C':
3907         case 'c':
3908             while (len-- > 0) {
3909                 fromstr = NEXTFROM;
3910                 aint = SvIV(fromstr);
3911                 achar = aint;
3912                 sv_catpvn(cat, &achar, sizeof(char));
3913             }
3914             break;
3915         /* Float and double added by gnb@melba.bby.oz.au  22/11/89 */
3916         case 'f':
3917         case 'F':
3918             while (len-- > 0) {
3919                 fromstr = NEXTFROM;
3920                 afloat = (float)SvNV(fromstr);
3921                 sv_catpvn(cat, (char *)&afloat, sizeof (float));
3922             }
3923             break;
3924         case 'd':
3925         case 'D':
3926             while (len-- > 0) {
3927                 fromstr = NEXTFROM;
3928                 adouble = (double)SvNV(fromstr);
3929                 sv_catpvn(cat, (char *)&adouble, sizeof (double));
3930             }
3931             break;
3932         case 'n':
3933             while (len-- > 0) {
3934                 fromstr = NEXTFROM;
3935                 ashort = (I16)SvIV(fromstr);
3936 #ifdef HAS_HTONS
3937                 ashort = PerlSock_htons(ashort);
3938 #endif
3939                 CAT16(cat, &ashort);
3940             }
3941             break;
3942         case 'v':
3943             while (len-- > 0) {
3944                 fromstr = NEXTFROM;
3945                 ashort = (I16)SvIV(fromstr);
3946 #ifdef HAS_HTOVS
3947                 ashort = htovs(ashort);
3948 #endif
3949                 CAT16(cat, &ashort);
3950             }
3951             break;
3952         case 'S':
3953         case 's':
3954             while (len-- > 0) {
3955                 fromstr = NEXTFROM;
3956                 ashort = (I16)SvIV(fromstr);
3957                 CAT16(cat, &ashort);
3958             }
3959             break;
3960         case 'I':
3961             while (len-- > 0) {
3962                 fromstr = NEXTFROM;
3963                 auint = SvUV(fromstr);
3964                 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
3965             }
3966             break;
3967         case 'w':
3968             while (len-- > 0) {
3969                 fromstr = NEXTFROM;
3970                 adouble = floor(SvNV(fromstr));
3971
3972                 if (adouble < 0)
3973                     croak("Cannot compress negative numbers");
3974
3975                 if (
3976 #ifdef BW_BITS
3977                     adouble <= BW_MASK
3978 #else
3979 #ifdef CXUX_BROKEN_CONSTANT_CONVERT
3980                     adouble <= UV_MAX_cxux
3981 #else
3982                     adouble <= UV_MAX
3983 #endif
3984 #endif
3985                     )
3986                 {
3987                     char   buf[1 + sizeof(UV)];
3988                     char  *in = buf + sizeof(buf);
3989                     UV     auv = U_V(adouble);;
3990
3991                     do {
3992                         *--in = (auv & 0x7f) | 0x80;
3993                         auv >>= 7;
3994                     } while (auv);
3995                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
3996                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
3997                 }
3998                 else if (SvPOKp(fromstr)) {  /* decimal string arithmetics */
3999                     char           *from, *result, *in;
4000                     SV             *norm;
4001                     STRLEN          len;
4002                     bool            done;
4003
4004                     /* Copy string and check for compliance */
4005                     from = SvPV(fromstr, len);
4006                     if ((norm = is_an_int(from, len)) == NULL)
4007                         croak("can compress only unsigned integer");
4008
4009                     New('w', result, len, char);
4010                     in = result + len;
4011                     done = FALSE;
4012                     while (!done)
4013                         *--in = div128(norm, &done) | 0x80;
4014                     result[len - 1] &= 0x7F; /* clear continue bit */
4015                     sv_catpvn(cat, in, (result + len) - in);
4016                     Safefree(result);
4017                     SvREFCNT_dec(norm); /* free norm */
4018                 }
4019                 else if (SvNOKp(fromstr)) {
4020                     char   buf[sizeof(double) * 2];     /* 8/7 <= 2 */
4021                     char  *in = buf + sizeof(buf);
4022
4023                     do {
4024                         double next = floor(adouble / 128);
4025                         *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4026                         if (--in < buf)  /* this cannot happen ;-) */
4027                             croak ("Cannot compress integer");
4028                         adouble = next;
4029                     } while (adouble > 0);
4030                     buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4031                     sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4032                 }
4033                 else
4034                     croak("Cannot compress non integer");
4035             }
4036             break;
4037         case 'i':
4038             while (len-- > 0) {
4039                 fromstr = NEXTFROM;
4040                 aint = SvIV(fromstr);
4041                 sv_catpvn(cat, (char*)&aint, sizeof(int));
4042             }
4043             break;
4044         case 'N':
4045             while (len-- > 0) {
4046                 fromstr = NEXTFROM;
4047                 aulong = SvUV(fromstr);
4048 #ifdef HAS_HTONL
4049                 aulong = PerlSock_htonl(aulong);
4050 #endif
4051                 CAT32(cat, &aulong);
4052             }
4053             break;
4054         case 'V':
4055             while (len-- > 0) {
4056                 fromstr = NEXTFROM;
4057                 aulong = SvUV(fromstr);
4058 #ifdef HAS_HTOVL
4059                 aulong = htovl(aulong);
4060 #endif
4061                 CAT32(cat, &aulong);
4062             }
4063             break;
4064         case 'L':
4065             while (len-- > 0) {
4066                 fromstr = NEXTFROM;
4067                 aulong = SvUV(fromstr);
4068                 CAT32(cat, &aulong);
4069             }
4070             break;
4071         case 'l':
4072             while (len-- > 0) {
4073                 fromstr = NEXTFROM;
4074                 along = SvIV(fromstr);
4075                 CAT32(cat, &along);
4076             }
4077             break;
4078 #ifdef HAS_QUAD
4079         case 'Q':
4080             while (len-- > 0) {
4081                 fromstr = NEXTFROM;
4082                 auquad = (unsigned Quad_t)SvIV(fromstr);
4083                 sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
4084             }
4085             break;
4086         case 'q':
4087             while (len-- > 0) {
4088                 fromstr = NEXTFROM;
4089                 aquad = (Quad_t)SvIV(fromstr);
4090                 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
4091             }
4092             break;
4093 #endif /* HAS_QUAD */
4094         case 'P':
4095             len = 1;            /* assume SV is correct length */
4096             /* FALL THROUGH */
4097         case 'p':
4098             while (len-- > 0) {
4099                 fromstr = NEXTFROM;
4100                 if (fromstr == &sv_undef)
4101                     aptr = NULL;
4102                 else {
4103                     /* XXX better yet, could spirit away the string to
4104                      * a safe spot and hang on to it until the result
4105                      * of pack() (and all copies of the result) are
4106                      * gone.
4107                      */
4108                     if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
4109                         warn("Attempt to pack pointer to temporary value");
4110                     if (SvPOK(fromstr) || SvNIOK(fromstr))
4111                         aptr = SvPV(fromstr,na);
4112                     else
4113                         aptr = SvPV_force(fromstr,na);
4114                 }
4115                 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4116             }
4117             break;
4118         case 'u':
4119             fromstr = NEXTFROM;
4120             aptr = SvPV(fromstr, fromlen);
4121             SvGROW(cat, fromlen * 4 / 3);
4122             if (len <= 1)
4123                 len = 45;
4124             else
4125                 len = len / 3 * 3;
4126             while (fromlen > 0) {
4127                 I32 todo;
4128
4129                 if (fromlen > len)
4130                     todo = len;
4131                 else
4132                     todo = fromlen;
4133                 doencodes(cat, aptr, todo);
4134                 fromlen -= todo;
4135                 aptr += todo;
4136             }
4137             break;
4138         }
4139     }
4140     SvSETMAGIC(cat);
4141     SP = ORIGMARK;
4142     PUSHs(cat);
4143     RETURN;
4144 }
4145 #undef NEXTFROM
4146
4147
4148 PP(pp_split)
4149 {
4150     djSP; dTARG;
4151     AV *ary;
4152     register I32 limit = POPi;                  /* note, negative is forever */
4153     SV *sv = POPs;
4154     STRLEN len;
4155     register char *s = SvPV(sv, len);
4156     char *strend = s + len;
4157     register PMOP *pm;
4158     register REGEXP *rx;
4159     register SV *dstr;
4160     register char *m;
4161     I32 iters = 0;
4162     I32 maxiters = (strend - s) + 10;
4163     I32 i;
4164     char *orig;
4165     I32 origlimit = limit;
4166     I32 realarray = 0;
4167     I32 base;
4168     AV *oldstack = curstack;
4169     I32 gimme = GIMME_V;
4170     I32 oldsave = savestack_ix;
4171     I32 make_mortal = 1;
4172     MAGIC *mg = (MAGIC *) NULL;
4173
4174 #ifdef DEBUGGING
4175     Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4176 #else
4177     pm = (PMOP*)POPs;
4178 #endif
4179     if (!pm || !s)
4180         DIE("panic: do_split");
4181     rx = pm->op_pmregexp;
4182
4183     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4184              (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4185
4186     if (pm->op_pmreplroot)
4187         ary = GvAVn((GV*)pm->op_pmreplroot);
4188     else if (gimme != G_ARRAY)
4189 #ifdef USE_THREADS
4190         ary = (AV*)curpad[0];
4191 #else
4192         ary = GvAVn(defgv);
4193 #endif /* USE_THREADS */
4194     else
4195         ary = Nullav;
4196     if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4197         realarray = 1;
4198         PUTBACK;
4199         av_extend(ary,0);
4200         av_clear(ary);
4201         SPAGAIN;
4202         if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
4203             PUSHMARK(SP);
4204             XPUSHs(mg->mg_obj);
4205         }
4206         else {
4207             if (!AvREAL(ary)) {
4208                 AvREAL_on(ary);
4209                 for (i = AvFILLp(ary); i >= 0; i--)
4210                     AvARRAY(ary)[i] = &sv_undef;        /* don't free mere refs */
4211             }
4212             /* temporarily switch stacks */
4213             SWITCHSTACK(curstack, ary);
4214             make_mortal = 0;
4215         }
4216     }
4217     base = SP - stack_base;
4218     orig = s;
4219     if (pm->op_pmflags & PMf_SKIPWHITE) {
4220         if (pm->op_pmflags & PMf_LOCALE) {
4221             while (isSPACE_LC(*s))
4222                 s++;
4223         }
4224         else {
4225             while (isSPACE(*s))
4226                 s++;
4227         }
4228     }
4229     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
4230         SAVEINT(multiline);
4231         multiline = pm->op_pmflags & PMf_MULTILINE;
4232     }
4233
4234     if (!limit)
4235         limit = maxiters + 2;
4236     if (pm->op_pmflags & PMf_WHITE) {
4237         while (--limit) {
4238             m = s;
4239             while (m < strend &&
4240                    !((pm->op_pmflags & PMf_LOCALE)
4241                      ? isSPACE_LC(*m) : isSPACE(*m)))
4242                 ++m;
4243             if (m >= strend)
4244                 break;
4245
4246             dstr = NEWSV(30, m-s);
4247             sv_setpvn(dstr, s, m-s);
4248             if (make_mortal)
4249                 sv_2mortal(dstr);
4250             XPUSHs(dstr);
4251
4252             s = m + 1;
4253             while (s < strend &&
4254                    ((pm->op_pmflags & PMf_LOCALE)
4255                     ? isSPACE_LC(*s) : isSPACE(*s)))
4256                 ++s;
4257         }
4258     }
4259     else if (strEQ("^", rx->precomp)) {
4260         while (--limit) {
4261             /*SUPPRESS 530*/
4262             for (m = s; m < strend && *m != '\n'; m++) ;
4263             m++;
4264             if (m >= strend)
4265                 break;
4266             dstr = NEWSV(30, m-s);
4267             sv_setpvn(dstr, s, m-s);
4268             if (make_mortal)
4269                 sv_2mortal(dstr);
4270             XPUSHs(dstr);
4271             s = m;
4272         }
4273     }
4274     else if (rx->check_substr && !rx->nparens
4275              && (rx->reganch & ROPT_CHECK_ALL)
4276              && !(rx->reganch & ROPT_ANCH)) {
4277         i = SvCUR(rx->check_substr);
4278         if (i == 1 && !SvTAIL(rx->check_substr)) {
4279             i = *SvPVX(rx->check_substr);
4280             while (--limit) {
4281                 /*SUPPRESS 530*/
4282                 for (m = s; m < strend && *m != i; m++) ;
4283                 if (m >= strend)
4284                     break;
4285                 dstr = NEWSV(30, m-s);
4286                 sv_setpvn(dstr, s, m-s);
4287                 if (make_mortal)
4288                     sv_2mortal(dstr);
4289                 XPUSHs(dstr);
4290                 s = m + 1;
4291             }
4292         }
4293         else {
4294 #ifndef lint
4295             while (s < strend && --limit &&
4296               (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
4297                     rx->check_substr)) )
4298 #endif
4299             {
4300                 dstr = NEWSV(31, m-s);
4301                 sv_setpvn(dstr, s, m-s);
4302                 if (make_mortal)
4303                     sv_2mortal(dstr);
4304                 XPUSHs(dstr);
4305                 s = m + i;
4306             }
4307         }
4308     }
4309     else {
4310         maxiters += (strend - s) * rx->nparens;
4311         while (s < strend && --limit &&
4312                regexec_flags(rx, s, strend, orig, 1, Nullsv, NULL, 0))
4313         {
4314             TAINT_IF(RX_MATCH_TAINTED(rx));
4315             if (rx->subbase
4316               && rx->subbase != orig) {
4317                 m = s;
4318                 s = orig;
4319                 orig = rx->subbase;
4320                 s = orig + (m - s);
4321                 strend = s + (strend - m);
4322             }
4323             m = rx->startp[0];
4324             dstr = NEWSV(32, m-s);
4325             sv_setpvn(dstr, s, m-s);
4326             if (make_mortal)
4327                 sv_2mortal(dstr);
4328             XPUSHs(dstr);
4329             if (rx->nparens) {
4330                 for (i = 1; i <= rx->nparens; i++) {
4331                     s = rx->startp[i];
4332                     m = rx->endp[i];
4333                     if (m && s) {
4334                         dstr = NEWSV(33, m-s);
4335                         sv_setpvn(dstr, s, m-s);
4336                     }
4337                     else
4338                         dstr = NEWSV(33, 0);
4339                     if (make_mortal)
4340                         sv_2mortal(dstr);
4341                     XPUSHs(dstr);
4342                 }
4343             }
4344             s = rx->endp[0];
4345         }
4346     }
4347
4348     LEAVE_SCOPE(oldsave);
4349     iters = (SP - stack_base) - base;
4350     if (iters > maxiters)
4351         DIE("Split loop");
4352
4353     /* keep field after final delim? */
4354     if (s < strend || (iters && origlimit)) {
4355         dstr = NEWSV(34, strend-s);
4356         sv_setpvn(dstr, s, strend-s);
4357         if (make_mortal)
4358             sv_2mortal(dstr);
4359         XPUSHs(dstr);
4360         iters++;
4361     }
4362     else if (!origlimit) {
4363         while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
4364             iters--, SP--;
4365     }
4366
4367     if (realarray) {
4368         if (!mg) {
4369             SWITCHSTACK(ary, oldstack);
4370             if (SvSMAGICAL(ary)) {
4371                 PUTBACK;
4372                 mg_set((SV*)ary);
4373                 SPAGAIN;
4374             }
4375             if (gimme == G_ARRAY) {
4376                 EXTEND(SP, iters);
4377                 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4378                 SP += iters;
4379                 RETURN;
4380             }
4381         }
4382         else {
4383             PUTBACK;
4384             ENTER;
4385             perl_call_method("PUSH",G_SCALAR|G_DISCARD);
4386             LEAVE;
4387             SPAGAIN;
4388             if (gimme == G_ARRAY) {
4389                 /* EXTEND should not be needed - we just popped them */
4390                 EXTEND(SP, iters);
4391                 for (i=0; i < iters; i++) {
4392                     SV **svp = av_fetch(ary, i, FALSE);
4393                     PUSHs((svp) ? *svp : &sv_undef);
4394                 }
4395                 RETURN;
4396             }
4397         }
4398     }
4399     else {
4400         if (gimme == G_ARRAY)
4401             RETURN;
4402     }
4403     if (iters || !pm->op_pmreplroot) {
4404         GETTARGET;
4405         PUSHi(iters);
4406         RETURN;
4407     }
4408     RETPUSHUNDEF;
4409 }
4410
4411 #ifdef USE_THREADS
4412 void
4413 unlock_condpair(void *svv)
4414 {
4415     dTHR;
4416     MAGIC *mg = mg_find((SV*)svv, 'm');
4417
4418     if (!mg)
4419         croak("panic: unlock_condpair unlocking non-mutex");
4420     MUTEX_LOCK(MgMUTEXP(mg));
4421     if (MgOWNER(mg) != thr)
4422         croak("panic: unlock_condpair unlocking mutex that we don't own");
4423     MgOWNER(mg) = 0;
4424     COND_SIGNAL(MgOWNERCONDP(mg));
4425     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
4426                           (unsigned long)thr, (unsigned long)svv);)
4427     MUTEX_UNLOCK(MgMUTEXP(mg));
4428 }
4429 #endif /* USE_THREADS */
4430
4431 PP(pp_lock)
4432 {
4433     djSP;
4434     dTOPss;
4435     SV *retsv = sv;
4436 #ifdef USE_THREADS
4437     MAGIC *mg;
4438
4439     if (SvROK(sv))
4440         sv = SvRV(sv);
4441
4442     mg = condpair_magic(sv);
4443     MUTEX_LOCK(MgMUTEXP(mg));
4444     if (MgOWNER(mg) == thr)
4445         MUTEX_UNLOCK(MgMUTEXP(mg));
4446     else {
4447         while (MgOWNER(mg))
4448             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
4449         MgOWNER(mg) = thr;
4450         DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
4451                               (unsigned long)thr, (unsigned long)sv);)
4452         MUTEX_UNLOCK(MgMUTEXP(mg));
4453         SvREFCNT_inc(sv);       /* keep alive until magic_mutexfree */
4454         save_destructor(unlock_condpair, sv);
4455     }
4456 #endif /* USE_THREADS */
4457     if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4458         || SvTYPE(retsv) == SVt_PVCV) {
4459         retsv = refto(retsv);
4460     }
4461     SETs(retsv);
4462     RETURN;
4463 }
4464
4465 PP(pp_threadsv)
4466 {
4467     djSP;
4468 #ifdef USE_THREADS
4469     EXTEND(SP, 1);
4470     if (op->op_private & OPpLVAL_INTRO)
4471         PUSHs(*save_threadsv(op->op_targ));
4472     else
4473         PUSHs(THREADSV(op->op_targ));
4474     RETURN;
4475 #else
4476     DIE("tried to access per-thread data in non-threaded perl");
4477 #endif /* USE_THREADS */
4478 }