av.c

   1 /*    av.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  * "...for the Entwives desired order, and plenty, and peace (by which they
  12  * meant that things should remain where they had set them)." --Treebeard
  13  */
  14
  15 #include "EXTERN.h"
  16 #include "perl.h"
  17
  18 void
  19 av_reify(AV *av)
  20 {
  21     I32 key;
  22     SV* sv;
  23
  24     if (AvREAL(av))
  25         return;
  26 #ifdef DEBUGGING
  27     if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
  28         warn("av_reify called on tied array");
  29 #endif
  30     key = AvMAX(av) + 1;
  31     while (key > AvFILLp(av) + 1)
  32         AvARRAY(av)[--key] = &sv_undef;
  33     while (key) {
  34         sv = AvARRAY(av)[--key];
  35         assert(sv);
  36         if (sv != &sv_undef) {
  37             dTHR;
  38             (void)SvREFCNT_inc(sv);
  39         }
  40     }
  41     key = AvARRAY(av) - AvALLOC(av);
  42     while (key)
  43         AvALLOC(av)[--key] = &sv_undef;
  44     AvREAL_on(av);
  45 }
  46
  47 void
  48 av_extend(AV *av, I32 key)
  49 {
  50     dTHR;                       /* only necessary if we have to extend stack */
  51     MAGIC *mg;
  52     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
  53         dSP;
  54         ENTER;
  55         SAVETMPS;
  56         PUSHSTACKi(PERLSI_MAGIC);
  57         PUSHMARK(SP);
  58         EXTEND(SP,2);
  59         PUSHs(mg->mg_obj);
  60         PUSHs(sv_2mortal(newSViv(key+1)));
  61         PUTBACK;
  62         perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
  63         POPSTACK;
  64         FREETMPS;
  65         LEAVE;
  66         return;
  67     }
  68     if (key > AvMAX(av)) {
  69         SV** ary;
  70         I32 tmp;
  71         I32 newmax;
  72
  73         if (AvALLOC(av) != AvARRAY(av)) {
  74             ary = AvALLOC(av) + AvFILLp(av) + 1;
  75             tmp = AvARRAY(av) - AvALLOC(av);
  76             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  77             AvMAX(av) += tmp;
  78             SvPVX(av) = (char*)AvALLOC(av);
  79             if (AvREAL(av)) {
  80                 while (tmp)
  81                     ary[--tmp] = &sv_undef;
  82             }
  83
  84             if (key > AvMAX(av) - 10) {
  85                 newmax = key + AvMAX(av);
  86                 goto resize;
  87             }
  88         }
  89         else {
  90             if (AvALLOC(av)) {
  91 #ifndef STRANGE_MALLOC
  92                 U32 bytes;
  93 #endif
  94
  95 #if defined(MYMALLOC) && !defined(PURIFY)
  96                 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
  97
  98                 if (key <= newmax)
  99                     goto resized;
 100 #endif
 101                 newmax = key + AvMAX(av) / 5;
 102               resize:
 103 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 104                 Renew(AvALLOC(av),newmax+1, SV*);
 105 #else
 106                 bytes = (newmax + 1) * sizeof(SV*);
 107 #define MALLOC_OVERHEAD 16
 108                 tmp = MALLOC_OVERHEAD;
 109                 while (tmp - MALLOC_OVERHEAD < bytes)
 110                     tmp += tmp;
 111                 tmp -= MALLOC_OVERHEAD;
 112                 tmp /= sizeof(SV*);
 113                 assert(tmp > newmax);
 114                 newmax = tmp - 1;
 115                 New(2,ary, newmax+1, SV*);
 116                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 117                 if (AvMAX(av) > 64)
 118                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
 119                 else
 120                     Safefree(AvALLOC(av));
 121                 AvALLOC(av) = ary;
 122 #endif
 123               resized:
 124                 ary = AvALLOC(av) + AvMAX(av) + 1;
 125                 tmp = newmax - AvMAX(av);
 126                 if (av == curstack) {   /* Oops, grew stack (via av_store()?) */
 127                     stack_sp = AvALLOC(av) + (stack_sp - stack_base);
 128                     stack_base = AvALLOC(av);
 129                     stack_max = stack_base + newmax;
 130                 }
 131             }
 132             else {
 133                 newmax = key < 3 ? 3 : key;
 134                 New(2,AvALLOC(av), newmax+1, SV*);
 135                 ary = AvALLOC(av) + 1;
 136                 tmp = newmax;
 137                 AvALLOC(av)[0] = &sv_undef;     /* For the stacks */
 138             }
 139             if (AvREAL(av)) {
 140                 while (tmp)
 141                     ary[--tmp] = &sv_undef;
 142             }
 143
 144             SvPVX(av) = (char*)AvALLOC(av);
 145             AvMAX(av) = newmax;
 146         }
 147     }
 148 }
 149
 150 SV**
 151 av_fetch(register AV *av, I32 key, I32 lval)
 152 {
 153     SV *sv;
 154
 155     if (!av)
 156         return 0;
 157
 158     if (key < 0) {
 159         key += AvFILL(av) + 1;
 160         if (key < 0)
 161             return 0;
 162     }
 163
 164     if (SvRMAGICAL(av)) {
 165         if (mg_find((SV*)av,'P')) {
 166             dTHR;
 167             sv = sv_newmortal();
 168             mg_copy((SV*)av, sv, 0, key);
 169             av_fetch_sv = sv;
 170             return &av_fetch_sv;
 171         }
 172     }
 173
 174     if (key > AvFILLp(av)) {
 175         if (!lval)
 176             return 0;
 177         if (AvREALISH(av))
 178             sv = NEWSV(5,0);
 179         else
 180             sv = sv_newmortal();
 181         return av_store(av,key,sv);
 182     }
 183     if (AvARRAY(av)[key] == &sv_undef) {
 184     emptyness:
 185         if (lval) {
 186             sv = NEWSV(6,0);
 187             return av_store(av,key,sv);
 188         }
 189         return 0;
 190     }
 191     else if (AvREIFY(av)
 192              && (!AvARRAY(av)[key]      /* eg. @_ could have freed elts */
 193                  || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
 194         AvARRAY(av)[key] = &sv_undef;   /* 1/2 reify */
 195         goto emptyness;
 196     }
 197     return &AvARRAY(av)[key];
 198 }
 199
 200 SV**
 201 av_store(register AV *av, I32 key, SV *val)
 202 {
 203     SV** ary;
 204     U32  fill;
 205
 206
 207     if (!av)
 208         return 0;
 209     if (!val)
 210         val = &sv_undef;
 211
 212     if (key < 0) {
 213         key += AvFILL(av) + 1;
 214         if (key < 0)
 215             return 0;
 216     }
 217
 218     if (SvREADONLY(av) && key >= AvFILL(av))
 219         croak(no_modify);
 220
 221     if (SvRMAGICAL(av)) {
 222         if (mg_find((SV*)av,'P')) {
 223             if (val != &sv_undef) {
 224                 mg_copy((SV*)av, val, 0, key);
 225             }
 226             return 0;
 227         }
 228     }
 229
 230     if (!AvREAL(av) && AvREIFY(av))
 231         av_reify(av);
 232     if (key > AvMAX(av))
 233         av_extend(av,key);
 234     ary = AvARRAY(av);
 235     if (AvFILLp(av) < key) {
 236         if (!AvREAL(av)) {
 237             dTHR;
 238             if (av == curstack && key > stack_sp - stack_base)
 239                 stack_sp = stack_base + key;    /* XPUSH in disguise */
 240             do
 241                 ary[++AvFILLp(av)] = &sv_undef;
 242             while (AvFILLp(av) < key);
 243         }
 244         AvFILLp(av) = key;
 245     }
 246     else if (AvREAL(av))
 247         SvREFCNT_dec(ary[key]);
 248     ary[key] = val;
 249     if (SvSMAGICAL(av)) {
 250         if (val != &sv_undef) {
 251             MAGIC* mg = SvMAGIC(av);
 252             sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
 253         }
 254         mg_set((SV*)av);
 255     }
 256     return &ary[key];
 257 }
 258
 259 AV *
 260 newAV(void)
 261 {
 262     register AV *av;
 263
 264     av = (AV*)NEWSV(3,0);
 265     sv_upgrade((SV *)av, SVt_PVAV);
 266     AvREAL_on(av);
 267     AvALLOC(av) = 0;
 268     SvPVX(av) = 0;
 269     AvMAX(av) = AvFILLp(av) = -1;
 270     return av;
 271 }
 272
 273 AV *
 274 av_make(register I32 size, register SV **strp)
 275 {
 276     register AV *av;
 277     register I32 i;
 278     register SV** ary;
 279
 280     av = (AV*)NEWSV(8,0);
 281     sv_upgrade((SV *) av,SVt_PVAV);
 282     AvFLAGS(av) = AVf_REAL;
 283     if (size) {         /* `defined' was returning undef for size==0 anyway. */
 284         New(4,ary,size,SV*);
 285         AvALLOC(av) = ary;
 286         SvPVX(av) = (char*)ary;
 287         AvFILLp(av) = size - 1;
 288         AvMAX(av) = size - 1;
 289         for (i = 0; i < size; i++) {
 290             assert (*strp);
 291             ary[i] = NEWSV(7,0);
 292             sv_setsv(ary[i], *strp);
 293             strp++;
 294         }
 295     }
 296     return av;
 297 }
 298
 299 AV *
 300 av_fake(register I32 size, register SV **strp)
 301 {
 302     register AV *av;
 303     register SV** ary;
 304
 305     av = (AV*)NEWSV(9,0);
 306     sv_upgrade((SV *)av, SVt_PVAV);
 307     New(4,ary,size+1,SV*);
 308     AvALLOC(av) = ary;
 309     Copy(strp,ary,size,SV*);
 310     AvFLAGS(av) = AVf_REIFY;
 311     SvPVX(av) = (char*)ary;
 312     AvFILLp(av) = size - 1;
 313     AvMAX(av) = size - 1;
 314     while (size--) {
 315         assert (*strp);
 316         SvTEMP_off(*strp);
 317         strp++;
 318     }
 319     return av;
 320 }
 321
 322 void
 323 av_clear(register AV *av)
 324 {
 325     register I32 key;
 326     SV** ary;
 327
 328 #ifdef DEBUGGING
 329     if (SvREFCNT(av) <= 0) {
 330         warn("Attempt to clear deleted array");
 331     }
 332 #endif
 333     if (!av)
 334         return;
 335     /*SUPPRESS 560*/
 336
 337     if (SvREADONLY(av))
 338         croak(no_modify);
 339
 340     /* Give any tie a chance to cleanup first */
 341     if (SvRMAGICAL(av))
 342         mg_clear((SV*)av);
 343
 344     if (AvMAX(av) < 0)
 345         return;
 346
 347     if (AvREAL(av)) {
 348         ary = AvARRAY(av);
 349         key = AvFILLp(av) + 1;
 350         while (key) {
 351             SvREFCNT_dec(ary[--key]);
 352             ary[key] = &sv_undef;
 353         }
 354     }
 355     if (key = AvARRAY(av) - AvALLOC(av)) {
 356         AvMAX(av) += key;
 357         SvPVX(av) = (char*)AvALLOC(av);
 358     }
 359     AvFILLp(av) = -1;
 360
 361 }
 362
 363 void
 364 av_undef(register AV *av)
 365 {
 366     register I32 key;
 367
 368     if (!av)
 369         return;
 370     /*SUPPRESS 560*/
 371
 372     /* Give any tie a chance to cleanup first */
 373     if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
 374         av_fill(av, -1);   /* mg_clear() ? */
 375
 376     if (AvREAL(av)) {
 377         key = AvFILLp(av) + 1;
 378         while (key)
 379             SvREFCNT_dec(AvARRAY(av)[--key]);
 380     }
 381     Safefree(AvALLOC(av));
 382     AvALLOC(av) = 0;
 383     SvPVX(av) = 0;
 384     AvMAX(av) = AvFILLp(av) = -1;
 385     if (AvARYLEN(av)) {
 386         SvREFCNT_dec(AvARYLEN(av));
 387         AvARYLEN(av) = 0;
 388     }
 389 }
 390
 391 void
 392 av_push(register AV *av, SV *val)
 393 {
 394     MAGIC *mg;
 395     if (!av)
 396         return;
 397     if (SvREADONLY(av))
 398         croak(no_modify);
 399
 400     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 401         dSP;
 402         PUSHSTACKi(PERLSI_MAGIC);
 403         PUSHMARK(SP);
 404         EXTEND(SP,2);
 405         PUSHs(mg->mg_obj);
 406         PUSHs(val);
 407         PUTBACK;
 408         ENTER;
 409         perl_call_method("PUSH", G_SCALAR|G_DISCARD);
 410         LEAVE;
 411         POPSTACK;
 412         return;
 413     }
 414     av_store(av,AvFILLp(av)+1,val);
 415 }
 416
 417 SV *
 418 av_pop(register AV *av)
 419 {
 420     SV *retval;
 421     MAGIC* mg;
 422
 423     if (!av || AvFILL(av) < 0)
 424         return &sv_undef;
 425     if (SvREADONLY(av))
 426         croak(no_modify);
 427     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 428         dSP;
 429         PUSHSTACKi(PERLSI_MAGIC);
 430         PUSHMARK(SP);
 431         XPUSHs(mg->mg_obj);
 432         PUTBACK;
 433         ENTER;
 434         if (perl_call_method("POP", G_SCALAR)) {
 435             retval = newSVsv(*stack_sp--);
 436         } else {
 437             retval = &sv_undef;
 438         }
 439         LEAVE;
 440         POPSTACK;
 441         return retval;
 442     }
 443     retval = AvARRAY(av)[AvFILLp(av)];
 444     AvARRAY(av)[AvFILLp(av)--] = &sv_undef;
 445     if (SvSMAGICAL(av))
 446         mg_set((SV*)av);
 447     return retval;
 448 }
 449
 450 void
 451 av_unshift(register AV *av, register I32 num)
 452 {
 453     register I32 i;
 454     register SV **ary;
 455     MAGIC* mg;
 456
 457     if (!av || num <= 0)
 458         return;
 459     if (SvREADONLY(av))
 460         croak(no_modify);
 461
 462     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 463         dSP;
 464         PUSHSTACKi(PERLSI_MAGIC);
 465         PUSHMARK(SP);
 466         EXTEND(SP,1+num);
 467         PUSHs(mg->mg_obj);
 468         while (num-- > 0) {
 469             PUSHs(&sv_undef);
 470         }
 471         PUTBACK;
 472         ENTER;
 473         perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
 474         LEAVE;
 475         POPSTACK;
 476         return;
 477     }
 478
 479     if (!AvREAL(av) && AvREIFY(av))
 480         av_reify(av);
 481     i = AvARRAY(av) - AvALLOC(av);
 482     if (i) {
 483         if (i > num)
 484             i = num;
 485         num -= i;
 486
 487         AvMAX(av) += i;
 488         AvFILLp(av) += i;
 489         SvPVX(av) = (char*)(AvARRAY(av) - i);
 490     }
 491     if (num) {
 492         i = AvFILLp(av);
 493         av_extend(av, i + num);
 494         AvFILLp(av) += num;
 495         ary = AvARRAY(av);
 496         Move(ary, ary + num, i + 1, SV*);
 497         do {
 498             ary[--num] = &sv_undef;
 499         } while (num);
 500     }
 501 }
 502
 503 SV *
 504 av_shift(register AV *av)
 505 {
 506     SV *retval;
 507     MAGIC* mg;
 508
 509     if (!av || AvFILL(av) < 0)
 510         return &sv_undef;
 511     if (SvREADONLY(av))
 512         croak(no_modify);
 513     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 514         dSP;
 515         PUSHSTACKi(PERLSI_MAGIC);
 516         PUSHMARK(SP);
 517         XPUSHs(mg->mg_obj);
 518         PUTBACK;
 519         ENTER;
 520         if (perl_call_method("SHIFT", G_SCALAR)) {
 521             retval = newSVsv(*stack_sp--);
 522         } else {
 523             retval = &sv_undef;
 524         }
 525         LEAVE;
 526         POPSTACK;
 527         return retval;
 528     }
 529     retval = *AvARRAY(av);
 530     if (AvREAL(av))
 531         *AvARRAY(av) = &sv_undef;
 532     SvPVX(av) = (char*)(AvARRAY(av) + 1);
 533     AvMAX(av)--;
 534     AvFILLp(av)--;
 535     if (SvSMAGICAL(av))
 536         mg_set((SV*)av);
 537     return retval;
 538 }
 539
 540 I32
 541 av_len(register AV *av)
 542 {
 543     return AvFILL(av);
 544 }
 545
 546 void
 547 av_fill(register AV *av, I32 fill)
 548 {
 549     MAGIC *mg;
 550     if (!av)
 551         croak("panic: null array");
 552     if (fill < 0)
 553         fill = -1;
 554     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 555         dSP;
 556         ENTER;
 557         SAVETMPS;
 558         PUSHSTACKi(PERLSI_MAGIC);
 559         PUSHMARK(SP);
 560         EXTEND(SP,2);
 561         PUSHs(mg->mg_obj);
 562         PUSHs(sv_2mortal(newSViv(fill+1)));
 563         PUTBACK;
 564         perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
 565         POPSTACK;
 566         FREETMPS;
 567         LEAVE;
 568         return;
 569     }
 570     if (fill <= AvMAX(av)) {
 571         I32 key = AvFILLp(av);
 572         SV** ary = AvARRAY(av);
 573
 574         if (AvREAL(av)) {
 575             while (key > fill) {
 576                 SvREFCNT_dec(ary[key]);
 577                 ary[key--] = &sv_undef;
 578             }
 579         }
 580         else {
 581             while (key < fill)
 582                 ary[++key] = &sv_undef;
 583         }
 584
 585         AvFILLp(av) = fill;
 586         if (SvSMAGICAL(av))
 587             mg_set((SV*)av);
 588     }
 589     else
 590         (void)av_store(av,fill,&sv_undef);
 591 }
 592
 593
 594 /* AVHV: Support for treating arrays as if they were hashes.  The
 595  * first element of the array should be a hash reference that maps
 596  * hash keys to array indices.
 597  */
 598
 599 STATIC I32
 600 avhv_index_sv(SV* sv)
 601 {
 602     I32 index = SvIV(sv);
 603     if (index < 1)
 604         croak("Bad index while coercing array into hash");
 605     return index;
 606 }
 607
 608 HV*
 609 avhv_keys(AV *av)
 610 {
 611     SV **keysp = av_fetch(av, 0, FALSE);
 612     if (keysp) {
 613         SV *sv = *keysp;
 614         if (SvGMAGICAL(sv))
 615             mg_get(sv);
 616         if (SvROK(sv)) {
 617             sv = SvRV(sv);
 618             if (SvTYPE(sv) == SVt_PVHV)
 619                 return (HV*)sv;
 620         }
 621     }
 622     croak("Can't coerce array into hash");
 623     return Nullhv;
 624 }
 625
 626 SV**
 627 avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
 628 {
 629     SV **indsvp;
 630     HV *keys = avhv_keys(av);
 631     HE *he;
 632
 633     he = hv_fetch_ent(keys, keysv, FALSE, hash);
 634     if (!he)
 635         croak("No such array field");
 636     return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
 637 }
 638
 639 bool
 640 avhv_exists_ent(AV *av, SV *keysv, U32 hash)
 641 {
 642     HV *keys = avhv_keys(av);
 643     return hv_exists_ent(keys, keysv, hash);
 644 }
 645
 646 HE *
 647 avhv_iternext(AV *av)
 648 {
 649     HV *keys = avhv_keys(av);
 650     return hv_iternext(keys);
 651 }
 652
 653 SV *
 654 avhv_iterval(AV *av, register HE *entry)
 655 {
 656     SV *sv = hv_iterval(avhv_keys(av), entry);
 657     return *av_fetch(av, avhv_index_sv(sv), TRUE);
 658 }