Fix up integration 5.003->5.004.

p4raw-id: //depot/perl@19

diff --git a/av.c b/av.c
index ca6f00a..e3d341c 100644 (file)
--- a/av.c
+++ b/av.c
@@ -507,6 +507,35 @@ I32 lval;
 }
 
 SV**
+avhv_fetch_ent(av, keysv, lval, hash)
+AV *av;
+SV *keysv;
+I32 lval;
+U32 hash;
+{
+    SV **keys, **indsvp;
+    HE *he;
+    I32 ind;
+    
+    keys = av_fetch(av, 0, FALSE);
+    if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+       croak("Can't coerce array into hash");
+    he = hv_fetch_ent((HV*)SvRV(*keys), keysv, FALSE, hash);
+    if (he) {
+       ind = SvIV(HeVAL(he));
+       if (ind < 1)
+           croak("Bad index while coercing array into hash");
+    } else {
+       if (!lval)
+           return 0;
+       
+       ind = AvFILL(av) + 1;
+       hv_store_ent((HV*)SvRV(*keys), keysv, newSViv(ind), 0);
+    }
+    return av_fetch(av, ind, lval);
+}
+
+SV**
 avhv_store(av, key, klen, val, hash)
 AV *av;
 char *key;
@@ -533,6 +562,20 @@ U32 hash;
 }
 
 bool
+avhv_exists_ent(av, keysv, hash)
+AV *av;
+SV *keysv;
+U32 hash;
+{
+    SV **keys;
+    
+    keys = av_fetch(av, 0, FALSE);
+    if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+       croak("Can't coerce array into hash");
+    return hv_exists_ent((HV*)SvRV(*keys), keysv, hash);
+}
+
+bool
 avhv_exists(av, key, klen)
 AV *av;
 char *key;
@@ -581,6 +624,41 @@ I32 flags;
     return sv;
 }
 
+/* avhv_delete_ent leaks. Caller can re-index and compress if so desired. */
+SV *
+avhv_delete_ent(av, keysv, flags, hash)
+AV *av;
+SV *keysv;
+I32 flags;
+U32 hash;
+{
+    SV **keys;
+    SV *sv;
+    SV **svp;
+    I32 ind;
+    
+    keys = av_fetch(av, 0, FALSE);
+    if (!keys || !SvROK(*keys) || SvTYPE(SvRV(*keys)) != SVt_PVHV)
+       croak("Can't coerce array into hash");
+    sv = hv_delete_ent((HV*)SvRV(*keys), keysv, 0, hash);
+    if (!sv)
+       return Nullsv;
+    ind = SvIV(sv);
+    if (ind < 1)
+       croak("Bad index while coercing array into hash");
+    svp = av_fetch(av, ind, FALSE);
+    if (!svp)
+       return Nullsv;
+    if (flags & G_DISCARD) {
+       sv = Nullsv;
+       SvREFCNT_dec(*svp);
+    } else {
+       sv = sv_2mortal(*svp);
+    }
+    *svp = &sv_undef;
+    return sv;
+}
+
 I32
 avhv_iterinit(av)
 AV *av;

diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index b76c53e..8d01d91 100644 (file)
--- a/ext/DB_File/DB_File.xs
+++ b/ext/DB_File/DB_File.xs
@@ -816,16 +816,6 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H
        OUTPUT: 
            RETVAL
 
->>>> ORIGINAL VERSION
-BOOT:
-    newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);
-
-==== THEIR VERSION
-==== YOUR VERSION
-BOOT:
-    newXS("DB_File::TIEARRAY", XS_DB_File_TIEHASH, file);
-
-<<<<
 int
 db_DESTROY(db)
        DB_File         db

diff --git a/lib/Class/Fields.pm b/lib/Class/Fields.pm
new file mode 100644 (file)
index 0000000..4b23e7d
--- /dev/null
+++ b/lib/Class/Fields.pm
@@ -0,0 +1,33 @@
+package Class::Fields;
+use Carp;
+
+sub import {
+    my $class = shift;
+    my ($package) = caller;
+    my $fields = \%{"$package\::FIELDS"};
+    my $i = $fields->{__MAX__};
+    foreach my $f (@_) {
+       if (defined($fields->{$f})) {
+           croak "Field name $f already used by a base class"
+       }
+       $fields->{$f} = ++$i;
+    }
+    $fields->{__MAX__} = $i;
+    push(@{"$package\::ISA"}, "Class::Fields");
+}
+
+sub new {
+    my $class = shift;
+    bless [\%{"$class\::FIELDS"}, @_], $class;
+}
+
+sub ISA {
+    my ($class, $package) = @_;
+    my $from_fields = \%{"$class\::FIELDS"};
+    my $to_fields = \%{"$package\::FIELDS"};
+    return unless defined %$from_fields;
+    croak "Ambiguous inheritance for %FIELDS" if defined %$to_fields;
+    %$to_fields = %$from_fields;
+}
+
+1;

