Proposal - Context-oriented programming

COP/examples/dependency-injection-file-slurp.pl

@@ -0,0 +1,16 @@
+
+# Well-known issue with File::Slurp is its utf8 support.
+# Should it use proposed slot mechanics then fixing it will be easy even without
+# modification of buggy module.
+
+package File::Slurp {
+	sub read_file {
+		has ${: file_name } := ...;
+		has ${: options } := ...;
+		has ${: binmode } := :optional, :default => ${: options }->{binmode};
+	}
+}
+
+# Inject default value for File::Slurp's read_file's binmode
+
+local has ${: / File::Slurp / &read_file / binmode } := ':utf8';

COP/examples/dependency-injection-prevent-login-password.pl

@@ -0,0 +1,38 @@
+
+package REST::API {
+
+	sub connect {
+		has ${: login }
+			:= :required :when (  exists ${: password})
+			:= :required :when (! exists ${: oauth})
+			:= not :available :when (exists ${: oauth })
+		;
+
+		has ${: password }
+			:= :required :when (  exists ${: login})
+			:= :required :when (! exists ${: oauth})
+			:= not :available :when (exists ${: oauth })
+		;
+
+		has ${: oauth }
+			:= not :available :when (exists ${: login })
+			:= not :available :when (exists ${: password })
+		;
+
+		has ${: authentication }
+			:= :required
+			:= not :available
+			:= :default :when (  exists ${: oauth}) => { REST::API::Authentication::Oauth->new ($oauth) }
+			:= :default :when (! exists ${: oauth}) => { REST::API::Authentication::Basic->new ($login, $password) }
+		;
+
+		return $connection;
+	}
+
+}
+
+# We can prevent usage of login/password authentication in whole program
+# without touching any line of (3rd party) code
+local has ${: / REST::API / &connect / login } := not :available;
+local has ${: / REST::API / &connect / password } := not :available;
+

COP/examples/meta-default-constant.pl

@@ -0,0 +1,12 @@
+
+# Literal values
+has $foo := :default => 1;
+has $foo := :default => [];
+has @foo := :default => 1, 2, 3;
+has @foo := :default => (1, 2, 3);
+has $foo := :default => +{};
+has &callback := :default => sub { ... };
+
+# Computed expressions
+has $foo := :default => { $bar + $baz };
+

COP/examples/multidispatch-rest-client.pl

@@ -0,0 +1,43 @@
+
+package REST::API {
+
+	sub connect {
+		has ${: login }
+			:= :required :when (  exists ${: password})
+			:= :required :when (! exists ${: oauth})
+			:= not :available :when (exists ${: oauth })
+		;
+
+		has ${: password }
+			:= :required :when (  exists ${: login})
+			:= :required :when (! exists ${: oauth})
+			:= not :available :when (exists ${: oauth })
+		;
+
+		has ${: oauth }
+			:= not :available :when (exists ${: login })
+			:= not :available :when (exists ${: password })
+		;
+
+		has ${: authentication }
+			:= :required
+			:= not :available
+			:= :default :when (  exists ${: oauth}) => { REST::API::Authentication::Oauth->new ($oauth) }
+			:= :default :when (! exists ${: oauth}) => { REST::API::Authentication::Basic->new ($login, $password) }
+		;
+
+		return ...;
+	}
+}
+
+package REST::API::Config {
+	__PACKAGE__ := :extends => REST::API;
+
+	sub connect :extends => &REST::API::connect {
+		has ${: another_method };
+
+		has ${: authentication }
+			:= :default :when (exists ${: another_method}) => { REST::API::Authentication::Another::Method ($another_method) }
+		;
+	}
+}

COP/examples/oop-inheritance.pl

@@ -0,0 +1,13 @@
+
+package Parent {
+	has ${: limit }
+		:= :is Number
+		:= :is { $_ > 0 }
+		:= :required
+	;
+
+
+}
+
+package Child {
+}

COP/examples/specify-class-properties.pl

@@ -0,0 +1,12 @@
+
+package Foo {
+
+	has ${: bar }
+		:= :is => Number
+		:= :default => ...
+		;
+
+	has @{: baz }
+		:= :is => Number
+		;
+};

COP/examples/specify-function-parameters.pl

@@ -0,0 +1,6 @@
+
+sub foo {
+	has ${: foo };
+	has ${: bar } := :default => 1;
+}
+

COP/examples/specify-multi-item-block.pl

@@ -0,0 +1,19 @@
+
+for (@list) {
+	has ${: first };
+	has ${: second };
+}
+
+map {
+	has ${: first };
+	has ${: second };
+
+	$first + $second;
+} @list;
+
+grep {
+	has ${: first };
+	has ${: second };
+
+	$first < $second;
+} @list;

