Implement push, pop, shift, unshift and splice for Perl 5 arrays

Fix GH #98
niner · Oct 2, 2017 · 92fe4b5 · 92fe4b5
1 parent f66e9b4
commit 92fe4b5
Show file tree

Hide file tree

Showing 4 changed files with 145 additions and 1 deletion.
diff --git a/lib/Inline/Perl5/Array.pm6 b/lib/Inline/Perl5/Array.pm6
@@ -64,4 +64,74 @@ class Inline::Perl5::Array does Iterable does Positional {
     multi method Str(Inline::Perl5::Array:D:) {
         self.Array.Str
     }
+    method pop(Inline::Perl5::Array:D:) {
+        $!ip5.p5_to_p6($!p5.p5_av_pop($!av));
+    }
+    method push(Inline::Perl5::Array:D: Mu \val --> Nil) {
+        $!p5.p5_av_push($!av, $!ip5.p6_to_p5(val));
+    }
+    method shift(Inline::Perl5::Array:D:) {
+        $!ip5.p5_to_p6($!p5.p5_av_shift($!av));
+    }
+    method unshift(Inline::Perl5::Array:D: Mu \val --> Nil) {
+        $!p5.p5_av_unshift($!av, $!ip5.p6_to_p5(val));
+    }
+    multi method splice(Inline::Perl5::Array:D:) {
+        my $retval = self.Array;
+        $!p5.p5_av_clear($!av);
+        $retval
+    }
+    multi method splice(Inline::Perl5::Array:D: Int:D $offset) {
+        my @retval;
+        my $size = self.elems - $offset;
+        @retval[$size - 1 - $++] = self.pop for ^$size;
+        @retval
+    }
+    multi method splice(Inline::Perl5::Array:D: Int:D $offset, Int:D $size) {
+        my @retval;
+        my $elems = self.elems;
+        for ^$size -> $i {
+            @retval[$i] = self.AT-POS($offset + $i);
+            $!p5.p5_av_delete($!av, $offset + $i);
+        }
+        for ($offset + $size)..$elems {
+            self.ASSIGN-POS($_ - $size, self.AT-POS($_));
+        }
+        # truncate array to new size
+        for ($elems...($elems - $size)) {
+            $!p5.p5_av_delete($!av, $_);
+        }
+        @retval
+    }
+    multi method splice(Inline::Perl5::Array:D: Int:D $offset, Int:D $size, @new) {
+        my @retval;
+        my $elems = self.elems;
+        for ^$size -> $i {
+            @retval[$i] = self.AT-POS($offset + $i);
+            $!p5.p5_av_delete($!av, $offset + $i);
+        }
+        if @new.elems < $size {
+            for @new {
+                self.ASSIGN-POS($offset + $++, $_);
+            }
+            for ($offset + $size)..$elems {
+                self.ASSIGN-POS($_ - $size + @new.elems, self.AT-POS($_));
+            }
+            # truncate array to new size
+            for ($elems...($elems - $size + 1)) {
+                $!p5.p5_av_delete($!av, $_);
+            }
+        }
+        else {
+            if $elems > $offset + $size {
+                for ($elems - 1)...($offset + $size) {
+                    self.ASSIGN-POS($_ + @new.elems - $size, self.AT-POS($_));
+                }
+            }
+            for @new.pairs {
+                self.ASSIGN-POS($offset + $_.key, $_.value);
+            }
+        }
+        @retval
+    }
 }
diff --git a/lib/Inline/Perl5/Interpreter.pm6 b/lib/Inline/Perl5/Interpreter.pm6
@@ -115,9 +115,24 @@ class Inline::Perl5::Interpreter is repr('CPointer') {
     method p5_av_store(Pointer, int32, Pointer) is native($p5helper)
         { ... }
 
+    method p5_av_pop(Pointer) is native($p5helper)
+        returns Pointer { ... }
+
     method p5_av_push(Pointer, Pointer) is native($p5helper)
         { ... }
 
+    method p5_av_shift(Pointer) is native($p5helper)
+        returns Pointer { ... }
+
+    method p5_av_unshift(Pointer, Pointer) is native($p5helper)
+        { ... }
+
+    method p5_av_delete(Pointer, int32) is native($p5helper)
+        { ... }
+
+    method p5_av_clear(Pointer) is native($p5helper)
+        { ... }
+
     method p5_hv_iterinit(Pointer) is native($p5helper)
         returns int32 { ... }
 

diff --git a/p5helper.c b/p5helper.c
@@ -328,11 +328,39 @@ void p5_av_store(PerlInterpreter *my_perl, AV *av, I32 key, SV *val) {
     return;
 }
 
+SV *p5_av_pop(PerlInterpreter *my_perl, AV *av) {
+    PERL_SET_CONTEXT(my_perl);
+    return av_pop(av);
+}
+
 void p5_av_push(PerlInterpreter *my_perl, AV *av, SV *sv) {
     PERL_SET_CONTEXT(my_perl);
     av_push(av, sv);
 }
 
+SV *p5_av_shift(PerlInterpreter *my_perl, AV *av) {
+    PERL_SET_CONTEXT(my_perl);
+    return av_shift(av);
+}
+
+void p5_av_unshift(PerlInterpreter *my_perl, AV *av, SV *sv) {
+    PERL_SET_CONTEXT(my_perl);
+    av_unshift(av, 1);
+    SvREFCNT_inc(sv);
+    if (av_store(av, 0, sv) == NULL)
+        SvREFCNT_dec(sv);
+}
+
+void p5_av_delete(PerlInterpreter *my_perl, AV *av, I32 key) {
+    PERL_SET_CONTEXT(my_perl);
+    av_delete(av, key, G_DISCARD);
+}
+
+void p5_av_clear(PerlInterpreter *my_perl, AV *av) {
+    PERL_SET_CONTEXT(my_perl);
+    av_clear(av);
+}
+
 I32 p5_hv_iterinit(PerlInterpreter *my_perl, HV *hv) {
     PERL_SET_CONTEXT(my_perl);
     return hv_iterinit(hv);

diff --git a/t/modify_array.t b/t/modify_array.t
@@ -3,7 +3,7 @@ use v6.c;
 use Test;
 use MONKEY-SEE-NO-EVAL;
 
-plan 16;
+plan 31;
 
 my &array-creator = EVAL q:to<PERL5>, :lang<Perl5>;
     sub {
@@ -37,5 +37,36 @@ my $array = array-creator(sub (@array) {
 });
 
 is($array, [1, 2, 3, 4]);
+is $array.pop, 4;
+is($array, [1, 2, 3]);
+$array.push: 4;
+is($array, [1, 2, 3, 4]);
+is $array.shift, 1;
+is($array, [2, 3, 4]);
+$array.unshift: 1;
+is($array, [1, 2, 3, 4]);
+
+is($array.splice(2), [3, 4]);
+is $array, [1, 2];
+
+$array.push: 3;
+$array.push: 4;
+is($array.splice(2, 1), [3]);
+is $array, [1, 2, 4];
+
+$array.splice(2, 0, [3]);
+is($array.splice, [1, 2, 3, 4]);
+is $array, [];
+
+$array.splice: 0, 0, [1, 2, 3, 4];
+is $array, [1, 2, 3, 4];
+
+$array.splice: 1, 2, [7];
+is $array, [1, 7, 4];
+
+$array.splice: 1, 1, [2, 3, 5, 6];
+is $array, [1, 2, 3, 5, 6, 4];
+
+$array.splice: 3, 0, $array.splice: 4, 1;
 
 # vim: ft=perl6