File Coverage

blib/lib/Test/LongString.pm
Criterion Covered Total %
statement 146 156 93.5
branch 64 74 86.4
condition 10 17 58.8
subroutine 16 16 100.0
pod 6 6 100.0
total 242 269 89.9


line stmt bran cond sub pod time code
1             package Test::LongString;
2              
3 6     6   121599 use strict;
  6         10  
  6         229  
4 6     6   26 use vars qw($VERSION @ISA @EXPORT $Max $Context $EOL $LCSS);
  6         6  
  6         585  
5              
6             $VERSION = '0.17';
7              
8 6     6   32 use Test::Builder;
  6         15  
  6         218  
9             my $Tester = new Test::Builder();
10              
11 6     6   36 use Exporter;
  6         9  
  6         3877  
12             @ISA = ('Exporter');
13             @EXPORT = qw( is_string is_string_nows like_string unlike_string
14             contains_string lacks_string );
15              
16             # Maximum string length displayed in diagnostics
17             $Max = 50;
18              
19             # Amount of context provided when starting displaying a string in the middle
20             $Context = 10;
21              
22             # Boolean: should we show LCSS context ?
23             $LCSS = 1;
24              
25             # Regular expression that decides what a end of line is
26             $EOL = "\n";
27              
28             sub import {
29 6     6   40 (undef, my %args) = @_;
30 6 100       22 $Max = $args{max} if defined $args{max};
31 6 100       23 $LCSS = $args{lcss} if defined $args{lcss};
32 6 50       50 $EOL = $args{eol} if defined $args{eol};
33 6         12 @_ = $_[0];
34 6         5822 goto &Exporter::import;
35             }
36              
37             # _display($string, [$offset = 0])
38             # Formats a string for display. Begins at $offset minus $Context.
39             # This function ought to be configurable, à la od(1).
40              
41             sub _display {
42 40     40   41 my $s = shift;
43 40 100       77 if (!defined $s) { return 'undef'; }
  3         6  
44 37 100       63 if (length($s) > $Max) {
45 7   100     25 my $offset = shift || 0;
46 7 50       14 if (defined $Context) {
47 7         9 $offset -= $Context;
48 7 100       20 $offset < 0 and $offset = 0;
49             }
50             else {
51 0         0 $offset = 0;
52             }
53 7         55 $s = sprintf(qq("%.${Max}s"...), substr($s, $offset));
54 7 100       20 $s = "...$s" if $offset;
55             }
56             else {
57 30         49 $s = qq("$s");
58             }
59 37         59 $s =~ s/([\0-\037\200-\377])/sprintf('\x{%02x}',ord $1)/eg;
  8         29  
60 37         71 return $s;
61             }
62              
63             sub _common_prefix_length {
64 11     11   19 my ($str1, $str2) = @_;
65 11         25 my $diff = "$str1" ^ "$str2";
66 11         35 my ($pre) = $diff =~ /^(\000*)/;
67 11         24 return length $pre;
68             }
69              
70             sub contains_string($$;$) {
71 5     5 1 2609 my ($str,$sub,$name) = @_;
72              
73 5         7 my $ok;
74 5 100       14 if (!defined $str) {
    100          
75 1         3 $Tester->ok($ok = 0, $name);
76 1         391 $Tester->diag("String to look in is undef");
77             } elsif (!defined $sub) {
78 1         4 $Tester->ok($ok = 0, $name);
79 1         481 $Tester->diag("String to look for is undef");
80             } else {
81 3         32 my $index = index($str, $sub);
82 3 100       5 $ok = ($index >= 0) ? 1 : 0;
83 3         8 $Tester->ok($ok, $name);
84 3 100       1235 if (!$ok) {
85 2         6 my ($g, $e) = (_display($str), _display($sub));
86              
87 2         9 $Tester->diag(<
88             searched: $g
89             can't find: $e
90             DIAG
91              
92 2 100       123 if ($LCSS) {
93             # if _lcss() returned the actual substring,
94             # all we'd have to do is:
95             # my $l = _display( _lcss($str, $sub) );
96              
97 1         4 my ($off, $len) = _lcss($str, $sub);
98 1         3 my $l = _display( substr($str, $off, $len) );
99              
100 1         5 $Tester->diag(<
101             LCSS: $l
102             DIAG
103             # if there's room left, show some surrounding context
104 1 50       67 if ($len < $Max) {
105 1         3 my $available = int( ($Max - $len) / 2 );
106 1 50       7 my $begin = ($off - ($available*2) > 0) ? $off - ($available*2)
    50          
107             : ($off - $available > 0) ? $off - $available : 0;
108 1         2 my $c = _display( substr($str, $begin, $Max) );
109              
110 1         4 $Tester->diag("LCSS context: $c");
111             }
112             }
113             }
114             }
115 5         165 return $ok;
116             }
117              
118             sub _lcss($$) {
119 11     11   5079 my ($S, $T) = (@_);
120 11         13 my @L;
121 11         19 my ($offset, $length) = (0,0);
122              
123             # prevent us from having to zero a $ix$j matrix
124 6     6   38 no warnings 'uninitialized';
  6         8  
  6         6041  
125              
126             # now the actual LCSS algorithm
127 11         30 foreach my $i (0 .. length($S) ) {
128 232         231 foreach my $j (0 .. length($T)) {
129 9833 100       14887 if (substr($S, $i, 1) eq substr($T, $j, 1)) {
130 696 100 100     1673 if ($i == 0 or $j == 0) {
131 22         43 $L[$i][$j] = 1;
132             }
133             else {
134 674         1071 $L[$i][$j] = $L[$i-1][$j-1] + 1;
135             }
136 696 100       1163 if ($L[$i][$j] > $length) {
137 79         77 $length = $L[$i][$j];
138 79         99 $offset = $i - $length + 1;
139             }
140             }
141             }
142             }
143              
144             # if you want to display just the lcss:
145             # return substr($S, $offset, $length);
146              
147             # but to display the surroundings, we need to:
148 11         109 return ($offset, $length);
149             }
150              
151              
152             sub lacks_string($$;$) {
153 5     5 1 3138 my ($str,$sub,$name) = @_;
154              
155 5         9 my $ok;
156 5 100       16 if (!defined $str) {
    100          
157 1         4 $Tester->ok($ok = 0, $name);
158 1         396 $Tester->diag("String to look in is undef");
159             } elsif (!defined $sub) {
160 1         4 $Tester->ok($ok = 0, $name);
161 1         411 $Tester->diag("String to look for is undef");
162             } else {
163 3         5 my $index = index($str, $sub);
164 3 100       8 $ok = ($index < 0) ? 1 : 0;
165 3         8 $Tester->ok($ok, $name);
166 3 100       1125 if (!$ok) {
167 2         5 my ($g, $e) = (_display($str), _display($sub));
168 2         18 my $line = () = substr($str,0,$index-1) =~ /$EOL/g;
169 2 100       9 my $column = $line ? $index - $+[0] + 1: $index + 1;
170 2         4 $line++;
171 2         13 $Tester->diag(<
172             searched: $g
173             and found: $e
174             at position: $index (line $line column $column)
175             DIAG
176             }
177             }
178 5         251 return $ok;
179             }
180              
181             sub is_string ($$;$) {
182 13     13 1 5832 my ($got, $expected, $name) = @_;
183 13 100 66     57 if (!defined $got || !defined $expected) {
184 2   66     466 my $ok = !defined $got && !defined $expected;
185 2         7 $Tester->ok($ok, $name);
186 2 50       823 if (!$ok) {
187 2         4 my ($g, $e) = (_display($got), _display($expected));
188 2         9 $Tester->diag(<
189             got: $g
190             expected: $e
191             DIAG
192             }
193 2         108 return $ok;
194             }
195 11 100       20 if ($got eq $expected) {
196 1         6 $Tester->ok(1, $name);
197 1         266 return 1;
198             }
199             else {
200 10         25 $Tester->ok(0, $name);
201 10         4206 my $common_prefix = _common_prefix_length($got,$expected);
202 10         20 my ($g, $e) = (
203             _display($got, $common_prefix),
204             _display($expected, $common_prefix),
205             );
206 10         68 my $line = () = substr($expected,0,$common_prefix) =~ /$EOL/g;
207 10 100       24 my $column = $line ? $common_prefix - $+[0] + 1 : $common_prefix + 1;
208 10         11 $line++;
209 10         17 $Tester->diag(<
210 10         24 got: $g
211 10         18 length: ${\(length $got)}
212             expected: $e
213 10         48 length: ${\(length $expected)}
214             strings begin to differ at char ${\($common_prefix + 1)} (line $line column $column)
215             DIAG
216 10         727 return 0;
217             }
218             }
219              
220             sub is_string_nows ($$;$) {
221 2     2 1 919 my ($got, $expected, $name) = @_;
222 2 50 33     9 if (!defined $got || !defined $expected) {
223 0   0     0 my $ok = !defined $got && !defined $expected;
224 0         0 $Tester->ok($ok, $name);
225 0 0       0 if (!$ok) {
226 0         0 my ($g, $e) = (_display($got), _display($expected));
227 0         0 $Tester->diag(<
228             got: $g
229             expected: $e
230             DIAG
231             }
232 0         0 return $ok;
233             }
234 2         32 s/\s+//g for (my $got_nows = $got), (my $expected_nows = $expected);
235 2 100       7 if ($got_nows eq $expected_nows) {
236 1         4 $Tester->ok(1, $name);
237 1         266 return 1;
238             }
239             else {
240 1         4 $Tester->ok(0, $name);
241 1         340 my $common_prefix = _common_prefix_length($got_nows,$expected_nows);
242 1         3 my ($g, $e) = (
243             _display($got_nows, $common_prefix),
244             _display($expected_nows, $common_prefix),
245             );
246 1         3 $Tester->diag(<
247             after whitespace removal:
248 1         4 got: $g
249 1         2 length: ${\(length $got_nows)}
250             expected: $e
251 1         4 length: ${\(length $expected_nows)}
252             strings begin to differ at char ${\($common_prefix + 1)}
253             DIAG
254 1         94 return 0;
255             }
256             }
257              
258             sub like_string ($$;$) {
259 4     4 1 1615 _like($_[0],$_[1],'=~',$_[2]);
260             }
261              
262             sub unlike_string ($$;$) {
263 1     1 1 474 _like($_[0],$_[1],'!~',$_[2]);
264             }
265              
266             # mostly from Test::Builder::_regex_ok
267             sub _like {
268 5     5   9 local $Test::Builder::Level = $Test::Builder::Level + 1;
269 5         7 my ($got, $regex, $cmp, $name) = @_;
270 5         6 my $ok = 0;
271 5         12 my $usable_regex = $Tester->maybe_regex($regex);
272 5 50       56 unless (defined $usable_regex) {
273 0         0 $ok = $Tester->ok( 0, $name );
274 0         0 $Tester->diag(" '$regex' doesn't look much like a regex to me.");
275 0         0 return $ok;
276             }
277             {
278 5         4 local $^W = 0;
  5         15  
279 5 100       24 my $test = $got =~ /$usable_regex/ ? 1 : 0;
280 5 100       12 $test = !$test if $cmp eq '!~';
281 5         13 $ok = $Tester->ok( $test, $name );
282             }
283 5 100       1647 unless( $ok ) {
284 4         8 my $g = _display($got);
285 4 100       9 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
286 4 100       6 my $l = defined $got ? length $got : '-';
287 4         21 $Tester->diag(sprintf(<
288             got: %s
289             length: $l
290             %13s '%s'
291             DIAGNOSTIC
292             }
293 5         246 return $ok;
294             }
295              
296             1;
297              
298             __END__