lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Hash;
   2 use Moose::Role;
   3
   4 sub exists : method {
   5     my ($attr) = @_;
   6     return sub { exists $attr->get_value($_[0])->{$_[1]} ? 1 : 0 };
   7 }
   8
   9 sub get : method {
  10     my ($attr) = @_;
  11     return sub { $attr->get_value($_[0])->{$_[1]} };
  12 }
  13
  14 sub set : method {
  15     my ($attr) = @_;
  16     if ($attr->has_container_type) {
  17         my $container_type_constraint = $attr->container_type_constraint;
  18         return sub {
  19             ($container_type_constraint->check($_[2]))
  20                 || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
  21             $attr->get_value($_[0])->{$_[1]} = $_[2]
  22         };
  23     }
  24     else {
  25         return sub { $attr->get_value($_[0])->{$_[1]} = $_[2] };
  26     }
  27 }
  28
  29 sub keys : method {
  30     my ($attr) = @_;
  31     return sub { keys %{$attr->get_value($_[0])} };
  32 }
  33
  34 sub values : method {
  35     my ($attr) = @_;
  36     return sub { values %{$attr->get_value($_[0])} };
  37 }
  38
  39 sub count : method {
  40     my ($attr) = @_;
  41     return sub { scalar keys %{$attr->get_value($_[0])} };
  42 }
  43
  44 sub empty : method {
  45     my ($attr) = @_;
  46     return sub { scalar keys %{$attr->get_value($_[0])} ? 1 : 0 };
  47 }
  48
  49 sub delete : method {
  50     my ($attr) = @_;
  51     return sub { delete $attr->get_value($_[0])->{$_[1]} };
  52 }
  53
  54 1;
  55
  56 __END__
  57
  58 =pod
  59
  60 =head1 NAME
  61
  62 MooseX::AttributeHelpers::MethodProvider::Hash
  63
  64 =head1 DESCRIPTION
  65
  66 This is a role which provides the method generators for
  67 L<MooseX::AttributeHelpers::Collection::Hash>.
  68
  69 =head1 METHODS
  70
  71 =over 4
  72
  73 =item B<meta>
  74
  75 =back
  76
  77 =head1 PROVIDED METHODS
  78
  79 =over 4
  80
  81 =item B<count>
  82
  83 =item B<delete>
  84
  85 =item B<empty>
  86
  87 =item B<exists>
  88
  89 =item B<get>
  90
  91 =item B<keys>
  92
  93 =item B<set>
  94
  95 =item B<values>
  96
  97 =back
  98
  99 =head1 BUGS
 100
 101 All complex software has bugs lurking in it, and this module is no
 102 exception. If you find a bug please either email me, or add the bug
 103 to cpan-RT.
 104
 105 =head1 AUTHOR
 106
 107 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 108
 109 =head1 COPYRIGHT AND LICENSE
 110
 111 Copyright 2007 by Infinity Interactive, Inc.
 112
 113 L<http://www.iinteractive.com>
 114
 115 This library is free software; you can redistribute it and/or modify
 116 it under the same terms as Perl itself.
 117
 118 =cut
 119