Permalink
Browse files

factor more type coercion into the type library

  • Loading branch information...
1 parent b939d9a commit eb2db384cd4f70eb7d30c8f4cb30c555be9c9949 @mjgardner committed Feb 24, 2012
Showing with 42 additions and 24 deletions.
  1. +0 −1 dist.ini
  2. +7 −19 lib/Tree/Path/Class.pm
  3. +34 −3 lib/Tree/Path/Class/Types.pm
  4. +1 −1 perlcritic.rc
View
@@ -9,7 +9,6 @@ copyright_holder = GSI Commerce
[AutoPrereqs]
[Prereqs]
perl = 5.010
-Throwable::Error = 0
[NextRelease]
[PkgDist]
[OurPkgVersion]
View
@@ -9,28 +9,21 @@ use Const::Fast;
use English '-no_match_vars';
use Path::Class;
use Moose;
-use Moose::Util::TypeConstraints;
use MooseX::Has::Options;
use MooseX::NonMoose;
-use MooseX::Types::Path::Class qw(Dir is_Dir to_Dir File is_File to_File);
-use Tree::Path::Class::Types 'TreePath';
+use Tree::Path::Class::Types qw(TreePath TreePathValue);
use MooseX::MarkAsMethods autoclean => 1;
extends 'Tree';
-# make our own error class for throwing exceptions
-const my $ERROR => __PACKAGE__ . '::Error';
-Moose::Meta::Class->create(
- $ERROR => ( superclasses => ['Throwable::Error'] ) );
-
# defang Moose's hashref params
around BUILDARGS => sub { &{ $ARG[0] }( $ARG[1] ) };
# coerce constructor arguments to Dir or File
sub FOREIGNBUILDARGS { return _value_to_path( @ARG[ 1 .. $#ARG ] ) }
has path => (
- qw(:ro :lazy),
- isa => maybe_type( union( [ Dir, File ] ) ),
+ qw(:ro :lazy :coerce),
+ isa => TreePathValue,
init_arg => undef,
writer => '_set_path',
default => sub { $ARG[0]->_tree_to_path },
@@ -79,18 +72,13 @@ sub _tree_to_path {
# coerce a value to a Dir or File if necessary
sub _value_to_path {
- return if !@ARG;
- my @args = @ARG;
- for my $arg ( grep {$ARG} @args ) {
- if ( not( is_Dir($arg) or is_File($arg) ) ) {
- $arg = to_Dir($arg) or $ERROR->throw(q{couldn't coerce to a dir});
- }
- }
- return is_File( $args[-1] ) ? to_File( \@args ) : to_Dir( \@args );
+ my @args = @_;
+ return TreePathValue->check( \@args )
+ ? @args
+ : TreePathValue->assert_coerce( \@args );
}
__PACKAGE__->meta->make_immutable();
-no Moose::Util::TypeConstraints;
no Moose;
1;
@@ -5,13 +5,17 @@ package Tree::Path::Class::Types;
use strict;
# VERSION
-use Tree;
-use Tree::Path::Class;
-use MooseX::Types -declare => [qw(TreePath Tree)];
+use Carp;
+use Path::Class;
+use MooseX::Types -declare => [qw(TreePath TreePathValue Tree)];
+use MooseX::Types::Moose qw(ArrayRef Maybe Str);
+use MooseX::Types::Path::Class qw(Dir is_Dir to_Dir File is_File to_File);
## no critic (Subroutines::ProhibitCallsToUndeclaredSubs)
class_type Tree, { class => 'Tree' };
class_type TreePath, { class => 'Tree::Path::Class' };
+subtype TreePathValue,
+ as Maybe [ Dir | File ]; ## no critic (Bangs::ProhibitBitwiseOperators)
coerce TreePath, from Tree, via {
my $tree = $_;
@@ -20,6 +24,23 @@ coerce TreePath, from Tree, via {
return $tpc;
};
+coerce TreePathValue,
+ from Dir, via { dir($_) },
+ from File, via { file($_) },
+ from ArrayRef, via { _coerce_val( @{$_} ) },
+ from Str, via { _coerce_val($_) };
+
+sub _coerce_val {
+ return if !( my @args = @_ );
+ for my $arg ( grep {$_} @args ) {
+ if ( not( is_Dir($arg) or is_File($arg) ) ) {
+ $arg = to_Dir($arg)
+ or croak; ## no critic (ErrorHandling::RequireUseOfExceptions)
+ }
+ }
+ return is_File( $args[-1] ) ? to_File( \@args ) : to_Dir( \@args );
+}
+
1;
# ABSTRACT: Type library for Tree::Path::Class
@@ -40,3 +61,13 @@ L<Tree::Path::Class|Tree::Path::Class>.
An object of L<Tree::Path::Class|Tree::Path::Class>. Can coerce from
L<Tree|Tree>, where it will also coerce the tree's children.
+
+=type TreePathValue
+
+Can either be undefined. a L<Path::Class::Dir|Path::Class::Dir> or a
+L<Path::Class:File|Path::Class::File>. Handles all the coercions that
+L<MooseX::Types::Path::Class|MooseX::Types::Path::Class> handles.
+
+=type Tree
+
+A L<Tree|Tree> object.
View
@@ -18,7 +18,7 @@ above_version = 5.010
flowcontrol = carp cluck confess croak die exit goto warn exit
[Documentation::PodSpelling]
-stop_words = Perldoc perldoc annonations PASSed prepended superclass FOREIGNBUILDARGS hashref accessor TreePath
+stop_words = Perldoc perldoc annonations PASSed prepended superclass FOREIGNBUILDARGS hashref accessor TreePath TreePathValue
[Documentation::RequirePodSections]
lib_sections = NAME | VERSION | SYNOPSIS | DESCRIPTION | SUPPORT | AUTHOR | COPYRIGHT AND LICENSE

0 comments on commit eb2db38

Please sign in to comment.