From 35d85cfe78dd870384d3aef07a1e852267061097 Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Sat, 8 Sep 2012 01:40:52 -0500
Subject: make function arguments readonly

---
 Fun.xs       | 61 +++++++++++++++++++++++++++++++++++++++++++++++++-----------
 t/basic.t    |  5 +++++
 t/readonly.t | 32 +++++++++++++++++++++++++++++++
 3 files changed, 87 insertions(+), 11 deletions(-)
 create mode 100644 t/readonly.t

diff --git a/Fun.xs b/Fun.xs
index 061e43d..f505239 100644
--- a/Fun.xs
+++ b/Fun.xs
@@ -117,6 +117,23 @@ static SV *THX_parse_varname(pTHX_ const char *sigil)
 
 /* end stolen from Scope::Escape::Sugar */
 
+static XOP readonly_xop;
+
+static OP *pp_readonly(pTHX)
+{
+    dSP; dMARK;
+    SV** prevmark;
+
+    prevmark = MARK;
+    MARK++;
+    while (MARK <= SP) {
+        SvREADONLY_on(*MARK++);
+    }
+    SP = prevmark;
+
+    RETURN;
+}
+
 #define parse_parameter_default(i, padoffset) THX_parse_parameter_default(aTHX_ i, padoffset)
 static OP *THX_parse_parameter_default(pTHX_ IV i, PADOFFSET padoffset)
 {
@@ -153,7 +170,7 @@ static OP *THX_parse_parameter_default(pTHX_ IV i, PADOFFSET padoffset)
 #define parse_function_prototype() THX_parse_function_prototype(aTHX)
 static OP *THX_parse_function_prototype(pTHX)
 {
-    OP *myvars, *defaults, *get_args, *arg_assign;
+    OP *myvars, *defaults, *get_args, *arg_assign, *readonly, *ret;
     IV i = 0;
 
     demand_unichar('(', DEMAND_IMMEDIATE);
@@ -166,35 +183,48 @@ static OP *THX_parse_function_prototype(pTHX)
 
     myvars = newLISTOP(OP_LIST, 0, NULL, NULL);
     defaults = newLISTOP(OP_LINESEQ, 0, NULL, NULL);
+    readonly = newLISTOP(OP_CUSTOM, 0, newOP(OP_PUSHMARK, 0), NULL);
+    readonly->op_ppaddr = pp_readonly;
 
     for (;;) {
-        OP *pad_op;
+        OP *pad_op, *readonly_pad_op;
         char next;
         I32 type;
         SV *name;
+        PADOFFSET offset;
 
         lex_read_space(0);
         next = lex_peek_unichar(0);
         if (next == '$') {
-            pad_op = newOP(OP_PADSV, 0);
             name = parse_scalar_varname();
-            pad_op->op_targ = pad_add_my_scalar_sv(name);
+            offset = pad_add_my_scalar_sv(name);
+            pad_op = newOP(OP_PADSV, 0);
+            pad_op->op_targ = offset;
+            readonly_pad_op = newOP(OP_PADSV, 0);
+            readonly_pad_op->op_targ = offset;
         }
         else if (next == '@') {
-            pad_op = newOP(OP_PADAV, 0);
             name = parse_array_varname();
-            pad_op->op_targ = pad_add_my_array_sv(name);
+            offset = pad_add_my_array_sv(name);
+            pad_op = newOP(OP_PADAV, 0);
+            pad_op->op_targ = offset;
+            readonly_pad_op = newOP(OP_PADAV, 0);
+            readonly_pad_op->op_targ = offset;
         }
         else if (next == '%') {
-            pad_op = newOP(OP_PADHV, 0);
             name = parse_hash_varname();
-            pad_op->op_targ = pad_add_my_hash_sv(name);
+            offset = pad_add_my_hash_sv(name);
+            pad_op = newOP(OP_PADHV, 0);
+            pad_op->op_targ = offset;
+            readonly_pad_op = newOP(OP_PADHV, 0);
+            readonly_pad_op->op_targ = offset;
         }
         else {
             croak("syntax error");
         }
 
         op_append_elem(OP_LIST, myvars, pad_op);
+        op_append_elem(OP_CUSTOM, readonly, readonly_pad_op);
 
         lex_read_space(0);
         next = lex_peek_unichar(0);
@@ -232,9 +262,14 @@ static OP *THX_parse_function_prototype(pTHX)
     get_args = newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, gv_fetchpv("_", 0, SVt_PVAV)));
     arg_assign = newASSIGNOP(OPf_STACKED, myvars, 0, get_args);
 
-    return op_prepend_elem(OP_LINESEQ,
-                           newSTATEOP(0, NULL, arg_assign),
-                           defaults);
+    ret = op_prepend_elem(OP_LINESEQ,
+                          newSTATEOP(0, NULL, arg_assign),
+                          defaults);
+    ret = op_append_elem(OP_LINESEQ,
+                         ret,
+                         readonly);
+
+    return ret;
 }
 
 static OP *parse_fun(pTHX_ GV *namegv, SV *psobj, U32 *flagsp)
@@ -318,4 +353,8 @@ BOOT:
 {
     cv_set_call_parser(get_cv("Fun::fun", 0), parse_fun, &PL_sv_undef);
     cv_set_call_checker(get_cv("Fun::fun", 0), check_fun, &PL_sv_undef);
+    XopENTRY_set(&readonly_xop, xop_name, "readonly");
+    XopENTRY_set(&readonly_xop, xop_desc, "readonly");
+    XopENTRY_set(&readonly_xop, xop_class, OA_LISTOP);
+    Perl_custom_op_register(aTHX_ pp_readonly, &readonly_xop);
 }
diff --git a/t/basic.t b/t/basic.t
index 080c2cf..2b2104f 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -29,4 +29,9 @@ is(sum(1, 2, 3, 4), 10);
 
 ok(exists $Foo::{foo});
 
+fun empty ($bar, $baz) { }
+
+is(scalar(empty(1, 2)), undef);
+is_deeply([empty(1, 2)], []);
+
 done_testing;
diff --git a/t/readonly.t b/t/readonly.t
new file mode 100644
index 0000000..f0b82ea
--- /dev/null
+++ b/t/readonly.t
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Fun;
+
+my $thing = 1;
+
+fun foo ($bar) { $bar = 1 }
+
+ok(!eval { foo(); 1 });
+ok(!eval { foo(1); 1 });
+ok(!eval { foo($thing); 1 });
+ok(!eval { foo($thing + 1); 1 });
+
+fun bar ($baz) { $baz }
+
+ok(eval { bar(); 1 });
+ok(eval { bar(1); 1 });
+ok(eval { bar($thing); 1 });
+ok(eval { bar($thing + 1); 1 });
+
+ok(eval { $thing = 2; 1 });
+is($thing, 2);
+
+fun baz ($quux) { $_[0] = 1 }
+
+ok(eval { baz($thing); 1 });
+is($thing, 1);
+
+done_testing;
-- 
cgit v1.2.3-54-g00ecf