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