# HG changeset patch
# User Sergey
# Date 1249998352 -14400
# Node ID 2e546a5175ddd30911d541497b7ab10c96d077dc
# Parent 78cd3855153421e93ffec2f4e16e9a0722f3818f
in developing
diff -r 78cd38551534 -r 2e546a5175dd Lib/IMPL/Object/List.pm
--- a/Lib/IMPL/Object/List.pm Mon Aug 10 17:39:08 2009 +0400
+++ b/Lib/IMPL/Object/List.pm Tue Aug 11 17:45:52 2009 +0400
@@ -3,11 +3,21 @@
use warnings;
use base qw(IMPL::Object::ArrayObject);
+use IMPL::Exception;
sub as_list {
return $_[0];
}
+sub CTOR {
+ my ($this,$data) = @_;
+
+ if ($data) {
+ die new IMPL::InvalidArgumentException("The parameter should be a reference to an array") unless UNIVERSAL::isa($data,"ARRAY");
+ @$this = @$data;
+ }
+}
+
sub Append {
push @{$_[0]}, @_{1 .. @$_-1};
}
diff -r 78cd38551534 -r 2e546a5175dd Lib/IMPL/Test.pm
--- a/Lib/IMPL/Test.pm Mon Aug 10 17:39:08 2009 +0400
+++ b/Lib/IMPL/Test.pm Tue Aug 11 17:45:52 2009 +0400
@@ -4,7 +4,7 @@
require Exporter;
our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(&test &shared);
+our @EXPORT_OK = qw(&test &shared &failed &cmparray);
require IMPL::Test::Unit;
use IMPL::Class::Member;
@@ -29,4 +29,20 @@
$class->set_meta(new IMPL::Test::Unit::SharedData($propInfo->Name));
}
+
+sub failed($;@) {
+ die new IMPL::Test::FailException(@_);
+}
+
+sub cmparray {
+ my ($a,$b) = @_;
+
+ return 0 unless @$a == @$b;
+
+ for (my $i=0; $i < @$a; $i++ ) {
+ return 0 unless $a->[$i] eq $b->[$i];
+ }
+
+ return 1;
+}
1;
diff -r 78cd38551534 -r 2e546a5175dd Lib/IMPL/Test/Plan.pm
--- a/Lib/IMPL/Test/Plan.pm Mon Aug 10 17:39:08 2009 +0400
+++ b/Lib/IMPL/Test/Plan.pm Tue Aug 11 17:45:52 2009 +0400
@@ -63,11 +63,14 @@
foreach my $Unit ($this->Units){
my %info;
+ # preload module
+ eval "require $Unit" unless (ref $Unit);
+
$info{Unit} = $Unit;
try {
$info{Tests} = [map $Unit->new($_), $Unit->List];
} otherwise {
- $info{Tests} = [$info{Unit} = new IMPL::Test::BadUnit($Unit->UnitName,"Failed to extract tests",$@)];
+ $info{Tests} = [$info{Unit} = new IMPL::Test::BadUnit($Unit->can('UnitName') ? $Unit->UnitName : $Unit,"Failed to extract tests",$@)];
};
$count += @{$info{Tests}};
push @cache, \%info if @{$info{Tests}};
diff -r 78cd38551534 -r 2e546a5175dd _test/Test/Object/Common.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/Object/Common.pm Tue Aug 11 17:45:52 2009 +0400
@@ -0,0 +1,106 @@
+package Test::Object::Common;
+use strict;
+use warnings;
+
+use base qw( IMPL::Test::Unit );
+use IMPL::Test qw(test failed cmparray);
+
+__PACKAGE__->PassThroughArgs;
+
+{
+ package Foo;
+ use base qw(IMPL::Object);
+
+ sub CTOR {
+ my ($this,$refarg) = @_;
+ $$refarg = 1;
+ }
+
+ package Bar;
+ use base qw(Foo);
+
+ __PACKAGE__->PassThroughArgs;
+
+ sub CTOR {
+ my ($this,$ref,$array) = @_;
+
+ push @$array,__PACKAGE__;
+ }
+
+ package Baz;
+ use base qw(Bar);
+
+ our %CTOR = (
+ Bar => sub {
+ my $t;
+ (\$t,$_[0]);
+ }
+ );
+
+ sub CTOR {
+ my ($this,$array) = @_;
+ push @$array,__PACKAGE__;
+ }
+
+ package Zoo;
+ use base qw(Bar);
+
+ __PACKAGE__->PassThroughArgs;
+
+ sub CTOR {
+ my ($this,$ref,$array) = @_;
+
+ push @$array,__PACKAGE__;
+ };
+
+ package Complex;
+ use base qw(Baz Zoo);
+
+ our %CTOR = (
+ Baz => sub { @_ },
+ Zoo => sub {
+ my $t;
+ (\$t,$_[0]);
+ }
+ );
+
+}
+
+test Creation => sub {
+ my $flag = 0;
+
+ my $obj = new Foo(\$flag);
+
+ die new IMPL::Test::FailException("Object is undef") unless $obj;
+ die new IMPL::Test::FailException("Contructor doesn't run") unless $obj;
+};
+
+test SimpleInheritance => sub {
+ my $sequence = [];
+ my $flag = 0;
+ my $obj = new Bar(\$flag,$sequence);
+
+ failed "Object is undef" unless $obj;
+ failed "Base class constructor isn't called" unless $flag;
+ failed "Class constructor isn't called" unless @$sequence;
+};
+
+test SimpleInheritance2 => sub {
+ my $sequence = [];
+ my $expected = [qw(Bar Baz)];
+ my $obj = new Baz($sequence);
+
+ failed "Object is undef" unless $obj;
+ failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
+};
+
+test MultipleInheritance => sub {
+ my $sequence = [];
+ my $expected = [qw(Bar Baz Bar Zoo)];
+ my $obj = new Complex($sequence);
+
+ failed "Object is undef" unless $obj;
+ failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
+};
+
+1;
diff -r 78cd38551534 -r 2e546a5175dd _test/Test/Object/List.pm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/Object/List.pm Tue Aug 11 17:45:52 2009 +0400
@@ -0,0 +1,32 @@
+package Test::Object::List;
+use strict;
+use warnings;
+
+use base qw(IMPL::Test::Unit);
+use IMPL::Test qw(test cmparray failed);
+use IMPL::Object::List;
+__PACKAGE__->PassThroughArgs;
+
+test Creation => sub {
+ my $list = new IMPL::Object::List();
+
+ failed "Failed to create an empty list" unless $list;
+};
+
+test FilledByRef => sub {
+ my $data = [map rand 100, 1 .. 300];
+ my $list = new IMPL::Object::List($data);
+
+ failed("List filled incorrectlty") unless cmparray($data,$list);
+};
+
+test FilledByWrongRef => sub {
+ eval {
+ my $list = new IMPL::Object::List({});
+ };
+ unless ($@) {
+ failed("List can be initialized only by an ARRAY reference");
+ }
+};
+
+1;
diff -r 78cd38551534 -r 2e546a5175dd _test/object.t
--- a/_test/object.t Mon Aug 10 17:39:08 2009 +0400
+++ b/_test/object.t Tue Aug 11 17:45:52 2009 +0400
@@ -1,30 +1,16 @@
#!/usr/bin/perl -w
use strict;
use lib '../Lib';
-
-package Foo;
-use base qw(IMPL::Object);
+use lib '.';
-sub CTOR {
- my ($this,%args) = @_;
- print "CTOR Foo says $args{Name}\n";
-}
-
-sub Hello {
- print "\tHello\n";
-}
+use IMPL::Test::Plan;
+use IMPL::Test::TAPListener;
-package Bar;
-use base qw(Foo);
-
-__PACKAGE__->PassThroughArgs;
+my $plan = new IMPL::Test::Plan qw(
+ Test::Object::Common
+ Test::Object::List
+);
-sub CTOR {
- print "CTOR Bar\n";
-}
-
-package main;
-
-my $obj = new Bar ( Name => 'Tom') ;
-
-Hello $obj;
\ No newline at end of file
+$plan->AddListener(new IMPL::Test::TAPListener);
+$plan->Prepare();
+$plan->Run();
diff -r 78cd38551534 -r 2e546a5175dd impl.kpf
--- a/impl.kpf Mon Aug 10 17:39:08 2009 +0400
+++ b/impl.kpf Tue Aug 11 17:45:52 2009 +0400
@@ -110,6 +110,13 @@
1
+
+
+
+
+ Perl - TAP (*.t)
+
+