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