[libmixin-extrafields-param-perl] 02/25: first pass implemented

[Florian Schlichting]

This is an automated email from the git hooks/post-receive script.

fsfs pushed a commit to annotated tag 0.001
in repository libmixin-extrafields-param-perl.

commit 9da24f13051b4748388f2cc68985ee4f680f03a7
Author: Ricardo SIGNES <rjbs at codesimply.com>
Date:   Thu Dec 22 20:44:24 2005 +0000

    first pass implemented
---
 lib/Does/Param.pm | 38 ++++++++++++++++++++++++++++++++++-
 t/basic.t         | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 t/gc.t            | 25 +++++++++++++++++++++++
 3 files changed, 121 insertions(+), 1 deletion(-)

diff --git a/lib/Does/Param.pm b/lib/Does/Param.pm
index 132de25..4ec256e 100644
--- a/lib/Does/Param.pm
+++ b/lib/Does/Param.pm
@@ -3,6 +3,13 @@ package Does::Param;
 use warnings;
 use strict;
 
+use Carp ();
+use Exporter qw(import);
+use Scalar::Util ();
+use Tie::RefHash::Weak;
+
+our @EXPORT = our @EXPORT_OK = qw(param);
+
 =head1 NAME
 
 Does::Param - make your class provide a familiar "param" method
@@ -47,8 +54,37 @@ provided by L<CGI>, L<CGI::Application>, and other classes.
 
 =cut
 
-sub param {
+tie my %_params_for, 'Tie::RefHash::Weak';
 
+sub __params_storage_guts { %_params_for }
+
+sub param {
+  my $self = shift;
+  
+  Carp::croak "param is an instance method" unless Scalar::Util::blessed($self);
+
+  my $stash = $_params_for{ $self } ||= {};
+
+  return keys %$stash unless @_;
+
+  @_ = %{$_[0]} if @_ == 1 and ref $_[0] eq 'HASH';
+  
+  Carp::croak "invalid call to param: odd, non-one number of params"
+    if @_ > 1 and @_ % 2 == 1;
+
+  if (@_ == 1) {
+    my $key = $_[0];
+    return unless exists $stash->{$key};
+    return $stash->{$key};
+  }
+
+  my @return;
+  while (@_) {
+    my ($key, $value) = splice @_, 0, 2;
+    $stash->{$key} = $value;
+    push @return, $value;
+  }
+  return wantarray ? @return : $return[0];
 }
 
 =head1 AUTHOR
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..45601d5
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,59 @@
+#!perl -T
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+{
+  package Widget::Parameterized;
+  use Does::Param;
+
+  sub new { bless {} => shift; }
+}
+
+my $widget = Widget::Parameterized->new;
+
+isa_ok($widget, 'Widget::Parameterized');
+can_ok($widget, 'param');
+
+{
+  my @names = $widget->param;
+  cmp_ok(@names, '==', 0, "there are zero params to start with");
+}
+
+is(
+  $widget->param('flavor'),
+  undef,
+  "a specific param is also unset",
+);
+
+{
+  my @names = $widget->param;
+  cmp_ok(@names, '==', 0, "checking on a given param didn't create it");
+}
+
+is(
+  $widget->param(flavor => 'teaberry'),
+  'teaberry',
+  "we set a param and got its value back",
+);
+
+is(
+  $widget->param('flavor'),
+  'teaberry',
+  "...and that value stuck",
+);
+
+{
+  my @names = $widget->param;
+  cmp_ok(@names, '==', 1, "so now there is one param");
+}
+
+{
+  my @values = $widget->param(size => 'big', limits => undef);
+  cmp_ok(@values, '==', 2, "we get back two values");
+  is_deeply(\@values, [ 'big', undef ], "...and they're the two set set");
+
+  my @names = $widget->param;
+  cmp_ok(@names, '==', 3, "we set two more, now there are three");
+}
diff --git a/t/gc.t b/t/gc.t
new file mode 100644
index 0000000..50daa33
--- /dev/null
+++ b/t/gc.t
@@ -0,0 +1,25 @@
+#!perl -T
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+{
+  package Widget::Parameterized;
+  use Does::Param;
+
+  sub new { bless {} => shift; }
+}
+
+{
+  my $widget = Widget::Parameterized->new;
+  $widget->param(flavor => 'teaberry');
+  $widget->param(size => 'big', limits => undef);
+
+  my %guts = Does::Param->__params_storage_guts;
+  ok(scalar %guts, "there are some params being stored universally (duh)");
+  ok($guts{$widget}, "the widget has some params");
+}
+
+my %guts = Does::Param->__params_storage_guts;
+ok(!(scalar %guts), "post GC, there are no params being stored universally");

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libmixin-extrafields-param-perl.git