t/003-apply.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 20;
   5 use Test::Exception;
   6
   7 my %args;
   8 do {
   9     package MyRole::Storage;
  10     use MooseX::Role::Parameterized;
  11     use Moose::Util::TypeConstraints;
  12
  13     parameter format => (
  14         isa      => (enum ['Dumper', 'Storable']),
  15         required => 1,
  16     );
  17
  18     parameter freeze_method => (
  19         isa     => 'Str',
  20         lazy    => 1,
  21         default => sub { "freeze_" . shift->format },
  22     );
  23
  24     parameter thaw_method => (
  25         isa     => 'Str',
  26         lazy    => 1,
  27         default => sub { "thaw_" . shift->format },
  28     );
  29
  30     role {
  31         my $p = shift;
  32         %args = @_;
  33
  34         my $format = $p->format;
  35
  36         my ($freezer, $thawer);
  37
  38         if ($format eq 'Dumper') {
  39             require Data::Dumper;
  40             $freezer = \&Data::Dumper::Dumper;
  41             $thawer  = sub { eval "@_" };
  42
  43         }
  44         elsif ($format eq 'Storable') {
  45             require Storable;
  46             $freezer = \&Storable::nfreeze;
  47             $thawer  = \&Storable::thaw;
  48         }
  49         else {
  50             die "Unknown format ($format)";
  51         }
  52
  53         method $p->freeze_method => $freezer;
  54         method $p->thaw_method   => $thawer;
  55     };
  56 };
  57
  58 do {
  59     package MyClass::Dumper;
  60     use Moose;
  61     with 'MyRole::Storage' => {
  62         format => 'Dumper',
  63     };
  64 };
  65
  66 can_ok('MyClass::Dumper' => qw(freeze_Dumper thaw_Dumper));
  67 cant_ok('MyClass::Dumper' => qw(freeze_Storable thaw_Storable));
  68
  69 is($args{consumer}, MyClass::Dumper->meta, 'Role block receives consumer');
  70
  71 do {
  72     package MyClass::Storable;
  73     use Moose;
  74     with 'MyRole::Storage' => {
  75         format => 'Storable',
  76     };
  77 };
  78
  79 can_ok('MyClass::Storable' => qw(freeze_Storable thaw_Storable));
  80 cant_ok('MyClass::Storable' => qw(freeze_Dumper thaw_Dumper));
  81
  82 is($args{consumer}, MyClass::Storable->meta, 'Role block receives consumer');
  83
  84 do {
  85     package MyClass::DumperRenamed;
  86     use Moose;
  87     with 'MyRole::Storage' => {
  88         format => 'Dumper',
  89         freeze_method => 'save',
  90         thaw_method   => 'load',
  91     };
  92 };
  93
  94 can_ok('MyClass::DumperRenamed' => qw(save load));
  95 cant_ok('MyClass::DumperRenamed' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable));
  96
  97 is($args{consumer}, MyClass::DumperRenamed->meta, 'Role block receives consumer');
  98
  99 do {
 100     package MyClass::Both;
 101     use Moose;
 102     with 'MyRole::Storage' => { format => 'Dumper'   };
 103     with 'MyRole::Storage' => { format => 'Storable' };
 104 };
 105
 106 can_ok('MyClass::Both' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable));
 107 is($args{consumer}, MyClass::Both->meta, 'Role block receives consumer');
 108
 109 do {
 110     package MyClass::Three;
 111     use Moose;
 112     with 'MyRole::Storage' => { format => 'Dumper'   };
 113     with 'MyRole::Storage' => { format => 'Storable' };
 114     with 'MyRole::Storage' => {
 115         format        => 'Storable',
 116         freeze_method => 'store',
 117         thaw_method   => 'dump',
 118     };
 119 };
 120
 121 can_ok('MyClass::Three' => qw(freeze_Dumper freeze_Storable thaw_Dumper thaw_Storable store dump));
 122 is($args{consumer}, MyClass::Three->meta, 'Role block receives consumer');
 123
 124 throws_ok {
 125     package MyClass::Error::Required;
 126     use Moose;
 127     with 'MyRole::Storage';
 128 } qr/^Attribute \(format\) is required/;
 129
 130 throws_ok {
 131     package MyClass::Error::Invalid;
 132     use Moose;
 133     with 'MyRole::Storage' => {
 134         format => 'YAML',
 135     };
 136 } qr/^Attribute \(format\) does not pass the type constraint/;
 137
 138 sub cant_ok {
 139     local $Test::Builder::Level = $Test::Builder::Level + 1;
 140     my $instance = shift;
 141     for my $method (@_) {
 142         ok(!$instance->can($method), "$instance cannot $method");
 143     }
 144 }
 145