--- /dev/null
+# Created with: ./make_t.pl
+
+# Contents:
+#1 scl.def
+#2 scl.scl
+#3 semicolon2.def
+#4 side_comments1.def
+#5 sil1.def
+#6 sil1.sil
+#7 slashslash.def
+#8 smart.def
+#9 space1.def
+#10 space2.def
+#11 space3.def
+#12 space4.def
+#13 space5.def
+#14 structure1.def
+#15 style.def
+#16 style.style1
+#17 style.style2
+#18 style.style3
+#19 style.style4
+#20 style.style5
+
+# To locate test #13 you can search for its name or the string '#13'
+
+use strict;
+use Test;
+use Carp;
+use Perl::Tidy;
+my $rparams;
+my $rsources;
+my $rtests;
+
+BEGIN {
+
+ ###########################################
+ # BEGIN SECTION 1: Parameter combinations #
+ ###########################################
+ $rparams = {
+ 'def' => "",
+ 'scl' => "-scl=12",
+ 'sil' => "-sil=0",
+ 'style1' => <<'----------',
+-b
+-se
+-w
+-i=2
+-l=100
+-nolq
+-bbt=1
+-bt=2
+-pt=2
+-nsfs
+-sbt=2
+-sbvt=2
+-nhsc
+-isbc
+-bvt=2
+-pvt=2
+-wbb="% + - * / x != == >= <= =~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
+-mbl=2
+----------
+ 'style2' => <<'----------',
+-bt=2
+-nwls=".."
+-nwrs=".."
+-pt=2
+-nsfs
+-sbt=2
+-cuddled-blocks
+-bar
+-nsbl
+-nbbc
+----------
+ 'style3' => <<'----------',
+-l=160
+-cbi=1
+-cpi=1
+-csbi=1
+-lp
+-nolq
+-csci=20
+-csct=40
+-csc
+-isbc
+-cuddled-blocks
+-nsbl
+-dcsc
+----------
+ 'style4' => <<'----------',
+-bt=2
+-pt=2
+-sbt=2
+-cuddled-blocks
+-bar
+----------
+ 'style5' => <<'----------',
+-b
+-bext="~"
+-et=8
+-l=77
+-cbi=2
+-cpi=2
+-csbi=2
+-ci=4
+-nolq
+-nasc
+-bt=2
+-ndsm
+-nwls="++ -- ?"
+-nwrs="++ --"
+-pt=2
+-nsfs
+-nsts
+-sbt=2
+-sbvt=1
+-wls="= .= =~ !~ :"
+-wrs="= .= =~ !~ ? :"
+-ncsc
+-isbc
+-msc=2
+-nolc
+-bvt=1
+-bl
+-sbl
+-pvt=1
+-wba="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x= . << >> -> && ||"
+-wbb=" "
+-cab=1
+-mbl=2
+----------
+ };
+
+ ############################
+ # BEGIN SECTION 2: Sources #
+ ############################
+ $rsources = {
+
+ 'scl' => <<'----------',
+ # try -scl=12 to see '$returns' joined with the previous line
+ $format = "format STDOUT =\n" . &format_line('Function: @') . '$name' . "\n" . &format_line('Arguments: @') . '$args' . "\n" . &format_line('Returns: @') . '$returns' . "\n" . &format_line(' ~~ ^') . '$desc' . "\n.\n";
+----------
+
+ 'semicolon2' => <<'----------',
+ # will not add semicolon for this block type
+ $highest = List::Util::reduce { Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b }
+----------
+
+ 'side_comments1' => <<'----------',
+ # side comments at different indentation levels should not be aligned
+ { { { { { ${msg} = "Hello World!"; print "My message: ${msg}\n"; } } #end level 4
+ } # end level 3
+ } # end level 2
+ } # end level 1
+----------
+
+ 'sil1' => <<'----------',
+#############################################################
+ # This will walk to the left because of bad -sil guess
+ SKIP: {
+#############################################################
+ }
+
+# This will walk to the right if it is the first line of a file.
+
+ ov_method mycan( $package, '(""' ), $package
+ or ov_method mycan( $package, '(0+' ), $package
+ or ov_method mycan( $package, '(bool' ), $package
+ or ov_method mycan( $package, '(nomethod' ), $package;
+
+----------
+
+ 'slashslash' => <<'----------',
+$home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7]
+ // die "You're homeless!\n";
+defined( $x // $y );
+$version = 'v' . join '.', map ord, split //, $version->PV;
+foreach ( split( //, $lets ) ) { }
+foreach ( split( //, $input ) ) { }
+'xyz' =~ //;
+----------
+
+ 'smart' => <<'----------',
+\&foo !~~ \&foo;
+\&foo ~~ \&foo;
+\&foo ~~ \&foo;
+\&foo ~~ sub {};
+sub {} ~~ \&foo;
+\&foo ~~ \&bar;
+\&bar ~~ \&foo;
+1 ~~ sub{shift};
+sub{shift} ~~ 1;
+0 ~~ sub{shift};
+sub{shift} ~~ 0;
+1 ~~ sub{scalar @_};
+sub{scalar @_} ~~ 1;
+[] ~~ \&bar;
+\&bar ~~ [];
+{} ~~ \&bar;
+\&bar ~~ {};
+qr// ~~ \&bar;
+\&bar ~~ qr//;
+a_const ~~ "a constant";
+"a constant" ~~ a_const;
+a_const ~~ a_const;
+a_const ~~ a_const;
+a_const ~~ b_const;
+b_const ~~ a_const;
+{} ~~ {};
+{} ~~ {};
+{} ~~ {1 => 2};
+{1 => 2} ~~ {};
+{1 => 2} ~~ {1 => 2};
+{1 => 2} ~~ {1 => 2};
+{1 => 2} ~~ {1 => 3};
+{1 => 3} ~~ {1 => 2};
+{1 => 2} ~~ {2 => 3};
+{2 => 3} ~~ {1 => 2};
+\%main:: ~~ {map {$_ => 'x'} keys %main::};
+{map {$_ => 'x'} keys %main::} ~~ \%main::;
+\%hash ~~ \%tied_hash;
+\%tied_hash ~~ \%hash;
+\%tied_hash ~~ \%tied_hash;
+\%tied_hash ~~ \%tied_hash;
+\%:: ~~ [keys %main::];
+[keys %main::] ~~ \%::;
+\%:: ~~ [];
+[] ~~ \%::;
+{"" => 1} ~~ [undef];
+[undef] ~~ {"" => 1};
+{foo => 1} ~~ qr/^(fo[ox])$/;
+qr/^(fo[ox])$/ ~~ {foo => 1};
++{0..100} ~~ qr/[13579]$/;
+qr/[13579]$/ ~~ +{0..100};
++{foo => 1, bar => 2} ~~ "foo";
+"foo" ~~ +{foo => 1, bar => 2};
++{foo => 1, bar => 2} ~~ "baz";
+"baz" ~~ +{foo => 1, bar => 2};
+[] ~~ [];
+[] ~~ [];
+[] ~~ [1];
+[1] ~~ [];
+[["foo"], ["bar"]] ~~ [qr/o/, qr/a/];
+[qr/o/, qr/a/] ~~ [["foo"], ["bar"]];
+["foo", "bar"] ~~ [qr/o/, qr/a/];
+[qr/o/, qr/a/] ~~ ["foo", "bar"];
+$deep1 ~~ $deep1;
+$deep1 ~~ $deep1;
+$deep1 ~~ $deep2;
+$deep2 ~~ $deep1;
+\@nums ~~ \@tied_nums;
+\@tied_nums ~~ \@nums;
+[qw(foo bar baz quux)] ~~ qr/x/;
+qr/x/ ~~ [qw(foo bar baz quux)];
+[qw(foo bar baz quux)] ~~ qr/y/;
+qr/y/ ~~ [qw(foo bar baz quux)];
+[qw(1foo 2bar)] ~~ 2;
+2 ~~ [qw(1foo 2bar)];
+[qw(1foo 2bar)] ~~ "2";
+"2" ~~ [qw(1foo 2bar)];
+2 ~~ 2;
+2 ~~ 2;
+2 ~~ 3;
+3 ~~ 2;
+2 ~~ "2";
+"2" ~~ 2;
+2 ~~ "2.0";
+"2.0" ~~ 2;
+2 ~~ "2bananas";
+"2bananas" ~~ 2;
+2_3 ~~ "2_3";
+"2_3" ~~ 2_3;
+qr/x/ ~~ "x";
+"x" ~~ qr/x/;
+qr/y/ ~~ "x";
+"x" ~~ qr/y/;
+12345 ~~ qr/3/;
+qr/3/ ~~ 12345;
+@nums ~~ 7;
+7 ~~ @nums;
+@nums ~~ \@nums;
+\@nums ~~ @nums;
+@nums ~~ \\@nums;
+\\@nums ~~ @nums;
+@nums ~~ [1..10];
+[1..10] ~~ @nums;
+@nums ~~ [0..9];
+[0..9] ~~ @nums;
+%hash ~~ "foo";
+"foo" ~~ %hash;
+%hash ~~ /bar/;
+/bar/ ~~ %hash;
+----------
+
+ 'space1' => <<'----------',
+ # We usually want a space at '} (', for example:
+ map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
+
+ # But not others:
+ &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
+
+ # remove unwanted spaces after $ and -> here
+ &{ $ _ -> [1] }( delete $ _ [$#_ ]{ $_ -> [0] } );
+----------
+
+ 'space2' => <<'----------',
+# space before this opening paren
+for$i(0..20){}
+
+# retain any space between '-' and bare word
+$myhash{USER-NAME}='steve';
+----------
+
+ 'space3' => <<'----------',
+# Treat newline as a whitespace. Otherwise, we might combine
+# 'Send' and '-recipients' here
+my $msg = new Fax::Send
+ -recipients => $to,
+ -data => $data;
+----------
+
+ 'space4' => <<'----------',
+# first prototype line will cause space between 'redirect' and '(' to close
+sub html::redirect($); #<-- temporary prototype;
+use html;
+print html::redirect ('http://www.glob.com.au/');
+----------
+
+ 'space5' => <<'----------',
+# first prototype line commented out; space after 'redirect' remains
+#sub html::redirect($); #<-- temporary prototype;
+use html;
+print html::redirect ('http://www.glob.com.au/');
+
+----------
+
+ 'structure1' => <<'----------',
+push@contents,$c->table({-width=>'100%'},$c->Tr($c->td({-align=>'left'},"The emboldened field names are mandatory, ","the remainder are optional",),$c->td({-align=>'right'},$c->a({-href=>'help.cgi',-target=>'_blank'},"What are the various fields?"))));
+----------
+
+ 'style' => <<'----------',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe {
+ my(@order) = ($hslabel_frame, $km_frame, $speed_frame[0],
+ $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
+ @speed_frame[1..$#speed_frame],
+ @power_frame[1..$#power_frame],
+ );
+ my(@col) = (0, 1, 3, 4+$#speed_frame, 5+$#speed_frame+$#power_frame,
+ 2, 6+$#speed_frame+$#power_frame,
+ 4..3+$#speed_frame,
+ 5+$#speed_frame..4+$#speed_frame+$#power_frame);
+ $top->idletasks;
+ my $width = 0;
+ my(%gridslaves) = map {($_, 1)} $top_frame->gridSlaves;
+ for(my $i = 0; $i <= $#order; $i++) {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ($gridslaves{$w}) {
+ $w->gridForget;
+ }
+ if ($width <= $top->width) {
+ $w->grid(-row => 0,
+ -column => $col,
+ -sticky => 'nsew'); # XXX
+ }
+ }
+}
+
+----------
+ };
+
+ ####################################
+ # BEGIN SECTION 3: Expected output #
+ ####################################
+ $rtests = {
+
+ 'scl.def' => {
+ source => "scl",
+ params => "def",
+ expect => <<'#1...........',
+ # try -scl=12 to see '$returns' joined with the previous line
+ $format =
+ "format STDOUT =\n"
+ . &format_line('Function: @') . '$name' . "\n"
+ . &format_line('Arguments: @') . '$args' . "\n"
+ . &format_line('Returns: @')
+ . '$returns' . "\n"
+ . &format_line(' ~~ ^') . '$desc' . "\n.\n";
+#1...........
+ },
+
+ 'scl.scl' => {
+ source => "scl",
+ params => "scl",
+ expect => <<'#2...........',
+ # try -scl=12 to see '$returns' joined with the previous line
+ $format =
+ "format STDOUT =\n"
+ . &format_line('Function: @') . '$name' . "\n"
+ . &format_line('Arguments: @') . '$args' . "\n"
+ . &format_line('Returns: @') . '$returns' . "\n"
+ . &format_line(' ~~ ^') . '$desc' . "\n.\n";
+#2...........
+ },
+
+ 'semicolon2.def' => {
+ source => "semicolon2",
+ params => "def",
+ expect => <<'#3...........',
+ # will not add semicolon for this block type
+ $highest = List::Util::reduce {
+ Sort::Versions::versioncmp( $a, $b ) > 0 ? $a : $b
+ }
+#3...........
+ },
+
+ 'side_comments1.def' => {
+ source => "side_comments1",
+ params => "def",
+ expect => <<'#4...........',
+ # side comments at different indentation levels should not be aligned
+ {
+ {
+ {
+ {
+ { ${msg} = "Hello World!"; print "My message: ${msg}\n"; }
+ } #end level 4
+ } # end level 3
+ } # end level 2
+ } # end level 1
+#4...........
+ },
+
+ 'sil1.def' => {
+ source => "sil1",
+ params => "def",
+ expect => <<'#5...........',
+#############################################################
+ # This will walk to the left because of bad -sil guess
+ SKIP: {
+#############################################################
+ }
+
+ # This will walk to the right if it is the first line of a file.
+
+ ov_method mycan( $package, '(""' ), $package
+ or ov_method mycan( $package, '(0+' ), $package
+ or ov_method mycan( $package, '(bool' ), $package
+ or ov_method mycan( $package, '(nomethod' ), $package;
+
+#5...........
+ },
+
+ 'sil1.sil' => {
+ source => "sil1",
+ params => "sil",
+ expect => <<'#6...........',
+#############################################################
+# This will walk to the left because of bad -sil guess
+SKIP: {
+#############################################################
+}
+
+# This will walk to the right if it is the first line of a file.
+
+ ov_method mycan( $package, '(""' ), $package
+ or ov_method mycan( $package, '(0+' ), $package
+ or ov_method mycan( $package, '(bool' ), $package
+ or ov_method mycan( $package, '(nomethod' ), $package;
+
+#6...........
+ },
+
+ 'slashslash.def' => {
+ source => "slashslash",
+ params => "def",
+ expect => <<'#7...........',
+$home = $ENV{HOME} // $ENV{LOGDIR} // ( getpwuid($<) )[7]
+ // die "You're homeless!\n";
+defined( $x // $y );
+$version = 'v' . join '.', map ord, split //, $version->PV;
+foreach ( split( //, $lets ) ) { }
+foreach ( split( //, $input ) ) { }
+'xyz' =~ //;
+#7...........
+ },
+
+ 'smart.def' => {
+ source => "smart",
+ params => "def",
+ expect => <<'#8...........',
+\&foo !~~ \&foo;
+\&foo ~~ \&foo;
+\&foo ~~ \&foo;
+\&foo ~~ sub { };
+sub { } ~~ \&foo;
+\&foo ~~ \&bar;
+\&bar ~~ \&foo;
+1 ~~ sub { shift };
+sub { shift } ~~ 1;
+0 ~~ sub { shift };
+sub { shift } ~~ 0;
+1 ~~ sub { scalar @_ };
+sub { scalar @_ } ~~ 1;
+[] ~~ \&bar;
+\&bar ~~ [];
+{} ~~ \&bar;
+\&bar ~~ {};
+qr// ~~ \&bar;
+\&bar ~~ qr//;
+a_const ~~ "a constant";
+"a constant" ~~ a_const;
+a_const ~~ a_const;
+a_const ~~ a_const;
+a_const ~~ b_const;
+b_const ~~ a_const;
+{} ~~ {};
+{} ~~ {};
+{} ~~ { 1 => 2 };
+{ 1 => 2 } ~~ {};
+{ 1 => 2 } ~~ { 1 => 2 };
+{ 1 => 2 } ~~ { 1 => 2 };
+{ 1 => 2 } ~~ { 1 => 3 };
+{ 1 => 3 } ~~ { 1 => 2 };
+{ 1 => 2 } ~~ { 2 => 3 };
+{ 2 => 3 } ~~ { 1 => 2 };
+\%main:: ~~ { map { $_ => 'x' } keys %main:: };
+{
+ map { $_ => 'x' } keys %main::
+}
+~~ \%main::;
+\%hash ~~ \%tied_hash;
+\%tied_hash ~~ \%hash;
+\%tied_hash ~~ \%tied_hash;
+\%tied_hash ~~ \%tied_hash;
+\%:: ~~ [ keys %main:: ];
+[ keys %main:: ] ~~ \%::;
+\%:: ~~ [];
+[] ~~ \%::;
+{ "" => 1 } ~~ [undef];
+[undef] ~~ { "" => 1 };
+{ foo => 1 } ~~ qr/^(fo[ox])$/;
+qr/^(fo[ox])$/ ~~ { foo => 1 };
++{ 0 .. 100 } ~~ qr/[13579]$/;
+qr/[13579]$/ ~~ +{ 0 .. 100 };
++{ foo => 1, bar => 2 } ~~ "foo";
+"foo" ~~ +{ foo => 1, bar => 2 };
++{ foo => 1, bar => 2 } ~~ "baz";
+"baz" ~~ +{ foo => 1, bar => 2 };
+[] ~~ [];
+[] ~~ [];
+[] ~~ [1];
+[1] ~~ [];
+[ ["foo"], ["bar"] ] ~~ [ qr/o/, qr/a/ ];
+[ qr/o/, qr/a/ ] ~~ [ ["foo"], ["bar"] ];
+[ "foo", "bar" ] ~~ [ qr/o/, qr/a/ ];
+[ qr/o/, qr/a/ ] ~~ [ "foo", "bar" ];
+$deep1 ~~ $deep1;
+$deep1 ~~ $deep1;
+$deep1 ~~ $deep2;
+$deep2 ~~ $deep1;
+\@nums ~~ \@tied_nums;
+\@tied_nums ~~ \@nums;
+[qw(foo bar baz quux)] ~~ qr/x/;
+qr/x/ ~~ [qw(foo bar baz quux)];
+[qw(foo bar baz quux)] ~~ qr/y/;
+qr/y/ ~~ [qw(foo bar baz quux)];
+[qw(1foo 2bar)] ~~ 2;
+2 ~~ [qw(1foo 2bar)];
+[qw(1foo 2bar)] ~~ "2";
+"2" ~~ [qw(1foo 2bar)];
+2 ~~ 2;
+2 ~~ 2;
+2 ~~ 3;
+3 ~~ 2;
+2 ~~ "2";
+"2" ~~ 2;
+2 ~~ "2.0";
+"2.0" ~~ 2;
+2 ~~ "2bananas";
+"2bananas" ~~ 2;
+2_3 ~~ "2_3";
+"2_3" ~~ 2_3;
+qr/x/ ~~ "x";
+"x" ~~ qr/x/;
+qr/y/ ~~ "x";
+"x" ~~ qr/y/;
+12345 ~~ qr/3/;
+qr/3/ ~~ 12345;
+@nums ~~ 7;
+7 ~~ @nums;
+@nums ~~ \@nums;
+\@nums ~~ @nums;
+@nums ~~ \\@nums;
+\\@nums ~~ @nums;
+@nums ~~ [ 1 .. 10 ];
+[ 1 .. 10 ] ~~ @nums;
+@nums ~~ [ 0 .. 9 ];
+[ 0 .. 9 ] ~~ @nums;
+%hash ~~ "foo";
+"foo" ~~ %hash;
+%hash ~~ /bar/;
+/bar/ ~~ %hash;
+#8...........
+ },
+
+ 'space1.def' => {
+ source => "space1",
+ params => "def",
+ expect => <<'#9...........',
+ # We usually want a space at '} (', for example:
+ map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
+
+ # But not others:
+ &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
+
+ # remove unwanted spaces after $ and -> here
+ &{ $_->[1] }( delete $_[$#_]{ $_->[0] } );
+#9...........
+ },
+
+ 'space2.def' => {
+ source => "space2",
+ params => "def",
+ expect => <<'#10...........',
+# space before this opening paren
+for $i ( 0 .. 20 ) { }
+
+# retain any space between '-' and bare word
+$myhash{ USER-NAME } = 'steve';
+#10...........
+ },
+
+ 'space3.def' => {
+ source => "space3",
+ params => "def",
+ expect => <<'#11...........',
+# Treat newline as a whitespace. Otherwise, we might combine
+# 'Send' and '-recipients' here
+my $msg = new Fax::Send
+ -recipients => $to,
+ -data => $data;
+#11...........
+ },
+
+ 'space4.def' => {
+ source => "space4",
+ params => "def",
+ expect => <<'#12...........',
+# first prototype line will cause space between 'redirect' and '(' to close
+sub html::redirect($); #<-- temporary prototype;
+use html;
+print html::redirect('http://www.glob.com.au/');
+#12...........
+ },
+
+ 'space5.def' => {
+ source => "space5",
+ params => "def",
+ expect => <<'#13...........',
+# first prototype line commented out; space after 'redirect' remains
+#sub html::redirect($); #<-- temporary prototype;
+use html;
+print html::redirect ('http://www.glob.com.au/');
+
+#13...........
+ },
+
+ 'structure1.def' => {
+ source => "structure1",
+ params => "def",
+ expect => <<'#14...........',
+push @contents,
+ $c->table(
+ { -width => '100%' },
+ $c->Tr(
+ $c->td(
+ { -align => 'left' },
+ "The emboldened field names are mandatory, ",
+ "the remainder are optional",
+ ),
+ $c->td(
+ { -align => 'right' },
+ $c->a(
+ { -href => 'help.cgi', -target => '_blank' },
+ "What are the various fields?"
+ )
+ )
+ )
+ );
+#14...........
+ },
+
+ 'style.def' => {
+ source => "style",
+ params => "def",
+ expect => <<'#15...........',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe {
+ my (@order) = (
+ $hslabel_frame,
+ $km_frame,
+ $speed_frame[0],
+ $power_frame[0],
+ $wind_frame,
+ $percent_frame,
+ $temp_frame,
+ @speed_frame[ 1 .. $#speed_frame ],
+ @power_frame[ 1 .. $#power_frame ],
+ );
+ my (@col) = (
+ 0,
+ 1,
+ 3,
+ 4 + $#speed_frame,
+ 5 + $#speed_frame + $#power_frame,
+ 2,
+ 6 + $#speed_frame + $#power_frame,
+ 4 .. 3 + $#speed_frame,
+ 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
+ );
+ $top->idletasks;
+ my $width = 0;
+ my (%gridslaves) = map { ( $_, 1 ) } $top_frame->gridSlaves;
+ for ( my $i = 0 ; $i <= $#order ; $i++ ) {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ( $gridslaves{$w} ) {
+ $w->gridForget;
+ }
+ if ( $width <= $top->width ) {
+ $w->grid(
+ -row => 0,
+ -column => $col,
+ -sticky => 'nsew'
+ ); # XXX
+ }
+ }
+}
+
+#15...........
+ },
+
+ 'style.style1' => {
+ source => "style",
+ params => "style1",
+ expect => <<'#16...........',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe {
+ my (@order) = (
+ $hslabel_frame, $km_frame, $speed_frame[0],
+ $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
+ @speed_frame[1 .. $#speed_frame],
+ @power_frame[1 .. $#power_frame],
+ );
+ my (@col) = (
+ 0, 1, 3,
+ 4 + $#speed_frame,
+ 5 + $#speed_frame + $#power_frame,
+ 2,
+ 6 + $#speed_frame + $#power_frame,
+ 4 .. 3 + $#speed_frame,
+ 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
+ );
+ $top->idletasks;
+ my $width = 0;
+ my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
+ for (my $i = 0; $i <= $#order; $i++) {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ($gridslaves{$w}) {
+ $w->gridForget;
+ }
+ if ($width <= $top->width) {
+ $w->grid(
+ -row => 0,
+ -column => $col,
+ -sticky => 'nsew'
+ ); # XXX
+ }
+ }
+}
+
+#16...........
+ },
+
+ 'style.style2' => {
+ source => "style",
+ params => "style2",
+ expect => <<'#17...........',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe {
+ my (@order) = (
+ $hslabel_frame, $km_frame,
+ $speed_frame[0], $power_frame[0],
+ $wind_frame, $percent_frame,
+ $temp_frame, @speed_frame[1..$#speed_frame],
+ @power_frame[1..$#power_frame],
+ );
+ my (@col) = (
+ 0,
+ 1,
+ 3,
+ 4 + $#speed_frame,
+ 5 + $#speed_frame + $#power_frame,
+ 2,
+ 6 + $#speed_frame + $#power_frame,
+ 4..3 + $#speed_frame,
+ 5 + $#speed_frame..4 + $#speed_frame + $#power_frame
+ );
+ $top->idletasks;
+ my $width = 0;
+ my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
+ for (my $i = 0; $i <= $#order; $i++) {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ($gridslaves{$w}) {
+ $w->gridForget;
+ }
+ if ($width <= $top->width) {
+ $w->grid(
+ -row => 0,
+ -column => $col,
+ -sticky => 'nsew'
+ ); # XXX
+ }
+ }
+}
+
+#17...........
+ },
+
+ 'style.style3' => {
+ source => "style",
+ params => "style3",
+ expect => <<'#18...........',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe {
+ my (@order) = (
+ $hslabel_frame, $km_frame, $speed_frame[0], $power_frame[0], $wind_frame, $percent_frame, $temp_frame,
+ @speed_frame[ 1 .. $#speed_frame ],
+ @power_frame[ 1 .. $#power_frame ],
+ );
+ my (@col) = (
+ 0, 1, 3,
+ 4 + $#speed_frame,
+ 5 + $#speed_frame + $#power_frame,
+ 2,
+ 6 + $#speed_frame + $#power_frame,
+ 4 .. 3 + $#speed_frame,
+ 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
+ );
+ $top->idletasks;
+ my $width = 0;
+ my (%gridslaves) = map { ( $_, 1 ) } $top_frame->gridSlaves;
+ for ( my $i = 0 ; $i <= $#order ; $i++ ) {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ( $gridslaves{$w} ) {
+ $w->gridForget;
+ }
+ if ( $width <= $top->width ) {
+ $w->grid(
+ -row => 0,
+ -column => $col,
+ -sticky => 'nsew'
+ ); # XXX
+ }
+ }
+} ## end sub arrange_topframe
+
+#18...........
+ },
+
+ 'style.style4' => {
+ source => "style",
+ params => "style4",
+ expect => <<'#19...........',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe {
+ my (@order) = (
+ $hslabel_frame, $km_frame,
+ $speed_frame[0], $power_frame[0],
+ $wind_frame, $percent_frame,
+ $temp_frame, @speed_frame[1 .. $#speed_frame],
+ @power_frame[1 .. $#power_frame],
+ );
+ my (@col) = (
+ 0,
+ 1,
+ 3,
+ 4 + $#speed_frame,
+ 5 + $#speed_frame + $#power_frame,
+ 2,
+ 6 + $#speed_frame + $#power_frame,
+ 4 .. 3 + $#speed_frame,
+ 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
+ );
+ $top->idletasks;
+ my $width = 0;
+ my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
+ for (my $i = 0 ; $i <= $#order ; $i++) {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ($gridslaves{$w}) {
+ $w->gridForget;
+ }
+ if ($width <= $top->width) {
+ $w->grid(
+ -row => 0,
+ -column => $col,
+ -sticky => 'nsew'
+ ); # XXX
+ }
+ }
+}
+
+#19...........
+ },
+
+ 'style.style5' => {
+ source => "style",
+ params => "style5",
+ expect => <<'#20...........',
+# This test snippet is from package bbbike v3.214 by Slaven Rezic; GPL 2.0 licence
+sub arrange_topframe
+{
+ my (@order) = (
+ $hslabel_frame, $km_frame,
+ $speed_frame[0], $power_frame[0],
+ $wind_frame, $percent_frame,
+ $temp_frame, @speed_frame[1 .. $#speed_frame],
+ @power_frame[1 .. $#power_frame],
+ );
+ my (@col) = (
+ 0,
+ 1,
+ 3,
+ 4 + $#speed_frame,
+ 5 + $#speed_frame + $#power_frame,
+ 2,
+ 6 + $#speed_frame + $#power_frame,
+ 4 .. 3 + $#speed_frame,
+ 5 + $#speed_frame .. 4 + $#speed_frame + $#power_frame
+ );
+ $top->idletasks;
+ my $width = 0;
+ my (%gridslaves) = map { ($_, 1) } $top_frame->gridSlaves;
+ for (my $i = 0; $i <= $#order; $i++)
+ {
+ my $w = $order[$i];
+ next unless Tk::Exists($w);
+ my $col = $col[$i] || 0;
+ $width += $w->reqwidth;
+ if ($gridslaves{$w})
+ {
+ $w->gridForget;
+ }
+ if ($width <= $top->width)
+ {
+ $w->grid(
+ -row => 0,
+ -column => $col,
+ -sticky => 'nsew'
+ ); # XXX
+ }
+ }
+}
+
+#20...........
+ },
+ };
+
+ my $ntests = 0 + keys %{$rtests};
+ plan tests => $ntests;
+}
+
+###############
+# EXECUTE TESTS
+###############
+
+foreach my $key ( sort keys %{$rtests} ) {
+ my $output;
+ my $sname = $rtests->{$key}->{source};
+ my $expect = $rtests->{$key}->{expect};
+ my $pname = $rtests->{$key}->{params};
+ my $source = $rsources->{$sname};
+ my $params = defined($pname) ? $rparams->{$pname} : "";
+ my $stderr_string;
+ my $errorfile_string;
+ my $err = Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$output,
+ perltidyrc => \$params,
+ argv => '', # for safety; hide any ARGV from perltidy
+ stderr => \$stderr_string,
+ errorfile => \$errorfile_string, # not used when -se flag is set
+ );
+ if ( $err || $stderr_string || $errorfile_string ) {
+ if ($err) {
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$err );
+ }
+ if ($stderr_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<STDERR>>\n$stderr_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$stderr_string );
+ }
+ if ($errorfile_string) {
+ print STDERR "---------------------\n";
+ print STDERR "<<.ERR file>>\n$errorfile_string\n";
+ print STDERR "---------------------\n";
+ print STDERR
+"This error received calling Perl::Tidy with '$sname' + '$pname'\n";
+ ok( !$errorfile_string );
+ }
+ }
+ else {
+ ok( $output, $expect );
+ }
+}
projects / perltidy.git / blobdiff