1use strict;
2use warnings;
3use FindBin;
4use lib "$FindBin::Bin/../../";
5use t::scan::Util;
6
7test(<<'TEST'); # HTML-Perlinfo-1.68/lib/HTML/Perlinfo/Base.pm
8eval qq{
9
10END {
11    delete \$INC{'HTML/Perlinfo.pm'};
12    \$html .= print_thesemodules('loaded',[values %INC]);
13    \$html .= print_variables();
14    \$html .= '</div></body></html>' if \$self->{'full_page'};
15    print \$html;
16 }
17
18}; die $@ if $@;
19TEST
20
21test(<<'TEST'); # KARASIK/Prima-1.46/Prima/Sliders.pm
22sub init
23{
24        my $self = shift;
25        my %profile = @_;
26        my $visible = $profile{visible};
27        $profile{visible} = 0;
28        for (qw( min max step circulate pageStep)) {$self-> {$_} = 1;};
29        $self-> {edit} = bless [], q\Prima::SpinEdit::DummyEdit\;
30        %profile = $self-> SUPER::init(%profile);
31        my ( $w, $h) = ( $self-> size);
32        $self-> {spin} = $self-> insert( $profile{spinClass} =>
33                ownerBackColor => 1,
34                name           => 'Spin',
35                bottom         => 1,
36                right          => $w - 1,
37                height         => $h - 1 * 2,
38                growMode       => gm::Right,
39                delegations    => $profile{spinDelegations},
40                (map { $_ => $profile{$_}} grep { exists $profile{$_} ? 1 : 0} keys %spinDynas),
41                %{$profile{spinProfile}},
42        );
43        $self-> {edit} = $self-> insert( $profile{editClass} =>
44                name         => 'InputLine',
45                origin      => [ 1, 1],
46                size        => [ $w - $self-> {spin}-> width - 1 * 2, $h - 1 * 2],
47                growMode    => gm::GrowHiX|gm::GrowHiY,
48                selectable  => 1,
49                tabStop     => 1,
50                borderWidth => 0,
51                current     => 1,
52                delegations => $profile{editDelegations},
53                (map { $_ => $profile{$_}} keys %editProps),
54                %{$profile{editProfile}},
55                text        => $profile{value},
56        );
57        for (qw( min max step value circulate pageStep)) {$self-> $_($profile{$_});};
58        $self-> visible( $visible);
59        return %profile;
60}
61
62sub on_paint
63{
64        my ( $self, $canvas) = @_;
65        my @s = $canvas-> size;
66        $canvas-> rect3d( 0, 0, $s[0]-1, $s[1]-1, 1, $self-> dark3DColor, $self-> light3DColor);
67}
68
69sub InputLine_MouseWheel
70{
71        my ( $self, $edit, $mod, $x, $y, $z) = @_;
72        $z = int($z/120);
73        $z *= $self-> {pageStep} if $mod & km::Ctrl;
74        my $value = $self-> value;
75        $self-> value( $value + $z * $self-> {step});
76        $self-> value( $z > 0 ? $self-> min : $self-> max)
77                if $self-> {circulate} && ( $self-> value == $value);
78        $edit-> clear_event;
79}
80
81sub Spin_Increment
82{
83        my ( $self, $spin, $increment) = @_;
84        my $value = $self-> value;
85        $self-> value( $value + $increment * $self-> {step});
86        $self-> value( $increment > 0 ? $self-> min : $self-> max)
87                if $self-> {circulate} && ( $self-> value == $value);
88}
89
90sub InputLine_KeyDown
91{
92        my ( $self, $edit, $code, $key, $mod) = @_;
93        $edit-> clear_event, return if
94                $key == kb::NoKey && !($mod & (km::Alt | km::Ctrl)) &&
95                chr($code) !~ /^[.\d+-]$/;
96        if ( $key == kb::Up || $key == kb::Down || $key == kb::PgDn || $key == kb::PgUp) {
97                my ($s,$pgs) = ( $self-> step, $self-> pageStep);
98                my $z = ( $key == kb::Up) ? $s : (( $key == kb::Down) ? -$s :
99                        (( $key == kb::PgUp) ? $pgs : -$pgs));
100                if (( $mod & km::Ctrl) && ( $key == kb::PgDn || $key == kb::PgUp)) {
101                        $self-> value( $key == kb::PgDn ? $self-> min : $self-> max);
102                } else {
103                        my $value = $self-> value;
104                        $self-> value( $value + $z);
105                        $self-> value( $z > 0 ? $self-> min : $self-> max)
106                                if $self-> {circulate} && ( $self-> value == $value);
107                }
108                $edit-> clear_event;
109                return;
110        }
111        if ($key == kb::Enter) {
112                my $value = $edit-> text;
113                $self-> value( $value);
114                $edit-> clear_event if $value ne $self-> value;
115                return;
116        }
117}
118
119sub InputLine_Change
120{
121        my ( $self, $edit) = @_;
122        $self-> notify(q(Change));
123}
124
125sub InputLine_Enter
126{
127        my ( $self, $edit) = @_;
128        $self-> notify(q(Enter));
129}
130
131sub InputLine_Leave
132{
133        my ( $self, $edit) = @_;
134        $self-> notify(q(Leave));
135}
136
137sub set_bounds
138{
139        my ( $self, $min, $max) = @_;
140        $max = $min if $max < $min;
141        ( $self-> { min}, $self-> { max}) = ( $min, $max);
142        my $oldValue = $self-> value;
143        $self-> value( $max) if $max < $self-> value;
144        $self-> value( $min) if $min > $self-> value;
145}
146
147sub set_step
148{
149        my ( $self, $step) = @_;
150        $step  = 0 if $step < 0;
151        $self-> {step} = $step;
152}
153
154sub circulate
155{
156        return $_[0]-> {circulate} unless $#_;
157        $_[0]-> {circulate} = $_[1];
158}
159
160sub pageStep
161{
162        return $_[0]-> {pageStep} unless $#_;
163        $_[0]-> {pageStep} = $_[1];
164}
165
166
167sub min          {($#_)?$_[0]-> set_bounds($_[1], $_[0]-> {'max'})      : return $_[0]-> {min};}
168sub max          {($#_)?$_[0]-> set_bounds($_[0]-> {'min'}, $_[1])      : return $_[0]-> {max};}
169sub step         {($#_)?$_[0]-> set_step         ($_[1]):return $_[0]-> {step}}
170sub value
171{
172        if ($#_) {
173                my ( $self, $value) = @_;
174                if ( $value =~ m/^\s*([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?\s*$/) {
175                        $value = $self-> {min} if $value < $self-> {min};
176                        $value = $self-> {max} if $value > $self-> {max};
177                } else {
178                        $value = $self-> {min};
179                }
180                return if $value eq $self-> {edit}-> text;
181                $self-> {edit}-> text( $value);
182        } else {
183                my $self = $_[0];
184                my $value = $self-> {edit}-> text;
185                if ( $value =~ m/^\s*([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?\s*$/) {
186                        $value = $self-> {min} if $value < $self-> {min};
187                        $value = $self-> {max} if $value > $self-> {max};
188                } else {
189                        $value = $self-> {min};
190                }
191                return $value;
192        }
193}
194
195
196# gauge reliefs
197package
198    gr;
199use constant Sink         =>  -1;
200use constant Border       =>  0;
201use constant Raise        =>  1;
202
203
204package Prima::Gauge;
205use vars qw(@ISA);
206@ISA = qw(Prima::Widget);
207
208{
209my %RNT = (
210        %{Prima::Widget-> notification_types()},
211        Stringify => nt::Action,
212);
213
214sub notification_types { return \%RNT; }
215}
216
217sub profile_default
218{
219        return {
220                %{$_[ 0]-> SUPER::profile_default},
221                indent         => 1,
222                relief         => gr::Sink,
223                ownerBackColor => 1,
224                hiliteBackColor=> cl::Blue,
225                hiliteColor    => cl::White,
226                min            => 0,
227                max            => 100,
228                value          => 0,
229                threshold      => 0,
230                vertical       => 0,
231        }
232}
233
234sub init
235{
236        my $self = shift;
237        my %profile = $self-> SUPER::init(@_);
238        for (qw( relief value indent min max threshold vertical))
239        {$self-> {$_} = 0}
240        $self-> {string} = '';
241        for (qw( vertical threshold min max relief indent value))
242        {$self-> $_($profile{$_}); }
243        return %profile;
244}
245
246sub setup
247{
248        $_[0]-> SUPER::setup;
249        $_[0]-> value($_[0]-> {value});
250}
251
252sub on_paint
253{
254        my ($self,$canvas) = @_;
255        my ($x, $y) = $canvas-> size;
256        my $i = $self-> indent;
257        my ($clComplete,$clBack,$clFore,$clHilite) = ($self-> hiliteBackColor, $self-> backColor, $self-> color, $self-> hiliteColor);
258        my $v = $self-> {vertical};
259        my $complete = $v ? $y : $x;
260        my $range = ($self-> {max} - $self-> {min}) || 1;
261        $complete = int(($complete - $i*2) * $self-> {value} / $range + 0.5);
262        my ( $l3, $d3) = ( $self-> light3DColor, $self-> dark3DColor);
263        $canvas-> color( $clComplete);
264        $canvas-> bar ( $v ? ($i, $i, $x-$i-1, $i+$complete) : ( $i, $i, $i + $complete, $y-$i-1));
265        $canvas-> color( $clBack);
266        $canvas-> bar ( $v ? ($i, $i+$complete+1, $x-$i-1, $y-$i-1) : ( $i+$complete+1, $i, $x-$i-1, $y-$i-1));
267        # draw the border
268        my $relief = $self-> relief;
269        $canvas-> color(( $relief == gr::Sink) ? $d3 : (( $relief == gr::Border) ? cl::Black : $l3));
270        for ( my $j = 0; $j < $i; $j++)
271        {
272                $canvas-> line( $j, $j, $j, $y - $j - 1);
273                $canvas-> line( $j, $y - $j - 1, $x - $j - 1, $y - $j - 1);
274        }
275        $canvas-> color(( $relief == gr::Sink) ? $l3 : (( $relief == gr::Border) ? cl::Black : $d3));
276        for ( my $j = 0; $j < $i; $j++)
277        {
278                $canvas-> line( $j + 1, $j, $x - $j - 1, $j);
279                $canvas-> line( $x - $j - 1, $j, $x - $j - 1, $y - $j - 1);
280        }
281
282        # draw the text, if neccessary
283        my $s = $self-> {string};
284        if ( $s ne '')
285        {
286                my ($fw, $fh) = ( $canvas-> get_text_width( $s), $canvas-> font-> height);
287                my $xBeg = int(( $x - $fw) / 2 + 0.5);
288                my $xEnd = $xBeg + $fw;
289                my $yBeg = int(( $y - $fh) / 2 + 0.5);
290                my $yEnd = $yBeg + $fh;
291                my ( $zBeg, $zEnd) = $v ? ( $yBeg, $yEnd) : ( $xBeg, $xEnd);
292                if ( $zBeg > $i + $complete) {
293                        $canvas-> color( $clFore);
294                        $canvas-> text_out_bidi( $s, $xBeg, $yBeg);
295                } elsif ( $zEnd < $i + $complete + 1) {
296                        $canvas-> color( $clHilite);
297                        $canvas-> text_out_bidi( $s, $xBeg, $yBeg);
298                } else {
299                        $canvas-> clipRect( $v ?
300                                ( 0, 0, $x, $i + $complete) :
301                                ( 0, 0, $i + $complete, $y)
302                        );
303                        $canvas-> color( $clHilite);
304                        $canvas-> text_out_bidi( $s, $xBeg, $yBeg);
305                        $canvas-> clipRect( $v ?
306                                ( 0, $i + $complete + 1, $x, $y) :
307                                ( $i + $complete + 1, 0, $x, $y)
308                        );
309                        $canvas-> color( $clFore);
310                        $canvas-> text_out_bidi( $s, $xBeg, $yBeg);
311                }
312        }
313}
314
315sub set_bounds
316{
317        my ( $self, $min, $max) = @_;
318        $max = $min if $max < $min;
319        ( $self-> { min}, $self-> { max}) = ( $min, $max);
320        my $oldValue = $self-> {value};
321        $self-> value( $max) if $self-> {value} > $max;
322        $self-> value( $min) if $self-> {value} < $min;
323}
324
325sub value
326{
327        return $_[0]-> {value} unless $#_;
328        my $v = $_[1] < $_[0]-> {min} ? $_[0]-> {min} : ($_[1] > $_[0]-> {max} ? $_[0]-> {max} : $_[1]);
329        $v -= $_[0]-> {min};
330        my $old = $_[0]-> {value};
331        if (abs($old - $v) >= $_[0]-> {threshold}) {
332                my ($x, $y) = $_[0]-> size;
333                my $i = $_[0]-> {indent};
334                my $range = ( $_[0]-> {max} - $_[0]-> {min}) || 1;
335                my $x1 = $i + ($x - $i*2) * $old / $range;
336                my $x2 = $i + ($x - $i*2) * $v   / $range;
337                ($x1, $x2) = ( $x2, $x1) if $x1 > $x2;
338                my $s = $_[0]-> {string};
339                $_[0]-> {value} = $v;
340                $_[0]-> notify(q(Stringify), $v, \$_[0]-> {string});
341                ( $_[0]-> {string} eq $s) ?
342                        $_[0]-> invalidate_rect( $x1, 0, $x2+1, $y) :
343                        $_[0]-> repaint;
344        }
345}
346
3471;
348
349TEST
350
351test(<<'TEST'); # AGENT/Makefile-DOM-0.008/t/Shell.pm
352sub run_test ($) {
353    my $block = shift;
354    #warn Dumper($block->cmd);
355
356    my $tempdir = tempdir( 'backend_XXXXXX', TMPDIR => 1, CLEANUP => 1 );
357    my $saved_cwd = Cwd::cwd;
358    chdir $tempdir;
359
360    process_pre($block);
361
362    my $cmd = [ split_arg($SHELL), '-c', $block->cmd() ];
363    if ($^O eq 'MSWin32' and $block->stdout and $block->stdout eq qq{\\"\n}) {
364        workaround($block, $cmd);
365    } else {
366        test_shell_command($block, $cmd);
367    }
368
369    process_found($block);
370    process_not_found($block);
371    process_post($block);
372
373    chdir $saved_cwd;
374}
375
376sub workaround (@) {
377    my ($block, $cmd) = @_;
378    my ($error_code, $stdout, $stderr) =
379        run_shell( $cmd );
380    #warn Dumper($stdout);
381    my $stdout2     = $block->stdout;
382    my $stderr2     = $block->stderr;
383    my $error_code2 = $block->error_code;
384
385    my $name = $block->name;
386    SKIP: {
387        skip 'Skip the test uncovers quoting issue on Win32', 3
388            if 1;
389        is ($stdout, $stdout2, "stdout - $name");
390        is ($stderr, $stderr2, "stderr - $name");
391        is ($error_code, $error_code2, "error_code - $name");
392    }
393}
394TEST
395
396test(<<'TEST'); # BPMEDLEY/Mojolicious-Plugin-SaveRequest-0.04/lib/Mojolicious/Plugin/SaveRequest.pm
397    print($handle qq(my \@exec = (
398        \@runme,
399        "get",
400        "-v",
401        "-M",
402        \$method,
403        "-c",
404        \$body,
405        map({ ("-H", \"\$_:\$headers{\$_}\") } keys \%headers),
406        \$url
407    );\n));
408TEST
409
410test(<<'TEST'); # HIO/Pod-MultiLang-0.14/lib/Pod/MultiLang/Dict/ja.pm
411sub make_linktext
412{
413  my ($pkg,$lang,$name,$section) = @_;
414  $name
415    ? $section ? qq($name �� "$section") : $name
416    : $section ? qq("$section") : undef;
417}
418TEST
419
420test(<<'TEST'); # KEICHNER/XML-Parsepp-Testgen-0.03/lib/XML/Parsepp/Testgen.pm
421                        if ($check_positions) {
422                            say {$ofh} q!!;
423                            say {$ofh} q!    my $e_line  = -1;!;
424                            say {$ofh} q!    my $e_col   = -1;!;
425                            say {$ofh} q!    my $e_bytes = -1;!;
426                            say {$ofh} q!!;
427                            say {$ofh} q!    if ($err =~ m{at \s+ line \s+ (\d+), \s+ column \s+ (\d+), \s+ byte \s+ (\d+) \s+ at \s+}xms)
428 {!;
429                            say {$ofh} q!        $e_line  = $1;!;
430                            say {$ofh} q!        $e_col   = $2;!;
431                            say {$ofh} q!        $e_bytes = $3;!;
432                            say {$ofh} q!    }!;
433                            say {$ofh} q!!;
434                            say {$ofh} q!    is($e_line,  !.sprintf('%4d', $rl->{e_line}) .q!, 'Test-!, sprintf('%03d', $tno), q!v1: error
435 - lineno');!;
436                            say {$ofh} q!    is($e_col,   !.sprintf('%4d', $rl->{e_col})  .q!, 'Test-!, sprintf('%03d', $tno), q!v2: error
437 - column');!;
438                            say {$ofh} q!    is($e_bytes, !.sprintf('%4d', $rl->{e_bytes}).q!, 'Test-!, sprintf('%03d', $tno), q!v3: error
439 - bytes');!;
440                            say {$ofh} q!!;
441                        }
442TEST
443
444test(<<'TEST'); # MBARBON/Devel-Debug-DBGp-0.06/DB/Text/Balanced.pm
445    {
446        $rdelspec = eval "qq{$rdel}" || do {
447            my $del;
448            for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',)
449                { next if $rdel =~ /\Q$_/; $del = $_; last }
450            unless ($del) {
451                use Carp;
452                croak "Can't interpolate right delimiter $rdel"
453            }
454            eval "qq$del$rdel$del";
455        };
456    }
457TEST
458
459test(<<'TEST'); # ABH/Authen-Bitcard-0.90/lib/Authen/Bitcard.pm
460sub _verify {
461    my $bc = shift;
462    my($msg, $key, $sig) = @_;
463    my $u1 = Math::BigInt->new("0b" . unpack("B*", sha1($msg)));
464    $sig->{s}->bmodinv($key->{q});
465    $u1 = ($u1 * $sig->{s}) % $key->{q};
466    $sig->{s} = ($sig->{r} * $sig->{s}) % $key->{q};
467    $key->{g}->bmodpow($u1, $key->{p});
468    $key->{pub_key}->bmodpow($sig->{s}, $key->{p});
469    $u1 = ($key->{g} * $key->{pub_key}) % $key->{p};
470    $u1 %= $key->{q};
471    $u1 == $sig->{r};
472}
473TEST
474
475done_testing;
476