Implement ability of regex matches to set $/

sorear · Dec 4, 2010 · e7be5b2 · e7be5b2
1 parent d8c3188
commit e7be5b2
Show file tree

Hide file tree

Showing 7 changed files with 55 additions and 6 deletions.
diff --git a/lib/Kernel.cs b/lib/Kernel.cs
@@ -1509,6 +1509,36 @@ public class Kernel {
             }
         }
 
+        public static void SetStatus(Frame th, string name, Variable v) {
+            th = th.caller;
+            while (true) {
+                string n = th.info.name;
+                // Mega-Hack: These functions wrap stuff and should
+                // propagate $/
+                if (n == "SAFE infix:<~~>") {
+                    th = th.caller;
+                    continue;
+                }
+                break;
+            }
+            if (th.lex == null)
+                th.lex = new Dictionary<string,object>();
+            th.lex[name] = v;
+        }
+
+        public static Variable StatusHelper(Frame th, string name, int up) {
+            object rt;
+            uint m = SubInfo.FilterForName(name);
+            while (th != null) {
+                if (up <= 0 && th.TryGetDynamic(name, m, out rt)) {
+                    return (Variable)rt;
+                }
+                th = th.outer;
+                up--;
+            }
+            return NewROScalar(AnyP);
+        }
+
         public static Variable DefaultNew(IP6 proto) {
             DynObject n = new DynObject(((DynObject)proto).mo);
             DynMetaObject[] mro = n.mo.mro;

diff --git a/lib/SAFE.setting b/lib/SAFE.setting
@@ -960,8 +960,11 @@ my class Regex is Sub {
                 (l iter (vvarlist_new_singleton
                     (subcall (@ {self}) (ns (l csr)))))
                 (ternary (iter_hasflat (l iter))
-                  (return (newrwlistvar (@ (vvarlist_shift (l iter)))))
+                  (letn val (vvarlist_shift (l iter))
+                    (set_status (s $*/) (l val))
+                    (return (newrwlistvar (@ (l val)))))
                   (prog))))
+              (set_status (s $*/) {Match})
               {Any})
         };
     }

diff --git a/src/CgOp.pm b/src/CgOp.pm
@@ -243,6 +243,8 @@ use warnings;
     sub control        { rawscall('Kernel.SearchForHandler', CgOp::int(shift()),
             @_) }
     sub context_get    { rawscall('Kernel.ContextHelper', callframe(), $_[0], $_[1]) }
+    sub status_get    { rawscall('Kernel.StatusHelper:m,Variable', callframe(), $_[0], $_[1]) }
+    sub set_status    { rawscall('Kernel.SetStatus:m,Void', callframe(), $_[0], $_[1]) }
     sub startgather    { rawscall('Kernel.GatherHelper', $_[0]) }
     sub get_first      { rawscall('Kernel.GetFirst', $_[0]) }
     sub promote_to_list{ rawscall('Kernel.PromoteToList:c,Variable', $_[0]) }

diff --git a/src/CgOpToCLROp.pm b/src/CgOpToCLROp.pm
@@ -340,14 +340,14 @@ sub codegen {
     local %lettypes;
     local $spill = 0;
 
-    #say(YAML::XS::Dump($root));
+    #say(YAML::XS::Dump($root)) if $cg->csname eq 'G256ACCEPTSC';
     my @stmts = cvt($root)->stmts_result;
-    #say(YAML::XS::Dump(@stmts));
+    #say(YAML::XS::Dump(@stmts)) if $cg->csname eq 'G256ACCEPTSC';
 
     for (@stmts) {
         codegen_term($cg, $_)
             if !$cg->unreach || $_->op->[0] eq 'ehspan' ||
-                $_->op->[0] eq 'labelhere';
+                $_->op->[0] eq 'labelhere' || $_->op->[0] eq 'drop_let';
     }
 }
 

diff --git a/src/CodeGen.pm b/src/CodeGen.pm
@@ -124,7 +124,9 @@ use CLRTypes;
 
     sub drop_let {
         my ($self, $which) = @_;
-        die "Let consistency error" if $which ne $self->letstack->[-1][0];
+        if ($which ne $self->letstack->[-1][0]) {
+            Carp::confess "Let consistency error: $which, " . YAML::XS::Dump($self->letstack);
+        }
         my $r = pop @{ $self->letstack };
         $self->letused->{ $r->[4] } = 0;
     }

diff --git a/src/Op.pm b/src/Op.pm
@@ -946,7 +946,9 @@ use CgOp;
 
     sub code {
         my ($self, $body) = @_;
-        CgOp::context_get(CgOp::clr_string($self->name), CgOp::int($self->uplevel));
+        my @a = (CgOp::clr_string($self->name), CgOp::int($self->uplevel));
+        ($self->name eq '$*/' || $self->name eq '$*!') ?
+            CgOp::status_get(@a) : CgOp::context_get(@a);
     }
 
     __PACKAGE__->meta->make_immutable;

diff --git a/test2.pl b/test2.pl
@@ -8,6 +8,16 @@
     is A.new + 23, 65, '+ calls user-written .Numeric';
 }
 
+{
+    "abc" ~~ /. (.) ./;
+    is $0, 'b', 'Regex matches set $/';
+}
+
+{
+    "abc" ~~ /de(.)/;
+    ok !defined($/), 'Failed regex matches clear $/';
+}
+
 #is $?FILE, 'test.pl', '$?FILE works';
 #is $?ORIG.substr(0,5), '# vim', '$?ORIG works';