File: Procedural.pm

package info (click to toggle)
libtest-unit-perl 0.25-3
  • links: PTS, VCS
  • area: main
  • in suites: buster, stretch
  • size: 1,376 kB
  • ctags: 549
  • sloc: perl: 4,290; makefile: 5
file content (211 lines) | stat: -rw-r--r-- 5,885 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
package Test::Unit::Procedural;

use strict;

use Test::Unit::TestSuite;
use Test::Unit::TestRunner;

use base 'Exporter';

use vars qw(@EXPORT);
@EXPORT = qw(assert create_suite run_suite add_suite);

# Helper classes
use Devel::Symdump;
use Class::Inner;

# Exception handling
use Error qw/:try/;
use Test::Unit::Exception;
use Test::Unit::Failure;

# private

my $test_suite = Test::Unit::TestSuite->empty_new("Test::Unit");
my %suites = ();
%suites = ('Test::Unit' => $test_suite);
    
sub add_to_suites {
    my $suite_holder = shift;
    if (not exists $suites{$suite_holder}) {
	my $test_suite = Test::Unit::TestSuite->empty_new($suite_holder);
	$suites{$suite_holder} = $test_suite;
    }
}

# public

sub assert ($;$) {
    my($condition, $message) = @_;
    my($asserter,$file,$line) = caller(1);
    
    add_to_suites($asserter);
    try {
        $suites{$asserter}->assert($condition, $message);
    }
    catch Test::Unit::Exception with {
        my $e = shift;
        $e->throw_new(
                      -package => $asserter,
                      -file    => $file,
                      -line    => $line);
    }
}

sub create_suite {
    my ($test_package_name) = @_;
    $test_package_name = caller() unless defined($test_package_name);
    add_to_suites($test_package_name);
    
    no strict 'refs';

    my $set_up_func    = sub {};
    my $tear_down_func = sub {};

    my $st = Devel::Symdump->new($test_package_name);
    my @set_up_candidates = grep /::set_up$/, $st->functions;
    $set_up_func = \&{$set_up_candidates[0]} if @set_up_candidates;

    my @tear_down_candidates = grep /::tear_down$/, $st->functions;
    $tear_down_func = \&{$tear_down_candidates[0]} if @tear_down_candidates;

    for my $test_method (grep /::test[^:]*$/, $st->functions) {
        my($method_name) = $test_method =~ /::(test[^:]*)/;
        my $subref = \&{$test_method};
        my $test_case = Class::Inner->new
            (parent  => 'Test::Unit::TestCase',
             methods => {set_up       => $set_up_func,
                         tear_down    => $tear_down_func,
                         $method_name => $subref,
                        },
             args    => [$method_name],);
	    $suites{$test_package_name}->add_test($test_case);
	}
}

sub run_suite {
    my ($test_package_name, $filehandle) = @_;
    $test_package_name = caller() unless defined($test_package_name);
    my $test_runner = Test::Unit::TestRunner->new($filehandle);
    $test_runner->do_run($suites{$test_package_name});
}

sub add_suite {
    my ($to_be_added, $to_add_to) = @_;
    $to_add_to = caller() unless defined($to_add_to);
    die "Error: no suite '$to_be_added'" unless exists $suites{$to_be_added};
    die "Error: no suite '$to_add_to'" unless exists $suites{$to_add_to};
    $suites{$to_add_to}->add_test($suites{$to_be_added});
}

1;
__END__

=head1 NAME

Test::Unit::Procedural - Procedural style unit testing interface

=head1 SYNOPSIS

    use Test::Unit::Procedural;

    # your code to be tested goes here

    sub foo { return 23 };
    sub bar { return 42 };

    # define tests

    sub test_foo { assert(foo() == 23, "Your message here"); }	
    sub test_bar { assert(bar() == 42, "I will be printed if this fails"); }

    # set_up and tear_down are used to
    # prepare and release resources need for testing

    sub set_up    { print "hello world\n"; }
    sub tear_down { print "leaving world again\n"; }

    # run your test

    create_suite();
    run_suite();

=head1 DESCRIPTION

Test::Unit::Procedural is the procedural style interface to a
sophisticated unit testing framework for Perl that is derived from the
JUnit testing framework for Java by Kent Beck and Erich Gamma.  While
this framework is originally intended to support unit testing in an
object-oriented development paradigm (with support for inheritance of
tests etc.), Test::Unit::Procedural is intended to provide a simpler
interface to the framework that is more suitable for use in a
scripting style environment.  Therefore, Test::Unit::Procedural does
not provide much support for an object-oriented approach to unit
testing - if you want that, please have a look at
L<Test::Unit::TestCase>.

You test a given unit (a script, a module, whatever) by using
Test::Unit::Procedural, which exports the following routines into your
namespace:

=over 4

=item assert()

used to assert that a boolean condition is true

=item create_suite()

used to create a test suite consisting of all methods with a name
prefix of C<test>

=item run_suite()

runs the test suite (text output)

=item add_suite()

used to add test suites to each other

=back

For convenience, C<create_suite()> will automatically build a test
suite for a given package. This will build a test case for each
subroutine in the package given that has a name starting with C<test>
and pack them all together into one TestSuite object for easy testing.
If you don't give a package name to C<create_suite()>, the current
package is taken as default.

Test output is one status line (a "." for every successful test run,
or an "F" for any failed test run, to indicate progress), one result
line ("OK" or "!!!FAILURES!!!"), and possibly many lines reporting
detailed error messages for any failed tests.

Please remember, Test::Unit::Procedural is intended to be a simple and
convenient interface. If you need more functionality, take the
object-oriented approach outlined in L<Test::Unit::TestCase>.

=head1 AUTHOR

Copyright (c) 2000-2002, 2005 the PerlUnit Development Team
(see L<Test::Unit> or the F<AUTHORS> file included in this
distribution).

All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

=over 4

=item *

L<Test::Unit::TestCase>

=item *

the procedural style examples in the examples directory

=back

=cut