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