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