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