diff --git a/lib/ISA.pm b/lib/ISA.pm
new file mode 100644 (file)
index 0000000..d18242c
--- /dev/null
+++ b/lib/ISA.pm
@@ -0,0 +1,20 @@
+package ISA;
+use Carp;
+
+sub import {
+    my $class = shift;
+    my ($package) = caller;
+    foreach my $base (@_) {
+       croak qq(No such class "$base") unless defined %{"$base\::"};
+       eval {
+           $base->ISA($package);
+       };
+       if ($@ && $@ !~ /^Can't locate object method/) {
+           $@ =~ s/ at .*? line \d+\n$//;
+           croak $@;
+       }
+    }
+    push(@{"$package\::ISA"}, @_);
+}
+
+1;

diff --git a/perl.c b/perl.c
index b3afec7..fd99e75 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -886,7 +886,7 @@ PerlInterpreter *sv_interp;
        if (perldb && DBsingle)
            sv_setiv(DBsingle, 1); 
        if (restartav)
-           calllist(restartav);
+           call_list(oldscope, restartav);
     }
 
     /* do it */

diff --git a/pp.c b/pp.c
index 6e8e4c1..af615c3 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2131,8 +2131,9 @@ PP(pp_delete)
 
     if (op->op_private & OPpSLICE) {
        dMARK; dORIGMARK;
+       U32 hvtype;
        hv = (HV*)POPs;
-       U32 hvtype = SvTYPE(hv);
+       hvtype = SvTYPE(hv);
        while (++MARK <= SP) {
            if (hvtype == SVt_PVHV)
                sv = hv_delete_ent(hv, *MARK, discard, 0);
@@ -2153,9 +2154,12 @@ PP(pp_delete)
     else {
        SV *keysv = POPs;
        hv = (HV*)POPs;
-       if (SvTYPE(hv) != SVt_PVHV)
+       if (SvTYPE(hv) == SVt_PVHV)
+           sv = hv_delete_ent(hv, keysv, discard, 0);
+       else if (SvTYPE(hv) == SVt_PVAV)
+           sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
+       else
            DIE("Not a HASH reference");
-       sv = hv_delete_ent(hv, keysv, discard, 0);
        if (!sv)
            sv = &sv_undef;
        if (!discard)
@@ -2197,7 +2201,7 @@ PP(pp_hslice)
                he = hv_fetch_ent(hv, keysv, lval, 0);
                svp = he ? &HeVAL(he) : 0;
            } else {
-               svp = avhv_fetch_ent((AV*)hv, keysv, lval);
+               svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
            }
            if (lval) {
                if (!he || HeVAL(he) == &sv_undef)

diff --git a/pp_hot.c b/pp_hot.c
index faa66b4..e9fad16 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1271,17 +1271,16 @@ PP(pp_helem)
 
     if (SvTYPE(hv) == SVt_PVHV) {
        he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
-       svp = he ? &Heval(he) : 0;
+       svp = he ? &HeVAL(he) : 0;
     }
     else if (SvTYPE(hv) == SVt_PVAV) {
-       svp = avhv_fetch_ent((AV*)hv, keysv, lval);
+       svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
     }
     else {
        RETPUSHUNDEF;
     }
-<<<<
     if (lval) {
-       if (svp || *svp == &sv_undef) {
+       if (!svp || *svp == &sv_undef) {
            SV* lv;
            SV* key2;
            if (!defer)

diff --git a/proto.h b/proto.h
index 06ba5df..a20ce43 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -15,8 +15,11 @@ OP*  append_list _((I32 optype, LISTOP* first, LISTOP* last));
 I32    apply _((I32 type, SV** mark, SV** sp));
 void   assertref _((OP* op));
 SV*    avhv_delete _((AV *ar, char* key, U32 klen, I32 flags));
+SV*    avhv_delete_ent _((AV *ar, SV* keysv, I32 flags, U32 hash));
 bool   avhv_exists _((AV *ar, char* key, U32 klen));
+bool   avhv_exists_ent _((AV *ar, SV* keysv, U32 hash));
 SV**   avhv_fetch _((AV *ar, char* key, U32 klen, I32 lval));
+SV**   avhv_fetch_ent _((AV *ar, SV* keysv, I32 lval, U32 hash));
 I32    avhv_iterinit _((AV *ar));
 HE*    avhv_iternext _((AV *ar));
 SV *   avhv_iternextsv _((AV *ar, char** key, I32* retlen));

diff --git a/toke.c b/toke.c
index d72b937..18f7266 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -3123,7 +3123,7 @@ yylex()
            in_my = TRUE;
            s = skipspace(s);
            if (isIDFIRST(*s)) {
-               s = scan_word(s, tokenbuf, TRUE, &len);
+               s = scan_word(s, tokenbuf, sizeof tokenbuf, TRUE, &len);
                in_my_stash = gv_stashpv(tokenbuf, FALSE);
                if (!in_my_stash) {
                    char tmpbuf[1024];