File Coverage

tlib/Test/Tech.pm
Criterion Covered Total %
statement 52 104 50.0
branch 11 44 25.0
condition 1 3 33.3
subroutine 13 15 86.6
pod 0 7 0.0
total 77 173 44.5


line stmt bran cond sub pod time code
1             #!perl
2             #
3             # Documentation, copyright and license is at the end of this file.
4             #
5             package Test::Tech;
6            
7 1     1   58166 use 5.001;
  1         7  
  1         426  
8 1     1   10 use strict;
  1         7  
  1         90  
9 1     1   12 use warnings;
  1         10  
  1         81  
10 1     1   16 use warnings::register;
  1         3  
  1         287  
11            
12 1     1   1880 use Test (); # do not import the "Test" subroutines
  1         5571  
  1         30  
13 1     1   1128 use Data::Dumper;
  1         7451  
  1         75  
14            
15 1     1   7 use vars qw($VERSION $DATE $FILE);
  1         2  
  1         80  
16             $VERSION = '1.11';
17             $DATE = '2003/07/27';
18             $FILE = __FILE__;
19            
20 1     1   4 use vars qw(@ISA @EXPORT_OK);
  1         1  
  1         1547  
21             require Exporter;
22             @ISA=('Exporter');
23             @EXPORT_OK = qw(&tech_config &plan &ok &skip &skip_tests &stringify &demo);
24            
25             #######
26             #
27             # Keep all data hidden in a local hash
28             #
29             # Too bad "Test" and "Data::Dumper" are not objectified
30             #
31             # Senseless to objectify "Test::Tech" if unless "Test" and "Data::Dumper"
32             # are objectified
33             #
34            
35             my %tech = ();
36             my $tech_p = \%tech; # quasi objectify by using $tech_p instead of %tech
37            
38             ########
39             # Tend to Data::Dumper variables
40             #
41             $tech_p->{Dumper} = {};
42             $tech_p->{Dumper}->{Terse} = \$Data::Dumper::Terse;
43             $tech_p->{Dumper}->{Indent} = \$Data::Indent;
44             $tech_p->{Dumper}->{Purity} = \$Data::Purity;
45             $tech_p->{Dumper}->{Pad} = \$Data::Pad;
46             $tech_p->{Dumper}->{Varname} = \$Data::Varname;
47             $tech_p->{Dumper}->{Useqq} = \$Data::Useqq;
48             $tech_p->{Dumper}->{Freezer} = \$Data::Freezer;
49             $tech_p->{Dumper}->{Toaster} = \$Data::Toaster;
50             $tech_p->{Dumper}->{Deepcopy} = \$Data::Deepcopy;
51             $tech_p->{Dumper}->{Quotekeys} = \$Data::Quotekeys;
52             $tech_p->{Dumper}->{Maxdepth} = \$Data::Maxdepth;
53            
54             ######
55             # Tend to Test variables
56             #
57             $tech_p->{Test}->{ntest} = \$Test::ntest;
58             $tech_p->{Test}->{TESTOUT} = \$Test::TESTOUT;
59             $tech_p->{Test}->{TestLevel} = \$Test::TestLevel;
60             $tech_p->{Test}->{ONFAIL} = \$Test::ONFAIL;
61             $tech_p->{Test}->{todo} = \%Test::todo;
62             $tech_p->{Test}->{history} = \%Test::history;
63             $tech_p->{Test}->{planned} = \$Test::planned;
64             $tech_p->{Test}->{FAILDETAIL} = \@Test::FAILDETAIL;
65             $tech_p->{Test}->{Program_Lines} = \%Test::Program_Lines if defined %Test::Program_lines;
66             $tech_p->{Test}->{TESTERR} = \$Test::TESTERR if defined $Test::TESTERR;
67             $tech_p->{Skip_Tests} = 0;
68            
69             #######
70             # Probe for internal storage
71             #
72             # The &Data::Dumper::Dumper subroutine stringifies the iternal Perl variable.
73             # Different Perls keep the have different internal formats for numbers. Some
74             # keep them as binary numbers, while others as strings. The ones that keep
75             # them as strings may be well spec. In any case they have been let loose in
76             # the wild so the test scripts that use Data::Dumper must deal with them.
77             #
78             # This is perl, v5.6.1 built for MSWin32-x86-multi-thread
79             # (with 1 registered patch, see perl -V for more detail)
80             #
81             # Copyright 1987-2001, Larry Wall
82             #
83             # Binary build 631 provided by ActiveState Tool Corp. http://www.ActiveState.com
84             # Built 17:16:22 Jan 2 2002
85             #
86             #
87             # Perl may be copied only under the terms of either the Artistic License or the
88             # GNU General Public License, which may be found in the Perl 5 source kit.
89             #
90             # Complete documentation for Perl, including FAQ lists, should be found on
91             # this system using `man perl' or `perldoc perl'. If you have access to the
92             # Internet, point your browser at http://www.perl.com/, the Perl Home Page.
93             #
94             # ~~~~~~~
95             #
96             # Wall, Christiansen and Orwant on Perl internal storage
97             #
98             # Page 351 of Programming Perl, Third Addition, Overloadable Operators
99             # quote:
100             #
101             # Conversion operators: ``'', 0+, bool
102             #
103             # These three keys let you provide behaviors for Perl's automatic conversions
104             # to strings, numbers, and Boolean values, respectively.
105             #
106             # ~~~~~~~
107             #
108             # Internal Storage of Perls that are in the wild
109             #
110             # string - Perl v5.6.1 MSWin32-x86-multi-thread, ActiveState build 631, binary
111             # number - Perl version 5.008 for solaris
112             #
113             # Perls in the wild with internal storage of string may be mutants that need to
114             # be hunted down killed.
115             #
116             my $probe = 3;
117             my $actual = Dumper([0+$probe]);
118             if( $actual eq Dumper([3]) ) {
119             $tech_p->{Internal_Number} = 'number';
120             }
121             elsif ( $actual eq Dumper(['3']) ) {
122             $tech_p->{Internal_Number} = 'string';
123             }
124             else {
125             $tech_p->{Internal_Number} = 'undetermine';
126             }
127            
128            
129             #####
130             # Stringify the variable and compare the string.
131             #
132             # This is the code that adds the big new capability of testing complex data
133             # structures to the "Test" module
134             #
135             sub stringify
136             {
137 4     4 0 11 my ($var_p) = @_;
138            
139 4 100       41 return '' unless $var_p;
140            
141 1         4 my ($result, $ref);
142 1 50       11 if($ref = ref($var_p)) {
143 0 0       0 if( $ref eq 'ARRAY' ) {
    0          
144 0 0       0 if( 1 < @$var_p ) {
145 0         0 $result = Dumper(@$var_p);
146             }
147             else {
148 0         0 $result = shift @$var_p;
149             }
150             }
151             elsif( $ref eq 'HASH' ) {
152 0         0 $result = Dumper(%$var_p);
153             }
154             else {
155 0         0 $result = Dumper($var_p);
156             }
157             }
158             else {
159 1         4 $result = $var_p;
160             }
161 1         10 $result;
162             }
163            
164            
165            
166             ######
167             # Cover function for &Test::plan that sets the proper 'Test::TestLevel'
168             # and outputs some info on the current site
169             #
170             sub plan
171             {
172 1     1 0 74 &Test::plan( @_ );
173            
174             ###############
175             #
176             # Establish default for Test and Data::Dumper
177             #
178             # Test 1.24 resets global variables in plan which
179             # never happens in 1.15
180             #
181 1         2316 $Data::Dumper::Terse = 1;
182 1         3 $Test::TestLevel = 1;
183            
184 1         28 my $loctime = localtime();
185 1         5 my $gmtime = gmtime();
186            
187 1         3 my $perl = "$]";
188 1 50 33     9 if(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) {
    50          
189 0         0 $perl .= " Win32 Build " . &Win32::BuildNumber();
190             }
191             elsif(defined $MacPerl::Version) {
192 0         0 $perl .= " MacPerl version " . $MacPerl::Version;
193             }
194            
195 1 50       6 print $Test::TESTOUT <<"EOF" unless 1.20 < $Test::VERSION ;
196             # OS : $^O
197             # Perl : $perl
198             # Local Time : $loctime
199             # GMT Time : $gmtime
200             # Test : $Test::VERSION
201             EOF
202            
203 1         248 print $Test::TESTOUT <<"EOF";
204             # Number Storage: $tech_p->{Internal_Number}
205             # Test::Tech : $VERSION
206             # Data::Dumper : $Data::Dumper::VERSION
207             # =cut
208             EOF
209            
210 1         100 1
211             }
212            
213            
214             ######
215             #
216             # Cover function for &Test::ok that adds capability to test
217             # complex data structures.
218             #
219             sub ok
220             {
221 1     1 0 1410 my ($actual_result, $expected_result, $diagnostic, $name) = @_;
222            
223 1 50       278 print $Test::TESTOUT "# $name\n" if $name;
224 1 50       10 if($tech_p->{Skip_Tests}) { # skip rest of tests switch
225 0         0 print $Test::TESTOUT "# Test invalid because of previous failure.\n";
226 0         0 &Test::skip( 1, 0, '');
227 0         0 return 1;
228             }
229            
230 1         6 &Test::ok(stringify($actual_result), stringify($expected_result), $diagnostic);
231             }
232            
233            
234             ######
235             #
236             #
237             sub skip
238             {
239 1     1 0 283 my ($mod, $actual_result, $expected_result, $diagnostic, $name) = @_;
240            
241 1 50       1100 print $Test::TESTOUT "# $name\n" if $name;
242            
243 1 50       47 if($tech_p->{Skip_Tests}) { # skip rest of tests switch
244 0         0 print $Test::TESTOUT "# Test invalid because of previous failure.\n";
245 0         0 &Test::skip( 1, 0, '');
246 0         0 return 1;
247             }
248            
249 1         12 &Test::skip($mod, stringify($actual_result), stringify($expected_result), $diagnostic);
250            
251             }
252            
253            
254             ######
255             #
256             #
257             sub skip_tests
258             {
259 1     1 0 1563 my ($value) = @_;
260 1         5 my $result = $tech_p->{Skip_Tests};
261 1 50       7 $tech_p->{Skip_Tests} = $value if defined $value;
262 1         5 $result;
263             }
264            
265            
266            
267             #######
268             # This accesses the values in the %tech hash
269             #
270             # Use a dot notation for following down layers
271             # of hashes of hashes
272             #
273             sub tech_config
274             {
275 0     0 0   my ($key, @values) = @_;
276 0           my @keys = split /\./, $key;
277            
278             #########
279             # Follow the hash with the current
280             # dot index until there are no more
281             # hashes. Hopefully the dot hash
282             # notation matches the structure.
283             #
284 0           my $key_p = $tech_p;
285 0           while (@keys) {
286            
287 0           $key = shift @keys;
288            
289             ######
290             # Do not allow creation of new configs
291             #
292 0 0         if( defined( $key_p->{$key}) ) {
293            
294             ########
295             # Follow the hash
296             #
297 0 0         if( ref($key_p->{$key}) eq 'HASH' ) {
298 0           $key_p = $key_p->{$key};
299             }
300             else {
301 0 0         if(@keys) {
302 0           warn( "More key levels than hashes.\n");
303 0           return undef;
304             }
305 0           last;
306             }
307             }
308             }
309            
310            
311             #########
312             # References to arrays and scalars in the config may
313             # be transparent.
314             #
315 0           my $current_value = $key_p->{$key};
316 0 0         return $current_value if ref($current_value) eq 'HASH';
317 0 0         if (defined $values[0]) {
318 0 0         if(ref($key_p->{$key}) eq 'ARRAY') {
    0          
319 0 0         if( ref($values[0]) eq 'ARRAY' ) {
320 0           $key_p->{$key} = $values[0];
321             }
322             else {
323 0           my @current_value = @{$key_p->{$key}};
  0            
324 0           $key_p->{$key} = \@values;
325 0           return @current_value;
326             }
327             }
328             elsif( ref($key_p->{$key}) ) {
329 0           $current_value = ${$key_p->{$key}};
  0            
330 0           ${$key_p->{$key}} = $values[0];
  0            
331             }
332             else {
333 0           $key_p->{$key} = $values[0];
334             }
335             }
336            
337 0           $current_value;
338            
339             }
340            
341            
342            
343             ######
344             # Demo
345             #
346             sub demo
347             {
348 0     0 0   my ($quoted_expression, @expression_results) = @_;
349            
350             #######
351             # A demo trys to simulate someone typing expresssions
352             # at a console.
353             #
354            
355             #########
356             # Print quoted expression so that see the non-executed
357             # expression. The extra space is so when pasted into
358             # a POD, the POD will process the line as code.
359             #
360 0           $quoted_expression =~ s/(\n+)/$1 => /g;
361 0           print $Test::TESTOUT ' => ' . $quoted_expression . "\n";
362            
363             ########
364             # @data is the result of the script executing the
365             # quoted expression.
366             #
367             # The demo output most likely will end up in a pod.
368             # The the process of running the generated script
369             # will execute the setup. Thus the input is the
370             # actual results. Putting a space in front of it
371             # tells the POD that it is code.
372             #
373 0 0         return unless @expression_results;
374            
375 0           $Data::Dumper::Terse = 1;
376 0           my $data = Dumper(@expression_results);
377 0           $data =~ s/(\n+)/$1 /g;
378 0           $data =~ s/\\\\/\\/g;
379 0           $data =~ s/\\'/'/g;
380            
381 0           print $Test::TESTOUT ' ' . $data . "\n" ;
382            
383             }
384            
385             1
386            
387            
388             __END__