av.c

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