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 (SvTIED_mg((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] = &PL_sv_undef;
  33     while (key) {
  34         sv = AvARRAY(av)[--key];
  35         assert(sv);
  36         if (sv != &PL_sv_undef) {
  37             dTHR;
  38             (void)SvREFCNT_inc(sv);
  39         }
  40     }
  41     key = AvARRAY(av) - AvALLOC(av);
  42     while (key)
  43         AvALLOC(av)[--key] = &PL_sv_undef;
  44     AvREIFY_off(av);
  45     AvREAL_on(av);
  46 }
  47
  48 void
  49 av_extend(AV *av, I32 key)
  50 {
  51     dTHR;                       /* only necessary if we have to extend stack */
  52     MAGIC *mg;
  53     if (mg = SvTIED_mg((SV*)av, 'P')) {
  54         dSP;
  55         ENTER;
  56         SAVETMPS;
  57         PUSHSTACKi(PERLSI_MAGIC);
  58         PUSHMARK(SP);
  59         EXTEND(SP,2);
  60         PUSHs(SvTIED_obj((SV*)av, mg));
  61         PUSHs(sv_2mortal(newSViv(key+1)));
  62         PUTBACK;
  63         perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
  64         POPSTACK;
  65         FREETMPS;
  66         LEAVE;
  67         return;
  68     }
  69     if (key > AvMAX(av)) {
  70         SV** ary;
  71         I32 tmp;
  72         I32 newmax;
  73
  74         if (AvALLOC(av) != AvARRAY(av)) {
  75             ary = AvALLOC(av) + AvFILLp(av) + 1;
  76             tmp = AvARRAY(av) - AvALLOC(av);
  77             Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
  78             AvMAX(av) += tmp;
  79             SvPVX(av) = (char*)AvALLOC(av);
  80             if (AvREAL(av)) {
  81                 while (tmp)
  82                     ary[--tmp] = &PL_sv_undef;
  83             }
  84
  85             if (key > AvMAX(av) - 10) {
  86                 newmax = key + AvMAX(av);
  87                 goto resize;
  88             }
  89         }
  90         else {
  91             if (AvALLOC(av)) {
  92 #ifndef STRANGE_MALLOC
  93                 U32 bytes;
  94 #endif
  95
  96 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
  97                 newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
  98
  99                 if (key <= newmax)
 100                     goto resized;
 101 #endif
 102                 newmax = key + AvMAX(av) / 5;
 103               resize:
 104 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
 105                 Renew(AvALLOC(av),newmax+1, SV*);
 106 #else
 107                 bytes = (newmax + 1) * sizeof(SV*);
 108 #define MALLOC_OVERHEAD 16
 109                 tmp = MALLOC_OVERHEAD;
 110                 while (tmp - MALLOC_OVERHEAD < bytes)
 111                     tmp += tmp;
 112                 tmp -= MALLOC_OVERHEAD;
 113                 tmp /= sizeof(SV*);
 114                 assert(tmp > newmax);
 115                 newmax = tmp - 1;
 116                 New(2,ary, newmax+1, SV*);
 117                 Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
 118                 if (AvMAX(av) > 64)
 119                     offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
 120                 else
 121                     Safefree(AvALLOC(av));
 122                 AvALLOC(av) = ary;
 123 #endif
 124               resized:
 125                 ary = AvALLOC(av) + AvMAX(av) + 1;
 126                 tmp = newmax - AvMAX(av);
 127                 if (av == PL_curstack) {        /* Oops, grew stack (via av_store()?) */
 128                     PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
 129                     PL_stack_base = AvALLOC(av);
 130                     PL_stack_max = PL_stack_base + newmax;
 131                 }
 132             }
 133             else {
 134                 newmax = key < 3 ? 3 : key;
 135                 New(2,AvALLOC(av), newmax+1, SV*);
 136                 ary = AvALLOC(av) + 1;
 137                 tmp = newmax;
 138                 AvALLOC(av)[0] = &PL_sv_undef;  /* For the stacks */
 139             }
 140             if (AvREAL(av)) {
 141                 while (tmp)
 142                     ary[--tmp] = &PL_sv_undef;
 143             }
 144
 145             SvPVX(av) = (char*)AvALLOC(av);
 146             AvMAX(av) = newmax;
 147         }
 148     }
 149 }
 150
 151 SV**
 152 av_fetch(register AV *av, I32 key, I32 lval)
 153 {
 154     SV *sv;
 155
 156     if (!av)
 157         return 0;
 158
 159     if (key < 0) {
 160         key += AvFILL(av) + 1;
 161         if (key < 0)
 162             return 0;
 163     }
 164
 165     if (SvRMAGICAL(av)) {
 166         if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
 167             dTHR;
 168             sv = sv_newmortal();
 169             mg_copy((SV*)av, sv, 0, key);
 170             PL_av_fetch_sv = sv;
 171             return &PL_av_fetch_sv;
 172         }
 173     }
 174
 175     if (key > AvFILLp(av)) {
 176         if (!lval)
 177             return 0;
 178         if (AvREALISH(av))
 179             sv = NEWSV(5,0);
 180         else
 181             sv = sv_newmortal();
 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 av_store(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         croak(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 newAV(void)
 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 av_make(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 av_fake(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 av_clear(register AV *av)
 325 {
 326     register I32 key;
 327     SV** ary;
 328
 329 #ifdef DEBUGGING
 330     if (SvREFCNT(av) <= 0) {
 331         warn("Attempt to clear deleted array");
 332     }
 333 #endif
 334     if (!av)
 335         return;
 336     /*SUPPRESS 560*/
 337
 338     if (SvREADONLY(av))
 339         croak(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 av_undef(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 av_push(register AV *av, SV *val)
 394 {
 395     MAGIC *mg;
 396     if (!av)
 397         return;
 398     if (SvREADONLY(av))
 399         croak(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         perl_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 av_pop(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         croak(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 (perl_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 av_unshift(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         croak(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         perl_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 av_shift(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         croak(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 (perl_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 av_len(register AV *av)
 543 {
 544     return AvFILL(av);
 545 }
 546
 547 void
 548 av_fill(register AV *av, I32 fill)
 549 {
 550     MAGIC *mg;
 551     if (!av)
 552         croak("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         perl_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 avhv_index_sv(SV* sv)
 602 {
 603     I32 index = SvIV(sv);
 604     if (index < 1)
 605         croak("Bad index while coercing array into hash");
 606     return index;
 607 }
 608
 609 HV*
 610 avhv_keys(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     croak("Can't coerce array into hash");
 624     return Nullhv;
 625 }
 626
 627 SV**
 628 avhv_fetch_ent(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         croak("No such array field");
 637     return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
 638 }
 639
 640 bool
 641 avhv_exists_ent(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 avhv_iternext(AV *av)
 649 {
 650     HV *keys = avhv_keys(av);
 651     return hv_iternext(keys);
 652 }
 653
 654 SV *
 655 avhv_iterval(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 }