use strict;
use warnings;
+use FindBin;
-use Test::More no_plan => 1;
+use Test::More;
use Test::Exception;
-use Test::Deep;
-use Data::Dumper;
+use Moose::Util::TypeConstraints;
-BEGIN
+subtype 'FilePath'
+ => as 'Str'
+ # This used to try to _really_ check for a valid Unix or Windows
+ # path, but the regex wasn't quite right, and all we care about
+ # for the tests is that it rejects '/'
+ => where { $_ ne '/' };
{
- use_ok('Moose');
-}
-
-{
- use Moose::Util::TypeConstraints;
+ package Baz;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
- subtype 'FilePath'
- => as 'Str'
- => where { $_ =~ m#^(/[a-zA-Z0-9_.-]+)+$#; }; # '/' (root) forbidden!
+ # Defining this causes the FIRST call to Baz->new w/o param to fail,
+ # if no call to ANY Moose::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ }
}
{
- package Baz;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'path' =>
- (
- is => 'ro',
- isa => 'FilePath',
- required => 1,
- );
-
- sub BUILD
- {
- my ( $self, $params ) = @_;
-
- confess $params->{path} . " does not exist" unless -e $params->{path};
-
- # open files etc.
- }
-
- # Defining this causes the FIRST call to Baz->new w/o param to fail,
- # if no call to ANY Moose::Object->new was done before.
- #
- sub DEMOLISH
- {
- my ( $self ) = @_;
-
- # cleanup files etc.
- }
-}
+ package Qee;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
-{
- package Qee;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'path' =>
- (
- is => 'ro',
- isa => 'FilePath',
- required => 1,
- );
-
- sub BUILD
- {
- my ( $self, $params ) = @_;
-
- confess $params->{path} . " does not exist" unless -e $params->{path};
-
- # open files etc.
- }
-
- # Defining this causes the FIRST call to Qee->new w/o param to fail...
- # if no call to ANY Moose::Object->new was done before.
- #
- sub DEMOLISH
- {
- my ( $self ) = @_;
-
- # cleanup files etc.
- }
+ # Defining this causes the FIRST call to Qee->new w/o param to fail...
+ # if no call to ANY Moose::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ }
}
{
- package Foo;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'path' =>
- (
- is => 'ro',
- isa => 'FilePath',
- required => 1,
- );
-
- sub BUILD
- {
- my ( $self, $params ) = @_;
-
- confess $params->{path} . " does not exist" unless -e $params->{path};
-
- # open files etc.
- }
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
- # Having no DEMOLISH, everything works as expected...
- #
+ # Having no DEMOLISH, everything works as expected...
}
-# Uncomment only one block per test run:
-#
-
-#=pod
-check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error
-check_em ( 'Qee' ); # ok
-check_em ( 'Foo' ); # ok
-#=cut
-
-#=pod
-check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error
-check_em ( 'Baz' ); # ok
-check_em ( 'Foo' ); # ok
-#=cut
-
-#=pod
-check_em ( 'Foo' ); # ok
-check_em ( 'Baz' ); # ok !
-check_em ( 'Qee' ); # ok
-#=cut
-
+check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error
+check_em ( 'Qee' ); # ok
+check_em ( 'Foo' ); # ok
+
+check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error
+check_em ( 'Baz' ); # ok
+check_em ( 'Foo' ); # ok
+
+check_em ( 'Foo' ); # ok
+check_em ( 'Baz' ); # ok !
+check_em ( 'Qee' ); # ok
+
+
+sub check_em {
+ my ( $pkg ) = @_;
+ my ( %param, $obj );
+
+ # Uncomment to see, that it is really any first call.
+ # Subsequents calls will not fail, aka giving the correct error.
+ {
+ local $@;
+ my $obj = eval { $pkg->new; };
+ ::like( $@, qr/is required/, "... $pkg plain" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new(); };
+ ::like( $@, qr/is required/, "... $pkg empty" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( notanattr => 1 ); };
+ ::like( $@, qr/is required/, "... $pkg undef" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( %param ); };
+ ::like( $@, qr/is required/, "... $pkg undef param" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => '/' ); };
+ ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); };
+ ::like( $@, qr/does not exist/, "... $pkg non existing path" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => $FindBin::Bin ); };
+ ::is( $@, '', "... $pkg no error" );
+ ::isa_ok( $obj, $pkg );
+ ::isa_ok( $obj, 'Moose::Object' );
+ ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" );
+ }
+}
-sub check_em
-{
- my ( $pkg ) = @_;
-
- my ( %param, $obj );
-
-# Uncomment to see, that it is really any first call.
-# Subsequents calls will not fail, aka giving the correct error.
- #
- #=pod
- {
- local $@;
- my $obj = eval { $pkg->new; };
- ::like ( $@, qr/is required/, "... $pkg plain" );
- ::is ( $obj, undef, "" );
- }
- {
- local $@;
- my $obj = eval { $pkg->new(); };
- ::like ( $@, qr/is required/, "... $pkg empty" );
- ::is ( $obj, undef, "" );
- }
- {
- local $@;
- my $obj = eval { $pkg->new ( undef ); };
- ::like ( $@, qr/is required/, "... $pkg undef" );
- ::is ( $obj, undef, "" );
- }
- #=cut
- {
- local $@;
- my $obj = eval { $pkg->new ( %param ); };
- ::like ( $@, qr/is required/, "... $pkg undef param" );
- ::is ( $obj, undef, "" );
- }
- {
- local $@;
- my $obj = eval { $pkg->new ( path => '/' ); };
- ::like ( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" );
- ::is ( $obj, undef, "" );
- }
- {
- local $@;
- my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); };
- ::like ( $@, qr/does not exist/, "... $pkg non existing path" );
- ::is ( $obj, undef, "" );
- }
- {
- local $@;
- my $obj = eval { $pkg->new ( path => '/tmp' ); };
- ::is ( $@, '', "... $pkg no error" );
- ::isa_ok ( $obj, $pkg );
- ::isa_ok ( $obj, 'Moose::Object' );
- ::is ( $obj->path, '/tmp', "... $pkg got the right value" );
- }
-}
\ No newline at end of file
+done_testing;
projects / gitmo/Moose.git / blobdiff