COP/examples/sub-arguments-multiple-lists.pl

@@ -0,0 +1,11 @@
+
+sub foo {
+	has @list := not :positional;
+	has %hash := not :positional;
+}
+
+foo
+	@list := (1, 2, 3),
+	%list := (a => 2),
+	;
+

COP/examples/sub-arguments-named.pl

@@ -0,0 +1,26 @@
+
+sub foo {
+	has $bar := :positional;
+	has $baz := :positional := :default => 2;
+
+	return $bar . $baz;
+}
+
+# All calls returns 12
+
+foo 1;
+foo $bar := 1;
+
+# All calls returns 13
+foo 1, 3;
+
+foo 1, $baz := 3;
+foo $baz := 3, 1;
+
+foo 3, $bar := 1;
+foo $bar := 1, 3;
+
+foo $bar := 1, $baz := 3;
+foo $baz := 3, $bar := 1;
+
+foo $baz := 10, $bar := 10, $baz := 3, $bar := 1;

COP/examples/sub-arguments-non-argument.pl

@@ -0,0 +1,14 @@
+
+has $foo := 1;
+
+sub foo {
+	has $bar := :positional := :default => ${: foo };
+
+	return $bar;
+}
+
+is 1, foo;
+is 2, foo 2;
+is 3, foo $bar := 3;
+is 4, foo ${: foo } := 4;
+

COP/examples/sub-currying-exponentiation.pl

@@ -0,0 +1,24 @@
+
+sub exponentiation {
+	has $base := positional;
+	has $exponent := positional;
+	$base ** $exponent
+}
+
+sub square :extends => &exponentiation {
+   	local has ${: exponent } := not :available := 2;
+	goto &SUPER;
+}
+
+sub radix :extends => &exponentiation {
+   	local has ${: base } := not :available := 10;
+	goto &SUPER;
+}
+
+ok 100, exponentiation $base := 10, $exponent := 2;
+ok 100, square $base := 10;
+ok 100, radix $exponent := 3;
+
+# Not available curryied parameters are ignored
+ok 100, square  $base := 10, $exponent := 3;
+ok 100, decimal $base := 2, $exponent := 3;

COP/examples/sub-inheritance-getopt-long.pl

@@ -0,0 +1,19 @@
+
+package Getopt::Long {
+
+	sub callback {
+		has $option;
+		has $value;
+	}
+}
+
+GetOptions (
+	"option" => sub :extends => &Getopt::Long::callback { say "$option => $value" },
+);
+
+my $foo = sub :extends => Getopt::Long::callback;
+
+GetOptions (
+	"option" => sub :extends => $foo { say "$option => $value" },
+);
+

COP/examples/sub-inheritance-method-overload.pl

@@ -0,0 +1,17 @@
+
+package Parent {
+	sub foo {
+		has $bar;
+	}
+}
+
+package Child {
+	extend Parent::;
+
+	sub foo : extends &Parent::foo {
+		say $bar;
+
+		goto SUPER;
+	}
+}
+

COP/examples/thunk.pl

@@ -0,0 +1,28 @@
+
+my $foo = 0;
+
+sub connect {
+	has ${: dsn };
+	my $x = $foo;
+	has ${: dbh } := not :available := :default { $foo += 10; $x };
+
+	$foo++;
+
+	return ${: dbh };
+}
+
+my $rv = connect;
+
+is $foo, 1;
+is $rv, 0;
+is $foo, 11;
+
+$rv = connect;
+is $foo, 12;
+
+$rv = connect;
+is $foo, 13;
+is $rv, 12;
+is $foo, 23;
+
+

COP/tests/slot-variable-access.pl

@@ -0,0 +1,13 @@
+
+has ${: foo } := 'foo';
+
+is $foo, 'foo';
+
+{
+	local ${: foo} := 'bar';
+
+	is $foo, 'bar';
+}
+
+is $foo, 'foo';
+

COP/tests/slot-variable-exists.pl

@@ -0,0 +1,27 @@
+
+has ${: foo };
+
+ok ! exists ${: foo }, "slot's foo value is not defined in current context";
+ok ! exists $foo,      "exists can be applied on scalar accessor as well";
+
+{
+	local ${: foo } := 'bar';
+
+	ok exists ${: foo };
+	ok ! exists ${: .. / foo };
+}
+
+ok ! exists ${: foo };
+
+{
+	local ${: foo };
+
+	ok ! exists ${: foo };
+
+	$foo = 'bar';
+
+	ok exists ${: foo };
+}
+
+ok ! exists ${: foo };
+